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))
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))
311