initial tests for pattern-specializer stuff

diff --git a/language-extension.pattern-specializer.asd b/language-extension.pattern-specializer.asd
index 1377c8791b40eacc0e1361ebdd822953577da64e..6e5ae96a1915751d7765d678b7fc4b4bc3a7f8b0 100644 (file)
--- a/language-extension.pattern-specializer.asd
+++ b/language-extension.pattern-specializer.asd
@@ -27,4 +27,23 @@
                  :components ((:file       "package")
                               (:file       "protocol")
                               (:file       "optima-extensions")
-                              (:file       "pattern-specializer")))))
+                              (:file       "pattern-specializer"))))
+
+  :in-order-to ((test-op (test-op :language-extension.pattern-specializer-test))))
+
+(defsystem :language-extension.pattern-specializer-test
+  :author      "Jan Moringen <jmoringe@techfak.uni-bielefeld.de>"
+  :license     "LLGPLv3; see COPYING file for details."
+  :description "Tests for the language-extension.pattern-specializer system."
+  :depends-on  (:fiveam
+
+                :language-extension.pattern-specializer)
+  :components  ((:module     "test"
+                 :pathname   "test/pattern-specializer"
+                 :serial     t
+                 :components ((:file       "package")
+                              (:file       "optima-extensions")))))
+
+(defmethod perform ((operation test-op)
+                    (component (eql (find-system :language-extension.pattern-specializer-test))))
+  (funcall (read-from-string "pattern-specializer.test:run-tests")))

diff --git a/test/pattern-specializer/optima-extensions.lisp b/test/pattern-specializer/optima-extensions.lisp
new file mode 100644 (file)
index 0000000..ba8ef46
--- /dev/null
+++ b/test/pattern-specializer/optima-extensions.lisp
@@ -0,0 +1,225 @@
+;;;; optima-extensions.lisp --- Tests for extensions of the optima library.
+;;;;
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+
+(cl:in-package #:pattern-specializer.test)
+
+(def-suite :optima-extensions.pattern-more-specific-p
+    :in :pattern-specializer)
+(in-suite :optima-extensions.pattern-more-specific-p)
+
+(defun process-case (case)
+  (destructuring-bind (pattern1 pattern2 expected) case
+    (let* ((pattern1/parsed (optima.core:parse-pattern pattern1))
+           (pattern2/parsed (optima.core:parse-pattern pattern2))
+           (result (pattern-specializer::pattern-more-specific-p
+                    pattern1/parsed pattern2/parsed)))
+      (is (eq expected result)
+          "~S < ~S => ~S [not ~S]" pattern1 pattern2 result expected))))
+
+(optima.core:parse-pattern '(and x))
+
+(test constant-pattern
+  (mapc #'process-case
+        '((1 1         =)
+          (1 2         /=)
+          ("foo" "foo" =)
+          ("foo" "bar" /=))))
+
+(test variable-pattern
+  (mapc #'process-case
+        '((x          x          =)
+          (x          y          =)
+          (1          y          <)
+          ((cons x y) y          <)
+          (x          1          >)
+          (x          (cons x y) >))))
+
+(test and-pattern
+  ;; Cannot test patterns of the form (and SUB-PATTERN) since optima
+  ;; reduces these to just SUB-PATTERN.
+  (mapc #'process-case
+        '((x            (and x y)    =)
+          (x            (and 1 y)    >)
+          (x            (and x 1)    >)
+          (x            (and 1 2)    >)
+          (1            (and x y)    <)
+          (1            (and 1 y)    =)
+          (1            (and x 1)    =)
+          (1            (and 1 1)    =)
+          (1            (and 1 2)    /=)
+          ((cons x y)   (and 1 2)    /=)
+
+          ((and x y)    x            =)
+          ((and 1 y)    x            <)
+          ((and x 1)    x            <)
+          ((and 1 2)    x            <)
+          ((and x y)    1            >)
+          ((and 1 y)    1            =)
+          ((and x 1)    1            =)
+          ((and 1 1)    1            =)
+          ((and 1 2)    1            /=)
+          ((and 1 2)    (cons x y)   /=)
+
+          ((and x y)    (and x y)    =)
+          ((and x y)    (and x z)    =)
+          ((and x y)    (and 1 y)    >)
+          ((and x y)    (and x 1)    >)
+          ((and x y)    (and 1 2)    >)
+          ((and 1 y)    (and x y)    <)
+          ((and x 1)    (and x y)    <)
+          ((and 1 2)    (and x y)    <)
+          ((and 1 y)    (and 1 1)    =)
+          ((and x 1)    (and 1 1)    =)
+          ((and 1 2)    (and 1 1)    /=)
+          ((and 1 1)    (and 1 y)    =)
+          ((and 1 1)    (and x 1)    =)
+          ((and 1 1)    (and 1 2)    /=)
+          ((and 1 1)    (and 1 1)    =)
+
+          ((cons 1 2)   (and (cons 1 y) (cons x 2)) =))))
+
+(test or-pattern
+  ;; Cannot test patterns of the form (or SUB-PATTERN) since optima
+  ;; reduces these to just SUB-PATTERN.
+  (mapc #'process-case
+        '((x          (or x y)    =)
+          (x          (or 1 y)    =)
+          (x          (or x 1)    =)
+          (x          (or 1 2)    >)
+          (1          (or x y)    <)
+          (1          (or 1 y)    <)
+          (1          (or x 1)    <)
+          (1          (or 1 1)    =)
+          (1          (or 1 2)    <)
+          ((cons x y) (or 1 2)    /=)
+
+          ((or x y)   x           =)
+          ((or 1 y)   x           =)
+          ((or x 1)   x           =)
+          ((or 1 2)   x           <)
+          ((or x y)   1           >)
+          ((or 1 y)   1           >)
+          ((or x 1)   1           >)
+          ((or 1 1)   1           =)
+          ((or 1 2)   1           >)
+          ((or 1 2)   (cons x y)  /=)
+
+          ((or x y)   (or x y)    =)
+          ((or x y)   (or x z)    =)
+          ((or x y)   (or 1 y)    =)
+          ((or x y)   (or x 1)    =)
+          ((or x y)   (or 1 2)    >)
+          ((or 1 y)   (or x y)    =)
+          ((or x 1)   (or x y)    =)
+          ((or 1 2)   (or x y)    <)
+          ((or 1 y)   (or 1 1)    >)
+          ((or x 1)   (or 1 1)    >)
+          ((or 1 2)   (or 1 1)    >)
+          ((or 1 1)   (or 1 y)    <)
+          ((or 1 1)   (or x 1)    <)
+          ((or 1 1)   (or 1 2)    <)
+          ((or 1 1)   (or 1 1)    =)
+
+          ((cons 1 2) (or (cons 1 y) (cons x 2)) <))))
+
+(test cons-pattern
+
+  (mapc #'process-case
+        '(((cons 1 1) 1          /=)
+          ((cons 1 1) x          <)
+
+          ((cons 1 1) (cons 1 1) =)
+          ((cons 1 2) (cons 1 1) /=)
+          ((cons 1 x) (cons 1 1) >)
+          ((cons 2 1) (cons 1 1) /=)
+          ((cons x 1) (cons 1 1) >))))
+
+;;; class-pattern
+
+(defclass foo ()
+  ((bar :initarg :bar)
+   (baz :initarg :baz)))
+(sb-mop:finalize-inheritance (find-class 'foo)) ; TODO optima bug?
+
+(defclass fez (foo) ())
+(sb-mop:finalize-inheritance (find-class 'fez)) ; TODO optima bug?
+
+(test class-pattern
+
+  (mapc #'process-case
+        '(((class real)       (class real)              =)
+          ((class real)       (class string)            /=)
+          ((class real)       (class integer)           >)
+
+          ((class integer)    (class real)              <)
+          ((class integer)    (class string)            /=)
+          ((class integer)    (class integer)           =)
+
+          ((class foo)        (class foo)               =)
+          ((class foo)        (class foo :bar x)        >)
+          ((class foo)        (class foo :bar 1)        >)
+          ((class foo)        (class foo :baz x)        >)
+          ((class foo)        (class foo :baz 1)        >)
+          ((class foo)        (class foo :bar x :baz 1) >)
+          ((class foo)        (class foo :bar 1 :baz 1) >)
+          ((class foo)        (class fez)               >)
+          ((class foo)        (class fez :bar x)        >)
+          ((class foo)        (class fez :bar 1)        >)
+          ((class foo)        (class fez :baz x)        >)
+          ((class foo)        (class fez :baz 1)        >)
+          ((class foo)        (class fez :bar x :baz 1) >)
+          ((class foo)        (class fez :bar 1 :baz 1) >)
+
+          ((class foo :bar x) (class foo)               <)
+          ((class foo :bar x) (class foo :bar x)        =)
+          ((class foo :bar x) (class foo :bar 1)        >)
+          ((class foo :bar x) (class foo :baz x)        /=)
+          ((class foo :bar x) (class foo :baz 1)        /=)
+          ((class foo :bar x) (class foo :bar x :baz 1) >)
+          ((class foo :bar x) (class foo :bar 1 :baz 1) >)
+          ((class foo :bar x) (class fez)               /=)
+          ((class foo :bar x) (class fez :bar x)        >)
+          ((class foo :bar x) (class fez :bar 1)        >)
+          ((class foo :bar x) (class fez :baz x)        /=)
+          ((class foo :bar x) (class fez :baz 1)        /=)
+          ((class foo :bar x) (class fez :bar x :baz 1) >)
+          ((class foo :bar x) (class fez :bar 1 :baz 1) >)
+
+          ((class foo :bar 1) (class foo)               <)
+          ((class foo :bar 1) (class foo :bar x)        <)
+          ((class foo :bar 1) (class foo :bar 1)        =)
+          ((class foo :bar 1) (class foo :baz x)        /=)
+          ((class foo :bar 1) (class foo :baz 1)        /=)
+          ((class foo :bar 1) (class foo :bar x :baz 1) /=)
+          ((class foo :bar 1) (class foo :bar 1 :baz 1) >)
+          ((class foo :bar 1) (class fez)               /=)
+          ((class foo :bar 1) (class fez :bar x)        /=)
+          ((class foo :bar 1) (class fez :bar 1)        >)
+          ((class foo :bar 1) (class fez :baz x)        /=)
+          ((class foo :bar 1) (class fez :baz 1)        /=)
+          ((class foo :bar 1) (class fez :bar x :baz 1) /=)
+          ((class foo :bar 1) (class fez :bar 1 :baz 1) >)
+
+          ((class fez)        (class foo)               <)
+          ((class fez)        (class foo :bar x)        /=)
+          ((class fez)        (class foo :bar 1)        /=)
+          ((class fez)        (class foo :baz x)        /=)
+          ((class fez)        (class foo :baz 1)        /=)
+          ((class fez)        (class foo :bar x :baz 1) /=)
+          ((class fez)        (class foo :bar 1 :baz 1) /=)
+          ((class fez)        (class fez)               =)
+          ((class fez)        (class fez :bar x)        >)
+          ((class fez)        (class fez :bar 1)        >)
+          ((class fez)        (class fez :baz x)        >)
+          ((class fez)        (class fez :baz 1)        >)
+          ((class fez)        (class fez :bar x :baz 1) >)
+          ((class fez)        (class fez :bar 1 :baz 1) >)
+
+          ((class foo :bar x) (class foo)               <)
+
+          ((class foo :baz 1) (class foo)               <)
+
+          ((class foo :bar x) (class foo)               <))))

diff --git a/test/pattern-specializer/package.lisp b/test/pattern-specializer/package.lisp
new file mode 100644 (file)
index 0000000..8244f18
--- /dev/null
+++ b/test/pattern-specializer/package.lisp
@@ -0,0 +1,22 @@
+;;;; package.lisp ---
+;;;;
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+
+(cl:defpackage #:pattern-specializer.test
+  (:use
+   #:cl
+   #:alexandria
+
+   #:fiveam)
+
+  (:export
+   #:run-tests))
+
+(cl:in-package #:pattern-specializer.test)
+
+(def-suite :pattern-specializer)
+
+(defun run-tests ()
+  (run! :pattern-specializer))