Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
485 lines (451 sloc) 13.5 KB
(defpackage :optima.test
(:use :cl :eos :optima :optima.extra :optima.ppcre)
(:import-from :optima.core #:parse-pattern #:unparse-pattern)
(:shadowing-import-from :optima #:fail))
(in-package :optima.test)
(def-suite optima-test)
(in-suite optima-test)
;;; Pattern syntax
(test roundtrip
(macrolet
((check-roundtrip (pattern)
`(is (equal ',pattern
(unparse-pattern (parse-pattern ',pattern))))))
;; constant
(check-roundtrip 1)
(check-roundtrip t)
(check-roundtrip nil)
(check-roundtrip :foo)
(check-roundtrip 3.14)
(check-roundtrip "foo")
(check-roundtrip 'x)
(check-roundtrip '(x . y))
(check-roundtrip '(x y))
(check-roundtrip '(1 :foo))
;; variable
; (check-roundtrip _) does not roundtrip, but that's probably OK.
(check-roundtrip x)))
;;; Pattern matching
(defmacro is-match (arg pattern)
`(is-true (match ,arg (,pattern t))))
(defmacro is-not-match (arg pattern)
`(is-false (match ,arg (,pattern t))))
(test empty
(is-true (match 1 (_ (fail)) (_ t))))
(test constant-pattern
;; integer
(is-match 1 1)
;; t
(is-match t t)
;; nil
(is-match nil nil)
;; keyword
(is-match :foo :foo)
;; float
(is-match 3.14 3.14)
(is-not-match 0.999 1)
;; string
(is-match "foo" "foo")
;; complex
(is-match '(1 t 3.14 :foo "foo") '(1 t 3.14 :foo "foo")))
(test variable-pattern
;; simple bind
(is (eql (match 1 (x x)) 1))
;; anonymous bind
(is-match 1 _)
;; complex bind
(is (eql (match '(1 2 3)
((list x y z) (+ x y z)))
6)))
(test place-pattern
;; level 0
(let ((z 1))
(match z ((place x) (incf x)))
(is (eql z 2)))
;; level 1
(let ((z (cons 1 2)))
(match z
((cons (place x) y)
(incf x)
(incf y)))
(is (equal z (cons 2 2))))
;; level 2
(let ((z (list (vector 1))))
(match z
((list (vector (place x)))
(incf x)))
(is (equalp z (list (vector 2))))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass person ()
((name :initarg :name)
(age :initarg :age)))
(defstruct (point (:predicate point-p))
x y))
(test constructor-pattern
;; cons
(is-match (cons 1 2) (cons 1 2))
;; assoc
(is-match '((1 . 2)) (assoc 1 2))
(is-match '((1 . 2) (3 . 4)) (assoc 3 4))
(is-match '(1 (2 . 3)) (assoc 2 3))
(is-match '((a . 1)) (assoc a 1))
(is-not-match 1 (assoc 1 2))
(is-not-match '((1 . 2)) (assoc 3 4))
(is-not-match '((1 . 2) (3 . 4)) (assoc 3 5))
(is-match '(("a" . 1)) (assoc "A" 1 :test string-equal))
;; property
(is-match '(:a 1) (property :a 1))
(is-match '(:a 1 :b 2) (property :a 1))
(is-match '(:a 1 2) (property :a 1))
(is-match '(1 2 :b 3) (property :b 3))
(is-match '(a 1) (property a 1))
(is-not-match 1 (property :a 1))
(is-not-match '(:a 1) (property :b 1))
(is-not-match '(:a 1 :b 2) (property :b 3))
;; vector
(is-match (vector 1 2) (vector 1 2))
;; simple-vector
(is-match (vector 1 2) (simple-vector 1 2))
;; class
(let ((person (make-instance 'person :name "Bob" :age 31)))
(is (equal (match person
((person name age) (list name age)))
'("Bob" 31)))
(is-match person (person))
(is-match person (person (name "Bob") (age 31)))
(is-match person (person (name "Bob")))
(is-match person (person (age 31)))
(is-not-match person (person (name "Alice")))
(is-not-match person (person (age 49)))
(is-not-match 1 (person))
;; make-instance style
(is-match person (person :name "Bob" :age 31))
(is-not-match person (person :name "Bob" :age 49)))
;; structure
(let ((point (make-point :x 1 :y 2)))
(is (equal (match point
((point- x y) (list x y)))
'(1 2)))
(is-match point (point))
(is-match point (point (x 1) (y 2)))
(is-match point (point (x 1)))
(is-match point (point (y 2)))
(is-not-match point (point (x 2)))
(is-not-match 1 (point-))
(is-match point (point-))
(is-match point (point- (x 1) (y 2)))
(is-match point (point- (x 1)))
(is-match point (point- (y 2)))
(is-not-match point (point- (x 2)))
(is-not-match 1 (point-))
;; make-instance style
(is-match point (point- :x 1 :y 2))
(is-not-match point (point- :x 2 :y 2))))
(test derived-pattern
;; list
(is-match '() (list))
(is-match '(1 2 3) (list 1 2 3))
(is-not-match '() (list _))
(is-not-match 5 (list _))
;; list*
(is-match '() (list* _))
(is-match '(1 2 3) (list* 1 2 (list 3)))
(is-match '(1 2 3) (list* _))
(is-match 5 (list* _))
(is-match '(1 2 . 3) (list* _ _ _))
(is-not-match '(1 2 . 3) (list* _ _ _ _))
;; alist
(is-match '((1 . 2) (2 . 3) (3 . 4)) (alist (3 . 4) (1 . 2)))
;; plist
(is-match '(:a 1 :b 2 :c 3) (plist :c 3 :a 1))
;; satisfies
(is-match 1 (satisfies numberp))
(is-not-match 1 (satisfies stringp))
;; eq, eql, equal, equalp
(is-match :foo (eq :foo))
(is-match 1 (eql 1))
(is-match "foo" (equal "foo"))
(is-match #(1) (equalp #(1)))
;; type
(is-match 1 (type number))
(is-match "foo" (type string))
(is-match :foo (type (eql :foo)))
(is-match 1 (type (or string number)))
(is-not-match 1 (type (not t))))
(test guard-pattern
(is-match 1 (guard _ t))
(is-not-match 1 (guard _ nil))
(is-match 1 (guard 1 t))
(is-not-match 1 (guard 1 nil))
(is-not-match 1 (guard 2 t))
(is-match 1 (guard x (eql x 1)))
;; lift
(is-match 1 (and x (guard y (eql x y))))
(is-match 1 (and (guard x (eql x y)) y))
(is-not-match 1 (and x (guard 2 (eql x 1))))
(is-not-match 1 (and x (guard y (not (eql x y)))))
(is-match '(1 1) (list x (guard y (eql x y))))
(is-match '(1 1) (list (guard x (oddp x)) (guard y (eql x y))))
(is-not-match '(1 2) (list (guard x (oddp x)) (guard y (eql x y))))
(is-match '(1 (1)) (list x (guard (list (guard y (eql x y))) (eql x 1))))
(is-not-match '(1 (1)) (list x (guard (list (guard y (eql x y))) (eql x 2))))
(is-match 1 (or (list x) (guard x (oddp x))))
(is-match '(1) (or (list x) (guard x (oddp x))))
(is-not-match 1 (or (list x) (guard x (evenp x))))
(is-match '(1) (list (or (list x) (guard x (oddp x)))))
(is-not-match '(1) (or (list (or (list x) (guard x (evenp x))))
(list (guard x (eql x 2)))))
(is-match '(2) (or (list (or (list x) (guard x (evenp x))))
(list (guard x (eql x 2)))))
(is-match (list 2 2) (list (or (guard x (eql x 1))
(guard x (eql x 2)))
(or (guard y (eql y 1))
(guard y (eql y 2)))))
(is-match 2 (or (guard x (eql x 1))
(guard x (eql x 2))))
(is-match 5 (or (guard x (eql x 1))
(or (guard x (eql x 2))
(or (guard x (eql x 3))
(or (guard x (eql x 4))
(guard x (eql x 5)))))))
(is-match '(((1)))
(list (or (guard x (eql x 1))
(list (or (guard x (eql x 1))
(list (or (guard x (eql x 1))
(list)))))))))
(test not-pattern
(is-match 1 (not 2))
(is-not-match 1 (not 1))
;; double negation
(is-not-match 1 (not (not (not 1))))
(is-match 1 (not (not (not (not 1)))))
;; complex
(is-match 1 (not (guard it (consp it))))
(is (equal (let ((it 1))
(match 2 ((not (guard it (eql it 3))) it)))
1)))
(test or-pattern
(is-not-match 1 (or))
(is-match 1 (or 1))
(is-match 1 (or 1 1))
(is-match 1 (or 1 2))
(is-match 1 (or 2 1))
(is-not-match 1 (or 2 3))
(is-match 1 (or _))
(is-match 1 (or _ _))
(is-match 1 (or 2 (or 1)))
(is-match 1 (or (or 1)))
(is-not-match 1 (or (or (not 1))))
;; unshared variables
(is (equal (match 1 ((or 1 (list x) y) (list x y)))
'(nil nil)))
(is (equal (match 2 ((or 1 (list x) y) (list x y)))
'(nil 2)))
(is (equal (match '(1) ((or 1 (list x) y) (list x y)))
'(1 nil))))
(test and-pattern
(is-match 1 (and))
(is-match 1 (and 1))
(is-match 1 (and 1 1))
(is-not-match 1 (and 1 2))
(is-match 1 (and _))
(is-match 1 (and _ _))
(is-match 1 (and 1 (and 1)))
(is-match 1 (and (and 1)))
(is (eql (match 1 ((and 1 x) x)) 1))
(is-not-match 1 (and (and (not 1))))
(is-match 1 (and (type number) (type integer)))
;; complex
(is-true (match 1
((and 1 2) nil)
(1 t)
(2 nil)))
(is (eql (match (list 1 2)
((list (and 1 x) 2) x))
1))
(is-true (match (list 1 2 3)
((list (and 1 2 3 4 5) 2))
((list (and 1 (type number)) 3 3))
((list (and 1 (type number)) 2 3) t)))
(is-true (match (list 2 2)
((list (and 2 (type number)) 3))
((list (and 2 (type number)) 2 3))
((list (and 1 (type number)) 2))
((list (and 2 (type number)) 2) t))))
(test match
;; empty
(is-false (match 1))
;; values
(is (equal (multiple-value-list (match 1 (1 (values 1 2 3))))
'(1 2 3)))
;; mixture
(is-true (match (cons 1 2)
((cons 2 1) 2)
(_ t)
((cons 1 2) nil)))
;; fail
(is-false (match 1
(1 (fail))))
(is-true (match 1
(1 (fail))
(1 t)))
(is-true (match 1
(1 (fail))
(1 t)
(_ nil)))
(is (eql (match (cons 1 2)
((cons x y)
(if (eql x 1)
(fail)
y))
((cons x 2)
x))
1))
;; linear pattern
(signals error
(macroexpand
'(match (cons 1 2)
((cons x x) t))))
(signals error
(macroexpand
'(match (list 1 (list 2 3))
((list x (list y x)) t))))
(signals error
(macroexpand
'(match (list 1 (list 2 3))
((list x (list y y)) t))))
(signals error
(macroexpand
'(match 1
((and x x) t))))
(is-match 1 (and _ _))
(is-match 1 (or _ _))
;; declarations
(is-true (match 1
(1 (declare (ignore)) t)))
(is-true (match 1
(1 when t (declare (ignore)) t)))
(is-true (match 1
((guard 1 t) (declare (ignore)) t)))
;; syntax sugar
(is-true (match 1 (_ when t t)))
(is-true (match 1 (_ unless nil t))))
(test multiple-value-match
(is (eql (multiple-value-match (values 1 2)
((2) 1)
((1 y) y))
2))
;; fail
(is-true (multiple-value-match (values 1 2)
((1 2) (fail))
((_ _) t)))
;; linear pattern
(signals error
(macroexpand
'(multiple-value-match (values 1 2)
((x x) t))))
(is-true (multiple-value-match 1
((_ _) t))))
(test ematch
(is-true (ematch 1 (1 t)))
(signals match-error
(ematch 1 (2 t)))
;; fail
(is-true (ematch 1
(1 (fail))
(_ t)))
(signals match-error
(ematch 1
(1 (fail))
(1 (fail))))
;; only once
(let ((count 0))
(flet ((f () (incf count)))
(is (eql (handler-case (ematch (f) (0 t))
(match-error (e)
(first (match-error-values e))))
1)))))
(test multiple-value-ematch
(signals match-error
(multiple-value-ematch (values 1 2)
((2 1) t)))
;; fail
(signals match-error
(multiple-value-ematch (values 1 2)
((1 2) (fail))))
;; only once
(let ((count 0))
(flet ((f () (incf count)))
(is (eql (handler-case (multiple-value-ematch (values (f)) ((0) t))
(match-error (e)
(first (match-error-values e))))
1)))))
(test cmatch
(is-true (cmatch 1 (1 t)))
(is-false (handler-bind ((match-error #'continue))
(cmatch 1 (2 t))))
;; only once
(let ((count 0))
(flet ((f () (incf count)))
(is (eql (handler-case (cmatch (f) (0 t))
(match-error (e)
(first (match-error-values e))))
1)))))
(test multiple-value-cmatch
(is-false (handler-bind ((match-error #'continue))
(multiple-value-cmatch (values 1 2)
((2 1) t))))
;; only once
(let ((count 0))
(flet ((f () (incf count)))
(is (eql (handler-case (multiple-value-cmatch (values (f)) ((0) t))
(match-error (e)
(first (match-error-values e))))
1)))))
;;; Contrib tests
(test ppcre
(is-match "a" (ppcre "^a$"))
(is-not-match "a" (ppcre "^b$"))
(is-not-match 1 (ppcre "a"))
(is-not-match :A (ppcre "A"))
(is-true (match "a"
((ppcre "^(.)$")
t)))
(is (equal (match "a"
((ppcre "(a)" x y)
(list x y)))
'("a" nil)))
(is (equal (match "2012-11-04"
((ppcre "^(\\d+)-(\\d+)-(\\d+)$" year month day)
(list year month day)))
'("2012" "11" "04"))))
;;; Regression tests
(test issue39
(is (eql (match '(0) ((list x) x))
0))
(is (eql (match '(0) ((list (and x (guard it (numberp it)))) x))
0)))
(test issue38
(signals error
(macroexpand '(match 1 ((or (place x) (place x)))))))
(test issue31
(is (equal (match '(1 2 3 4)
((or (list* (and (type symbol) x) y z)
(list* y x z))
(list x y z)))
'(2 1 (3 4)))))
(test issue68
(is (equal (match 1
((guard x (equal x 2)) (list :a x))
(x (list :b x)))
'(:b 1))))
(defun signal-error ()
(error 'error))
(defun will-fail ()
(match 1
((not 2)
(signal-error))))
(test issue101
(signals error (will-fail)))
(test issue105
(is-match '(1) (list* (or 1 2) _)))