Commit | Line | Data |
---|---|---|
400a5dcb LC |
1 | (define-syntax compile-match |
2 | (syntax-rules () | |
3 | [(compile-match pat action0 action ...) | |
4 | (lambda (x) | |
5 | (sxml-match x [pat action0 action ...]))])) | |
6 | ||
7 | (run-test "basic match of a top-level pattern var" | |
8 | (sxml-match '(e 3 4 5) | |
9 | [,y (list "matched" y)]) | |
10 | '("matched" (e 3 4 5))) | |
11 | (run-test "match of simple element contents with pattern vars" | |
12 | ((compile-match (e ,a ,b ,c) (list a b c)) '(e 3 4 5)) | |
13 | '(3 4 5)) | |
14 | (run-test "match a literal pattern within a element pattern" | |
15 | ((compile-match (e ,a "abc" ,c) (list a c)) '(e 3 "abc" 5)) | |
16 | '(3 5)) | |
17 | (run-test "match an empty element" | |
18 | ((compile-match (e) "match") '(e)) | |
19 | "match") | |
20 | (run-test "match a nested element" | |
21 | ((compile-match (e ,a (f ,b ,c) ,d) (list a b c d)) '(e 3 (f 4 5) 6)) | |
22 | '(3 4 5 6)) | |
23 | (run-test "match a dot-rest pattern within a nested element" | |
24 | ((compile-match (e ,a (f . ,y) ,d) (list a y d)) '(e 3 (f 4 5) 6)) | |
25 | '(3 (4 5) 6)) | |
26 | (run-test "match a basic list pattern" | |
27 | ((compile-match (list ,a ,b ,c ,d ,e) (list a b c d e)) '("i" "j" "k" "l" "m")) | |
28 | '("i" "j" "k" "l" "m")) | |
29 | (run-test "match a list pattern with a dot-rest pattern" | |
30 | ((compile-match (list ,a ,b ,c . ,y) (list a b c y)) '("i" "j" "k" "l" "m")) | |
31 | '("i" "j" "k" ("l" "m"))) | |
32 | (run-test "basic test of a multi-clause sxml-match" | |
33 | (sxml-match '(a 1 2 3) | |
34 | ((a ,n) n) | |
35 | ((a ,m ,n) (+ m n)) | |
36 | ((a ,m ,n ,o) (list "matched" (list m n o)))) | |
37 | '("matched" (1 2 3))) | |
38 | (run-test "basic test of a sxml-match-let" | |
39 | (sxml-match-let ([(a ,i ,j) '(a 1 2)]) | |
40 | (+ i j)) | |
41 | 3) | |
42 | (run-test "basic test of a sxml-match-let*" | |
43 | (sxml-match-let* ([(a ,k) '(a (b 1 2))] | |
44 | [(b ,i ,j) k]) | |
45 | (list i j)) | |
46 | '(1 2)) | |
47 | (run-test "match of top-level literal string pattern" | |
48 | ((compile-match "abc" "match") "abc") | |
49 | "match") | |
50 | (run-test "match of top-level literal number pattern" | |
51 | ((compile-match 77 "match") 77) | |
52 | "match") | |
53 | (run-test "test of multi-expression guard in pattern" | |
54 | (sxml-match '(a 1 2 3) | |
55 | ((a ,n) n) | |
56 | ((a ,m ,n) (+ m n)) | |
57 | ((a ,m ,n ,o) (guard (number? m) (number? n) (number? o)) (list "guarded-matched" (list m n o)))) | |
58 | '("guarded-matched" (1 2 3))) | |
59 | (run-test "basic test of multiple action items in match clause" | |
60 | ((compile-match 77 (display "") "match") 77) | |
61 | "match") | |
62 | ||
63 | (define simple-eval | |
64 | (lambda (x) | |
65 | (sxml-match x | |
66 | [,i (guard (integer? i)) i] | |
67 | [(+ ,x ,y) (+ (simple-eval x) (simple-eval y))] | |
68 | [(* ,x ,y) (* (simple-eval x) (simple-eval y))] | |
69 | [(- ,x ,y) (- (simple-eval x) (simple-eval y))] | |
70 | [(/ ,x ,y) (/ (simple-eval x) (simple-eval y))] | |
71 | [,otherwise (error "simple-eval: invalid expression" x)]))) | |
72 | ||
73 | (run-test "basic test of explicit recursion in match clauses" | |
74 | (simple-eval '(* (+ 7 3) (- 7 3))) | |
75 | 40) | |
76 | ||
77 | (define simple-eval2 | |
78 | (lambda (x) | |
79 | (sxml-match x | |
80 | [,i (guard (integer? i)) i] | |
81 | [(+ ,[x] ,[y]) (+ x y)] | |
82 | [(* ,[x] ,[y]) (* x y)] | |
83 | [(- ,[x] ,[y]) (- x y)] | |
84 | [(/ ,[x] ,[y]) (/ x y)] | |
85 | [,otherwise (error "simple-eval: invalid expression" x)]))) | |
86 | ||
87 | (run-test "basic test of anonymous catas" | |
88 | (simple-eval2 '(* (+ 7 3) (- 7 3))) | |
89 | 40) | |
90 | ||
91 | (define simple-eval3 | |
92 | (lambda (x) | |
93 | (sxml-match x | |
94 | [,i (guard (integer? i)) i] | |
95 | [(+ ,[simple-eval3 -> x] ,[simple-eval3 -> y]) (+ x y)] | |
96 | [(* ,[simple-eval3 -> x] ,[simple-eval3 -> y]) (* x y)] | |
97 | [(- ,[simple-eval3 -> x] ,[simple-eval3 -> y]) (- x y)] | |
98 | [(/ ,[simple-eval3 -> x] ,[simple-eval3 -> y]) (/ x y)] | |
99 | [,otherwise (error "simple-eval: invalid expression" x)]))) | |
100 | ||
101 | (run-test "test of named catas" | |
102 | (simple-eval3 '(* (+ 7 3) (- 7 3))) | |
103 | 40) | |
104 | ||
105 | ; need a test case for cata on a ". rest)" pattern | |
106 | ||
107 | (run-test "successful test of attribute matching: pat-var in value position" | |
108 | (sxml-match '(e (@ (z 1)) 3 4 5) | |
109 | [(e (@ (z ,d)) ,a ,b ,c) (list d a b c)] | |
110 | [,otherwise #f]) | |
111 | '(1 3 4 5)) | |
112 | ||
113 | (run-test "failing test of attribute matching: pat-var in value position" | |
114 | (sxml-match '(e (@ (a 1)) 3 4 5) | |
115 | [(e (@ (z ,d)) ,a ,b ,c) (list d a b c)] | |
116 | [,otherwise #f]) | |
117 | #f) | |
118 | ||
119 | (run-test "test of attribute matching: literal in value position" | |
120 | ((compile-match (e (@ (z 1)) ,a ,b ,c) (list a b c)) '(e (@ (z 1)) 3 4 5)) | |
121 | '(3 4 5)) | |
122 | ||
123 | (run-test "test of attribute matching: default-value spec in value position" | |
124 | ((compile-match (e (@ (z (,d 1))) ,a ,b ,c) (list d a b c)) '(e 3 4 5)) | |
125 | '(1 3 4 5)) | |
126 | ||
127 | (run-test "test of attribute matching: multiple attributes in pattern" | |
128 | ((compile-match (e (@ (y ,e) (z ,d)) ,a ,b ,c) (list e d a b c)) '(e (@ (z 1) (y 2)) 3 4 5)) | |
129 | '(2 1 3 4 5)) | |
130 | ||
131 | (run-test "basic test of ellipses in pattern; no ellipses in output" | |
132 | ((compile-match (e ,i ...) i) '(e 3 4 5)) | |
133 | '(3 4 5)) | |
134 | ||
135 | (run-test "test of non-null tail pattern following ellipses" | |
136 | ((compile-match (e ,i ... ,a ,b) i) '(e 3 4 5 6 7)) | |
137 | '(3 4 5 )) | |
138 | ||
139 | (define simple-eval4 | |
140 | (lambda (x) | |
141 | (sxml-match x | |
142 | [,i (guard (integer? i)) i] | |
143 | [(+ ,[x*] ...) (apply + x*)] | |
144 | [(* ,[x*] ...) (apply * x*)] | |
145 | [(- ,[x] ,[y]) (- x y)] | |
146 | [(/ ,[x] ,[y]) (/ x y)] | |
147 | [,otherwise (error "simple-eval: invalid expression" x)]))) | |
148 | ||
149 | (run-test "test of catas with ellipses in pattern" | |
150 | (simple-eval4 '(* (+ 7 3) (- 7 3))) | |
151 | 40) | |
152 | ||
153 | (run-test "simple test of ellipses in pattern and output" | |
154 | ((compile-match (e ,i ...) ((lambda rst (cons 'f rst)) i ...)) '(e 3 4 5)) | |
155 | '(f 3 4 5)) | |
156 | ||
157 | (define simple-eval5 | |
158 | (lambda (x) | |
159 | (sxml-match x | |
160 | [,i (guard (integer? i)) i] | |
161 | [(+ ,[x*] ...) (+ x* ...)] | |
162 | [(* ,[x*] ...) (* x* ...)] | |
163 | [(- ,[x] ,[y]) (- x y)] | |
164 | [(/ ,[x] ,[y]) (/ x y)] | |
165 | [,otherwise (error "simple-eval: invalid expression" x)]))) | |
166 | ||
167 | (run-test "test of catas with ellipses in pattern and output" | |
168 | (simple-eval5 '(* (+ 7 3) (- 7 3))) | |
169 | 40) | |
170 | ||
171 | (run-test "test of nested dots in pattern and output" | |
172 | ((lambda (x) | |
173 | (sxml-match x | |
174 | [(d (a ,b ...) ...) | |
175 | (list (list b ...) ...)])) | |
176 | '(d (a 1 2 3) (a 4 5) (a 6 7 8) (a 9 10))) | |
177 | '((1 2 3) (4 5) (6 7 8) (9 10))) | |
178 | ||
179 | (run-test "test successful tail pattern match (after ellipses)" | |
180 | (sxml-match '(e 3 4 5 6 7) ((e ,i ... 6 7) #t) (,otherwise #f)) | |
181 | #t) | |
182 | ||
183 | (run-test "test failing tail pattern match (after ellipses), too few items" | |
184 | (sxml-match '(e 3 4 5 6) ((e ,i ... 6 7) #t) (,otherwise #f)) | |
185 | #f) | |
186 | ||
187 | (run-test "test failing tail pattern match (after ellipses), too many items" | |
188 | (sxml-match '(e 3 4 5 6 7 8) ((e ,i ... 6 7) #t) (,otherwise #f)) | |
189 | #f) | |
190 | ||
191 | (run-test "test failing tail pattern match (after ellipses), wrong items" | |
192 | (sxml-match '(e 3 4 5 7 8) ((e ,i ... 6 7) #t) (,otherwise #f)) | |
193 | #f) | |
194 | ||
195 | (run-test "test of ellipses in output quasiquote" | |
196 | (sxml-match '(e 3 4 5 6 7) | |
197 | [(e ,i ... 6 7) `("start" ,i ... "end")] | |
198 | [,otherwise #f]) | |
199 | '("start" 3 4 5 "end")) | |
200 | ||
201 | (run-test "test of ellipses in output quasiquote, with more complex unquote expression" | |
202 | (sxml-match '(e 3 4 5 6 7) | |
203 | [(e ,i ... 6 7) `("start" ,(list 'wrap i) ... "end")] | |
204 | [,otherwise #f]) | |
205 | '("start" (wrap 3) (wrap 4) (wrap 5) "end")) | |
206 | ||
207 | (run-test "test of a quasiquote expr within the dotted unquote expression" | |
208 | (sxml-match '(e 3 4 5 6 7) | |
209 | [(e ,i ... 6 7) `("start" ,`(wrap ,i) ... "end")] | |
210 | [,otherwise #f]) | |
211 | '("start" (wrap 3) (wrap 4) (wrap 5) "end")) | |
212 | ||
213 | (define xyzpq '(d (a 1 2 3) (a 4 5) (a 6 7 8) (a 9 10))) | |
214 | ||
215 | (run-test "quasiquote tests" | |
216 | (sxml-match xyzpq | |
217 | [(d (a ,b ...) ...) | |
218 | `(,`(,b ...) ...)]) | |
219 | '((1 2 3) (4 5) (6 7 8) (9 10))) | |
220 | ||
221 | (run-test "quasiquote tests" | |
222 | (sxml-match xyzpq | |
223 | [(d (a ,b ...) ...) | |
224 | (list (list b ...) ...)]) | |
225 | '((1 2 3) (4 5) (6 7 8) (9 10))) | |
226 | ||
227 | (run-test "quasiquote tests" | |
228 | (sxml-match xyzpq | |
229 | [(d (a ,b ...) ...) | |
230 | `(xx ,`(y ,b ...) ...)]) | |
231 | '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10))) | |
232 | ||
233 | (run-test "quasiquote tests" | |
234 | (sxml-match xyzpq | |
235 | [(d (a ,b ...) ...) | |
236 | `(xx ,@(map (lambda (i) `(y ,@i)) b))]) | |
237 | '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10))) | |
238 | ||
239 | (run-test "quasiquote tests" | |
240 | (sxml-match xyzpq | |
241 | [(d (a ,b ...) ...) | |
242 | `(xx ,(cons 'y b) ...)]) | |
243 | '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10))) | |
244 | ||
245 | (run-test "quasiquote tests" | |
246 | (sxml-match xyzpq | |
247 | [(d (a ,b ...) ...) | |
248 | `(xx ,`(y ,b ...) ...)]) | |
249 | '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10))) | |
250 | ||
251 | (run-test "quasiquote tests" | |
252 | (sxml-match xyzpq | |
253 | [(d (a ,b ...) ...) | |
254 | `(xx ,`(y ,@b) ...)]) | |
255 | '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10))) | |
256 | ||
257 | (run-test "quasiquote tests" | |
258 | (sxml-match xyzpq | |
259 | [(d (a ,b ...) ...) | |
260 | `((,b ...) ...)]) | |
261 | '((1 2 3) (4 5) (6 7 8) (9 10))) | |
262 | ||
263 | (run-test "quasiquote tests" | |
264 | (sxml-match xyzpq | |
265 | [(d (a ,b ...) ...) | |
266 | `(xx (y ,b ...) ...)]) | |
267 | '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10))) | |
268 | ||
269 | (define (prog-trans p) | |
270 | (sxml-match p | |
271 | [(Program (Start ,start-time) (Duration ,dur) (Series ,series-title) | |
272 | (Description . ,desc) | |
273 | ,cl) | |
274 | `(div (p ,start-time | |
275 | (br) ,series-title | |
276 | (br) ,desc) | |
277 | ,cl)] | |
278 | [(Program (Start ,start-time) (Duration ,dur) (Series ,series-title) | |
279 | (Description . ,desc)) | |
280 | `(div (p ,start-time | |
281 | (br) ,series-title | |
282 | (br) ,desc))] | |
283 | [(Program (Start ,start-time) (Duration ,dur) (Series ,series-title)) | |
284 | `(div (p ,start-time | |
285 | (br) ,series-title))])) | |
286 | ||
287 | (run-test "test for shrinking-order list of pattern clauses" | |
288 | (prog-trans '(Program (Start "2001-07-05T20:00:00") (Duration "PT1H") (Series "HomeFront"))) | |
289 | '(div (p "2001-07-05T20:00:00" (br) "HomeFront"))) | |
290 | ||
291 | (run-test "test binding of unmatched attributes" | |
292 | (sxml-match '(a (@ (z 1) (y 2) (x 3)) 4 5 6) | |
293 | [(a (@ (y ,www) . ,qqq) ,t ...) | |
294 | (list www qqq t ...)]) | |
295 | '(2 ((z 1) (x 3)) 4 5 6)) | |
296 | ||
297 | (run-test "test binding all attributes" | |
298 | (sxml-match '(a (@ (z 1) (y 2) (x 3)) 4 5 6) | |
299 | [(a (@ . ,qqq) ,t ...) | |
300 | (list qqq t ...)]) | |
301 | '(((z 1) (y 2) (x 3)) 4 5 6)) | |
01fded8c LC |
302 | |
303 | (run-test "test multiple value returns" | |
304 | (call-with-values | |
305 | (lambda () | |
306 | (sxml-match '(foo) | |
307 | ((foo) (values 'x 'y)))) | |
308 | (lambda (x y) | |
309 | (cons x y))) | |
310 | '(x . y)) |