1
2(cond-expand
3 (modules (import (chibi match) (only (chibi test) test-begin test test-end)))
4 (else (load "lib/chibi/match/match.scm")))
5
6(test-begin "match")
7
8(test "any" 'ok (match 'any (_ 'ok)))
9(test "symbol" 'ok (match 'ok (x x)))
10(test "number" 'ok (match 28 (28 'ok)))
11(test "string" 'ok (match "good" ("bad" 'fail) ("good" 'ok)))
12(test "literal symbol" 'ok (match 'good ('bad 'fail) ('good 'ok)))
13(test "null" 'ok (match '() (() 'ok)))
14(test "pair" 'ok (match '(ok) ((x) x)))
15(test "vector" 'ok (match '#(ok) (#(x) x)))
16(test "any doubled" 'ok (match '(1 2) ((_ _) 'ok)))
17(test "and empty" 'ok (match '(o k) ((and) 'ok)))
18(test "and single" 'ok (match 'ok ((and x) x)))
19(test "and double" 'ok (match 'ok ((and (? symbol?) y) 'ok)))
20(test "or empty" 'ok (match '(o k) ((or) 'fail) (else 'ok)))
21(test "or single" 'ok (match 'ok ((or x) 'ok)))
22(test "or double" 'ok (match 'ok ((or (? symbol? y) y) y)))
23(test "not" 'ok (match 28 ((not (a . b)) 'ok)))
24(test "pred" 'ok (match 28 ((? number?) 'ok)))
25(test "named pred" 29 (match 28 ((? number? x) (+ x 1))))
26
27(test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x)))
28(test "duplicate symbols fail" 'ok (match '(ok . bad) ((x . x) 'bad) (else 'ok)))
29(test "duplicate symbols samth" 'ok (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)))
30(test "duplicate symbols bound" 3 (let ((a '(1 2))) (match a ((and (a 2) (1 b)) (+ a b)) (_ #f))))
31(test "duplicate quasiquote" 'ok (match '(a b) ((or `(a ,x) `(,x b)) 'ok) (_ #f)))
32
33(test "ellipses" '((a b c) (1 2 3))
34  (match '((a . 1) (b . 2) (c . 3))
35    (((x . y) ___) (list x y))))
36
37(test "real ellipses" '((a b c) (1 2 3))
38  (match '((a . 1) (b . 2) (c . 3))
39    (((x . y) ...) (list x y))))
40
41(test "vector ellipses" '(1 2 3 (a b c) (1 2 3))
42  (match '#(1 2 3 (a . 1) (b . 2) (c . 3))
43    (#(a b c (hd . tl) ...) (list a b c hd tl))))
44
45(test "pred ellipses" '(1 2 3)
46  (match '(1 2 3)
47    (((? odd? n) ___) n)
48    (((? number? n) ___) n)))
49
50(test "failure continuation" 'ok
51  (match '(1 2)
52    ((a . b) (=> next) (if (even? a) 'fail (next)))
53    ((a . b) 'ok)))
54
55(test "let" '(o k)
56  (match-let ((x 'ok) (y '(o k))) y))
57
58(test "let*" '(f o o f)
59  (match-let* ((x 'f) (y 'o) ((z w) (list y x))) (list x y z w)))
60
61(test "getter car" '(1 2)
62  (match '(1 . 2) (((get! a) . b) (list (a) b))))
63
64(test "getter cdr" '(1 2)
65  (match '(1 . 2) ((a . (get! b)) (list a (b)))))
66
67(test "getter vector" '(1 2 3)
68  (match '#(1 2 3) (#((get! a) b c) (list (a) b c))))
69
70(test "setter car" '(3 . 2)
71  (let ((x (cons 1 2)))
72    (match x (((set! a) . b) (a 3)))
73    x))
74
75(test "setter cdr" '(1 . 3)
76  (let ((x (cons 1 2)))
77    (match x ((a . (set! b)) (b 3)))
78    x))
79
80(test "setter vector" '#(1 0 3)
81  (let ((x (vector 1 2 3)))
82    (match x (#(a (set! b) c) (b 0)))
83    x))
84
85(test "single tail" '((a b) (1 2) (c . 3))
86  (match '((a . 1) (b . 2) (c . 3))
87    (((x . y) ... last) (list x y last))))
88
89(test "single tail 2" '((a b) (1 2) 3)
90  (match '((a . 1) (b . 2) 3)
91    (((x . y) ... last) (list x y last))))
92
93(test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5))
94  (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5))
95    (((x . y) ... u v w) (list x y u v w))))
96
97(test "tail against improper list" #f
98  (match '(a b c d e f . g)
99    ((x ... y u v w) (list x y u v w))
100    (else #f)))
101
102(test "Riastradh quasiquote" '(2 3)
103  (match '(1 2 3) (`(1 ,b ,c) (list b c))))
104
105(test "trivial tree search" '(1 2 3)
106  (match '(1 2 3) ((_ *** (a b c)) (list a b c))))
107
108(test "simple tree search" '(1 2 3)
109  (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))))
110
111(test "deep tree search" '(1 2 3)
112  (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))))
113
114(test "non-tail tree search" '(1 2 3)
115  (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))))
116
117(test "restricted tree search" '(1 2 3)
118  (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))))
119
120(test "fail restricted tree search" #f
121  (match '(x (y (x a b c (1 2 3) d e f)))
122    (('x *** (a b c)) (list a b c))
123    (else #f)))
124
125(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode"))
126  (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
127    (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
128     (list attrs text))
129    (else #f)))
130
131(test "failed sxml tree search" #f
132  (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
133    (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
134     (list attrs text))
135    (else #f)))
136
137(test "collect tree search"
138    '((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))
139  (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
140    (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...))
141     (list tag attrs text))
142    (else #f)))
143
144(test "anded tail pattern" '(1 2)
145      (match '(1 2 3) ((and (a ... b) x) a)))
146
147(test "anded search pattern" '(a b c)
148      (match '(a (b (c d))) ((and (p *** 'd) x) p)))
149
150(test "joined tail" '(1 2)
151      (match '(1 2 3) ((and (a ... b) x) a)))
152
153(test "list ..1" '(a b c)
154    (match '(a b c) ((x ..1) x)))
155
156(test "list ..1 failed" #f
157    (match '()
158      ((x ..1) x)
159      (else #f)))
160
161(test "list ..1 with predicate" '(a b c)
162    (match '(a b c)
163      (((and x (? symbol?)) ..1) x)))
164
165(test "list ..1 with failed predicate" #f
166    (match '(a b 3)
167      (((and x (? symbol?)) ..1) x)
168      (else #f)))
169
170(test "match-named-let" 6
171    (match-let loop (((x . rest) '(1 2 3))
172                     (sum 0))
173      (let ((sum (+ x sum)))
174        (if (null? rest)
175            sum
176            (loop rest sum)))))
177
178(test-end)
179