From 96068870488697c6f4d24c264a3bfafe5168cace Mon Sep 17 00:00:00 2001 From: Jan Moringen Date: Mon, 14 Apr 2014 00:47:11 +0200 Subject: [PATCH] initial tests for pattern-specializer stuff --- language-extension.pattern-specializer.asd | 21 +- .../optima-extensions.lisp | 225 ++++++++++++++++++ test/pattern-specializer/package.lisp | 22 ++ 3 files changed, 267 insertions(+), 1 deletion(-) create mode 100644 test/pattern-specializer/optima-extensions.lisp create mode 100644 test/pattern-specializer/package.lisp diff --git a/language-extension.pattern-specializer.asd b/language-extension.pattern-specializer.asd index 1377c87..6e5ae96 100644 --- 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 " + :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 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 + +(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 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 + +(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)) -- 2.30.2