sxml-match-tests.ss 12 KB

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