summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-01-18 07:27:17 -0800
committerKaz Kylheku <kaz@kylheku.com>2021-01-18 07:27:17 -0800
commitfb2f2c8ea44b56a089c685656bffa08bc63d8ac5 (patch)
tree1d0b7c94e3c453a4822ae5bd07bd2ce6aaac78b6
parent262df61dea7cdb66b5dd50ef38f8e4ba672a596e (diff)
downloadtxr-fb2f2c8ea44b56a089c685656bffa08bc63d8ac5.tar.gz
txr-fb2f2c8ea44b56a089c685656bffa08bc63d8ac5.tar.bz2
txr-fb2f2c8ea44b56a089c685656bffa08bc63d8ac5.zip
matcher: add tests from documentation.
* tests/011/patmatch.tl: New file. * tests/011/patmatch.expected: Likewise.
-rw-r--r--tests/011/patmatch.expected0
-rw-r--r--tests/011/patmatch.tl68
2 files changed, 68 insertions, 0 deletions
diff --git a/tests/011/patmatch.expected b/tests/011/patmatch.expected
new file mode 100644
index 00000000..e69de29b
--- /dev/null
+++ b/tests/011/patmatch.expected
diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl
new file mode 100644
index 00000000..f930dd9f
--- /dev/null
+++ b/tests/011/patmatch.tl
@@ -0,0 +1,68 @@
+(load "../common")
+
+(test (if-match 1 1 'yes 'no) yes)
+(test (if-match 1 0 'yes 'no) no)
+
+(test (let ((sym 'a))
+ (list (if-match a sym 'yes 'no)
+ (if-match b sym 'yes 'no)))
+ (yes no))
+
+(test (when-match @a 42 (list a)) (42))
+(test (when-match (@a @b @c) '(1 2 3) (list c b a)) (3 2 1))
+(test (if-match (@a @b @c . @d) '(1 2 3 . 4) (list d c b a)) (4 3 2 1))
+
+(test (if-match (@(oddp a) @b @c . @d) '(2 x y z)
+ (list a b c d)
+ :no-match)
+ :no-match)
+
+(test (if-match (1 2 . @a) '(1 2 3 4) a) (3 4))
+(test (if-match ((1 2 @a) @b) '((1 2 3) 4) (list a b)) (3 4))
+(test (if-match #() #() :yes :no) :yes)
+(test (if-match #() #(1) :yes :no) :no)
+(test (if-match #((1 @a) #(3 @b)) #((1 2) #(3 4)) (list a b)) (2 4))
+
+(test (when-match @(struct time year 2021 month @m) #S(time year 2021 month 1)
+ m)
+ 1)
+
+(defstruct widget ()
+ name
+ value)
+
+(defstruct grommet ()
+ name
+ value)
+
+(vtest (append-each ((obj (list (new grommet name "foo" value :grom)
+ (new widget name "foo" value :widg))))
+ (when-match @(struct @type name "foo" value @v) obj
+ (list (list type v))))
+ ^((,(find-struct-type 'grommet) :grom)
+ (,(find-struct-type 'widget) :widg)))
+
+(test (when-match @(let w (@a @b @c)) '(1 2 3) (list w a b c)) ((1 2 3) 1 2 3))
+(test (when-match @(require (+ @a @b) (equal a b)) '(+ z z) (list a b)) (z z))
+
+(test (if-match @(require (+ @a @b) (equal a b)) '(+ y z)
+ (list a b)
+ :no-match)
+ :no-match)
+
+(test (when-match @(all (x @a @b)) '((x 1 a) (x 2 b) (x 3 c))
+ (list a b))
+ ((1 2 3) (a b c)))
+
+(test (when-match @(some (x @a @b)) '((y 1 a) (x 2 b) (z 3 c))
+ (list a b))
+ (2 b))
+
+(test (if-match @(and (@x 2 3) (1 @y 3) (1 2 @z)) '(1 2 3)
+ (list x y z))
+ (1 2 3))
+
+(test (if-match @(or (@x 3 3) (1 @x 3) (1 2 @x)) '(1 2 3) x) 2)
+(test (if-match @(op <= 10 @1 13) 11 :yes :no) :yes)
+(test (when-match @(let x @(op <= 10 @1 13)) 11 x) 11)
+(test (when-match (@(evenp) @(oddp x)) '(2 3) x) 3)