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