Commit | Line | Data |
---|---|---|
5fcb7b3c LC |
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))) | |
b92bbfff | 30 | (test "duplicate symbols bound" 3 (let ((a '(1 2))) (match a ((and (a 2) (1 b)) (+ a b)) (_ #f)))) |
5fcb7b3c LC |
31 | |
32 | (test "ellipses" '((a b c) (1 2 3)) | |
33 | (match '((a . 1) (b . 2) (c . 3)) | |
34 | (((x . y) ___) (list x y)))) | |
35 | ||
36 | (test "real ellipses" '((a b c) (1 2 3)) | |
37 | (match '((a . 1) (b . 2) (c . 3)) | |
38 | (((x . y) ...) (list x y)))) | |
39 | ||
40 | (test "vector ellipses" '(1 2 3 (a b c) (1 2 3)) | |
41 | (match '#(1 2 3 (a . 1) (b . 2) (c . 3)) | |
42 | (#(a b c (hd . tl) ...) (list a b c hd tl)))) | |
43 | ||
44 | (test "pred ellipses" '(1 2 3) | |
45 | (match '(1 2 3) | |
46 | (((? odd? n) ___) n) | |
47 | (((? number? n) ___) n))) | |
48 | ||
49 | (test "failure continuation" 'ok | |
50 | (match '(1 2) | |
51 | ((a . b) (=> next) (if (even? a) 'fail (next))) | |
52 | ((a . b) 'ok))) | |
53 | ||
54 | (test "let" '(o k) | |
55 | (match-let ((x 'ok) (y '(o k))) y)) | |
56 | ||
57 | (test "let*" '(f o o f) | |
58 | (match-let* ((x 'f) (y 'o) ((z w) (list y x))) (list x y z w))) | |
59 | ||
60 | (test "getter car" '(1 2) | |
61 | (match '(1 . 2) (((get! a) . b) (list (a) b)))) | |
62 | ||
63 | (test "getter cdr" '(1 2) | |
64 | (match '(1 . 2) ((a . (get! b)) (list a (b))))) | |
65 | ||
66 | (test "getter vector" '(1 2 3) | |
67 | (match '#(1 2 3) (#((get! a) b c) (list (a) b c)))) | |
68 | ||
69 | (test "setter car" '(3 . 2) | |
70 | (let ((x (cons 1 2))) | |
71 | (match x (((set! a) . b) (a 3))) | |
72 | x)) | |
73 | ||
74 | (test "setter cdr" '(1 . 3) | |
75 | (let ((x (cons 1 2))) | |
76 | (match x ((a . (set! b)) (b 3))) | |
77 | x)) | |
78 | ||
79 | (test "setter vector" '#(1 0 3) | |
80 | (let ((x (vector 1 2 3))) | |
81 | (match x (#(a (set! b) c) (b 0))) | |
82 | x)) | |
83 | ||
84 | (test "single tail" '((a b) (1 2) (c . 3)) | |
85 | (match '((a . 1) (b . 2) (c . 3)) | |
86 | (((x . y) ... last) (list x y last)))) | |
87 | ||
88 | (test "single tail 2" '((a b) (1 2) 3) | |
89 | (match '((a . 1) (b . 2) 3) | |
90 | (((x . y) ... last) (list x y last)))) | |
91 | ||
92 | (test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5)) | |
93 | (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5)) | |
94 | (((x . y) ... u v w) (list x y u v w)))) | |
95 | ||
96 | (test "tail against improper list" #f | |
97 | (match '(a b c d e f . g) | |
98 | ((x ... y u v w) (list x y u v w)) | |
99 | (else #f))) | |
100 | ||
101 | (test "Riastradh quasiquote" '(2 3) | |
102 | (match '(1 2 3) (`(1 ,b ,c) (list b c)))) | |
103 | ||
104 | (test "trivial tree search" '(1 2 3) | |
105 | (match '(1 2 3) ((_ *** (a b c)) (list a b c)))) | |
106 | ||
107 | (test "simple tree search" '(1 2 3) | |
108 | (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c)))) | |
109 | ||
110 | (test "deep tree search" '(1 2 3) | |
111 | (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c)))) | |
112 | ||
113 | (test "non-tail tree search" '(1 2 3) | |
114 | (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c)))) | |
115 | ||
116 | (test "restricted tree search" '(1 2 3) | |
117 | (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c)))) | |
118 | ||
119 | (test "fail restricted tree search" #f | |
120 | (match '(x (y (x a b c (1 2 3) d e f))) | |
121 | (('x *** (a b c)) (list a b c)) | |
122 | (else #f))) | |
123 | ||
124 | (test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode")) | |
125 | (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) | |
126 | (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) | |
127 | (list attrs text)) | |
128 | (else #f))) | |
129 | ||
130 | (test "failed sxml tree search" #f | |
131 | (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) | |
132 | (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) | |
133 | (list attrs text)) | |
134 | (else #f))) | |
135 | ||
136 | (test "collect tree search" | |
137 | '((p ul li) ((href . "http://synthcode.com/")) ("synthcode")) | |
138 | (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) | |
139 | (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) | |
140 | (list tag attrs text)) | |
141 | (else #f))) | |
142 | ||
143 | (test "anded tail pattern" '(1 2) | |
144 | (match '(1 2 3) ((and (a ... b) x) a))) | |
145 | ||
146 | (test "anded search pattern" '(a b c) | |
147 | (match '(a (b (c d))) ((and (p *** 'd) x) p))) | |
148 | ||
149 | (test "joined tail" '(1 2) | |
150 | (match '(1 2 3) ((and (a ... b) x) a))) | |
151 | ||
152 | (test "list ..1" '(a b c) | |
153 | (match '(a b c) ((x ..1) x))) | |
154 | ||
155 | (test "list ..1 failed" #f | |
156 | (match '() | |
157 | ((x ..1) x) | |
158 | (else #f))) | |
159 | ||
160 | (test "list ..1 with predicate" '(a b c) | |
161 | (match '(a b c) | |
162 | (((and x (? symbol?)) ..1) x))) | |
163 | ||
164 | (test "list ..1 with failed predicate" #f | |
165 | (match '(a b 3) | |
166 | (((and x (? symbol?)) ..1) x) | |
167 | (else #f))) | |
168 | ||
169 | (test-end) |