test-suite/tests/sxml-match-tests.ss

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