1;; Library: sxml-match 2;; Author: Jim Bender 3;; Version: 1.1, version for PLT Scheme 4;; 5;; Copyright 2005-9, Jim Bender 6;; sxml-match is released under the MIT License 7;; 8(module sxml-match mzscheme 9 10 (provide sxml-match 11 sxml-match-let 12 sxml-match-let*) 13 14 (require (rename (lib "fold.ss" "srfi" "1") fold-right fold-right) 15 (rename (lib "filter.ss" "srfi" "1") filter filter)) 16 17 (define (nodeset? x) 18 (or (and (pair? x) (not (symbol? (car x)))) (null? x))) 19 20 (define (xml-element-tag s) 21 (if (and (pair? s) (symbol? (car s))) 22 (car s) 23 (error 'xml-element-tag "expected an xml-element, given" s))) 24 25 (define (xml-element-attributes s) 26 (if (and (pair? s) (symbol? (car s))) 27 (fold-right (lambda (a b) 28 (if (and (pair? a) (eq? '@ (car a))) 29 (if (null? b) 30 (filter (lambda (i) (not (and (pair? i) (eq? '@ (car i))))) (cdr a)) 31 (fold-right (lambda (c d) 32 (if (and (pair? c) (eq? '@ (car c))) 33 d 34 (cons c d))) 35 b (cdr a))) 36 b)) 37 '() 38 (cdr s)) 39 (error 'xml-element-attributes "expected an xml-element, given" s))) 40 41 (define (xml-element-contents s) 42 (if (and (pair? s) (symbol? (car s))) 43 (filter (lambda (i) 44 (not (and (pair? i) (eq? '@ (car i))))) 45 (cdr s)) 46 (error 'xml-element-contents "expected an xml-element, given" s))) 47 48 (define (match-xml-attribute key l) 49 (if (not (pair? l)) 50 #f 51 (if (eq? (car (car l)) key) 52 (car l) 53 (match-xml-attribute key (cdr l))))) 54 55 (define (filter-attributes keys lst) 56 (if (null? lst) 57 '() 58 (if (member (caar lst) keys) 59 (filter-attributes keys (cdr lst)) 60 (cons (car lst) (filter-attributes keys (cdr lst)))))) 61 62 (define-syntax compile-clause 63 (lambda (stx) 64 (letrec 65 ([sxml-match-syntax-error 66 (lambda (msg exp sub) 67 (raise-syntax-error #f msg (with-syntax ([s exp]) (syntax (sxml-match s))) sub))] 68 [ellipsis? 69 (lambda (stx) 70 (and (identifier? stx) (eq? '... (syntax-object->datum stx))))] 71 [literal? 72 (lambda (stx) 73 (let ([x (syntax-object->datum stx)]) 74 (or (string? x) 75 (char? x) 76 (number? x) 77 (boolean? x))))] 78 [keyword? 79 (lambda (stx) 80 (and (identifier? stx) 81 (let ([str (symbol->string (syntax-object->datum stx))]) 82 (char=? #\: (string-ref str (- (string-length str) 1))))))] 83 [extract-cata-fun 84 (lambda (cf) 85 (syntax-case cf () 86 [#f #f] 87 [other cf]))] 88 [add-pat-var 89 (lambda (pvar pvar-lst) 90 (define (check-pvar lst) 91 (if (null? lst) 92 (void) 93 (if (bound-identifier=? (car lst) pvar) 94 (sxml-match-syntax-error "duplicate pattern variable not allowed" 95 stx 96 pvar) 97 (check-pvar (cdr lst))))) 98 (check-pvar pvar-lst) 99 (cons pvar pvar-lst))] 100 [add-cata-def 101 (lambda (depth cvars cfun ctemp cdefs) 102 (cons (list depth cvars cfun ctemp) cdefs))] 103 [process-cata-exp 104 (lambda (depth cfun ctemp) 105 (if (= depth 0) 106 (with-syntax ([cf cfun] 107 [ct ctemp]) 108 (syntax (cf ct))) 109 (let ([new-ctemp (car (generate-temporaries (list ctemp)))]) 110 (with-syntax ([ct ctemp] 111 [nct new-ctemp] 112 [body (process-cata-exp (- depth 1) cfun new-ctemp)]) 113 (syntax (map (lambda (nct) body) ct))))))] 114 [process-cata-defs 115 (lambda (cata-defs body) 116 (if (null? cata-defs) 117 body 118 (with-syntax ([(cata-binding ...) 119 (map (lambda (def) 120 (with-syntax ([bvar (cadr def)] 121 [bval (process-cata-exp (car def) 122 (caddr def) 123 (cadddr def))]) 124 (syntax (bvar bval)))) 125 cata-defs)] 126 [body-stx body]) 127 (syntax (let-values (cata-binding ...) 128 body-stx)))))] 129 [cata-defs->pvar-lst 130 (lambda (lst) 131 (if (null? lst) 132 '() 133 (let iter ([items (cadr (car lst))]) 134 (syntax-case items () 135 [() (cata-defs->pvar-lst (cdr lst))] 136 [(fst . rst) (cons (syntax fst) (iter (syntax rst)))]))))] 137 [process-output-action 138 (lambda (action dotted-vars) 139 (define (finite-lst? lst) 140 (syntax-case lst () 141 (item 142 (identifier? (syntax item)) 143 #f) 144 (() 145 #t) 146 ((fst dots . rst) 147 (ellipsis? (syntax dots)) 148 #f) 149 ((fst . rst) 150 (finite-lst? (syntax rst))))) 151 (define (expand-lst lst) 152 (syntax-case lst () 153 [() (syntax '())] 154 [item 155 (identifier? (syntax item)) 156 (syntax item)] 157 [(fst dots . rst) 158 (ellipsis? (syntax dots)) 159 (with-syntax ([exp-lft (expand-dotted-item 160 (process-output-action (syntax fst) 161 dotted-vars))] 162 [exp-rgt (expand-lst (syntax rst))]) 163 (syntax (append exp-lft exp-rgt)))] 164 [(fst . rst) 165 (with-syntax ([exp-lft (process-output-action (syntax fst) 166 dotted-vars)] 167 [exp-rgt (expand-lst (syntax rst))]) 168 (syntax (cons exp-lft exp-rgt)))])) 169 (define (member-var? var lst) 170 (let iter ([lst lst]) 171 (if (null? lst) 172 #f 173 (if (or (bound-identifier=? var (car lst)) 174 (free-identifier=? var (car lst))) 175 #t 176 (iter (cdr lst)))))) 177 (define (dotted-var? var) 178 (member-var? var dotted-vars)) 179 (define (merge-pvars lst1 lst2) 180 (if (null? lst1) 181 lst2 182 (if (member-var? (car lst1) lst2) 183 (merge-pvars (cdr lst1) lst2) 184 (cons (car lst1) (merge-pvars (cdr lst1) lst2))))) 185 (define (select-dotted-vars x) 186 (define (walk-quasi-body y) 187 (syntax-case y (unquote unquote-splicing) 188 [((unquote a) . rst) 189 (merge-pvars (select-dotted-vars (syntax a)) 190 (walk-quasi-body (syntax rst)))] 191 [((unquote-splicing a) . rst) 192 (merge-pvars (select-dotted-vars (syntax a)) 193 (walk-quasi-body (syntax rst)))] 194 [(fst . rst) 195 (merge-pvars (walk-quasi-body (syntax fst)) 196 (walk-quasi-body (syntax rst)))] 197 [other 198 '()])) 199 (syntax-case x (quote quasiquote) 200 [(quote . rst) '()] 201 [(quasiquote . rst) (walk-quasi-body (syntax rst))] 202 [(fst . rst) 203 (merge-pvars (select-dotted-vars (syntax fst)) 204 (select-dotted-vars (syntax rst)))] 205 [item 206 (and (identifier? (syntax item)) 207 (dotted-var? (syntax item))) 208 (list (syntax item))] 209 [item '()])) 210 (define (expand-dotted-item item) 211 (let ([dvars (select-dotted-vars item)]) 212 (syntax-case item () 213 [x 214 (identifier? (syntax x)) 215 (syntax x)] 216 [x (with-syntax ([(dv ...) dvars]) 217 (syntax (map (lambda (dv ...) x) dv ...)))]))) 218 (define (expand-quasiquote-body x) 219 (syntax-case x (unquote unquote-splicing quasiquote) 220 [(quasiquote . rst) (process-quasiquote x)] 221 [(unquote item) 222 (with-syntax ([expanded-item (process-output-action (syntax item) 223 dotted-vars)]) 224 (syntax (unquote expanded-item)))] 225 [(unquote-splicing item) 226 (with-syntax ([expanded-item (process-output-action (syntax item) 227 dotted-vars)]) 228 (syntax (unquote-splicing expanded-item)))] 229 [((unquote item) dots . rst) 230 (ellipsis? (syntax dots)) 231 (with-syntax ([expanded-item (expand-dotted-item 232 (process-output-action (syntax item) 233 dotted-vars))] 234 [expanded-rst (expand-quasiquote-body (syntax rst))]) 235 (syntax ((unquote-splicing expanded-item) . expanded-rst)))] 236 [(item dots . rst) 237 (ellipsis? (syntax dots)) 238 (with-syntax ([expanded-item (expand-dotted-item 239 (process-output-action (syntax (quasiquote item)) 240 dotted-vars))] 241 [expanded-rst (expand-quasiquote-body (syntax rst))]) 242 (syntax ((unquote-splicing expanded-item) . expanded-rst)))] 243 [(fst . rst) 244 (with-syntax ([expanded-fst (expand-quasiquote-body (syntax fst))] 245 [expanded-rst (expand-quasiquote-body (syntax rst))]) 246 (syntax (expanded-fst . expanded-rst)))] 247 [other x])) 248 (define (process-quasiquote x) 249 (syntax-case x () 250 [(quasiquote term) (with-syntax ([expanded-body (expand-quasiquote-body (syntax term))]) 251 (syntax (quasiquote expanded-body)))] 252 [else (sxml-match-syntax-error "bad quasiquote-form" 253 stx 254 x)])) 255 (syntax-case action (quote quasiquote) 256 [(quote . rst) action] 257 [(quasiquote . rst) (process-quasiquote action)] 258 [(fst . rst) (if (finite-lst? action) 259 (with-syntax ([exp-lft (process-output-action (syntax fst) dotted-vars)] 260 [exp-rgt (process-output-action (syntax rst) dotted-vars)]) 261 (syntax (exp-lft . exp-rgt))) 262 (with-syntax ([exp-lft (process-output-action (syntax fst) 263 dotted-vars)] 264 [exp-rgt (expand-lst (syntax rst))]) 265 (syntax (apply exp-lft exp-rgt))))] 266 [item action]))] 267 [compile-element-pat 268 (lambda (ele exp nextp fail-k pvar-lst depth cata-fun cata-defs dotted-vars) 269 (syntax-case ele (@) 270 [(tag (@ . attr-items) . items) 271 (identifier? (syntax tag)) 272 (let ([attr-exp (car (generate-temporaries (list exp)))] 273 [body-exp (car (generate-temporaries (list exp)))]) 274 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) 275 (compile-attr-list (syntax attr-items) 276 (syntax items) 277 attr-exp 278 body-exp 279 '() 280 nextp 281 fail-k 282 pvar-lst 283 depth 284 cata-fun 285 cata-defs 286 dotted-vars)]) 287 (values (with-syntax ([x exp] 288 [ax attr-exp] 289 [bx body-exp] 290 [body tests] 291 [fail-to fail-k]) 292 (syntax (if (and (pair? x) (eq? 'tag (xml-element-tag x))) 293 (let ([ax (xml-element-attributes x)] 294 [bx (xml-element-contents x)]) 295 body) 296 (fail-to)))) 297 new-pvar-lst 298 new-cata-defs 299 new-dotted-vars)))] 300 [(tag . items) 301 (identifier? (syntax tag)) 302 (let ([body-exp (car (generate-temporaries (list exp)))]) 303 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) 304 (compile-item-list (syntax items) 305 body-exp 306 nextp 307 fail-k 308 #t 309 pvar-lst 310 depth 311 cata-fun 312 cata-defs 313 dotted-vars)]) 314 (values (with-syntax ([x exp] 315 [bx body-exp] 316 [body tests] 317 [fail-to fail-k]) 318 (syntax (if (and (pair? x) (eq? 'tag (xml-element-tag x))) 319 (let ([bx (xml-element-contents x)]) 320 body) 321 (fail-to)))) 322 new-pvar-lst 323 new-cata-defs 324 new-dotted-vars)))]))] 325 [compile-end-element 326 (lambda (exp nextp fail-k pvar-lst cata-defs dotted-vars) 327 (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars) 328 (nextp pvar-lst cata-defs dotted-vars)]) 329 (values (with-syntax ([x exp] 330 [body next-tests] 331 [fail-to fail-k]) 332 (syntax (if (null? x) body (fail-to)))) 333 new-pvar-lst 334 new-cata-defs 335 new-dotted-vars)))] 336 [compile-attr-list 337 (lambda (attr-lst body-lst attr-exp body-exp attr-key-lst nextp fail-k pvar-lst depth cata-fun cata-defs dotted-vars) 338 (syntax-case attr-lst (unquote ->) 339 [(unquote var) 340 (identifier? (syntax var)) 341 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) 342 (compile-item-list body-lst 343 body-exp 344 nextp 345 fail-k 346 #t 347 (add-pat-var (syntax var) pvar-lst) 348 depth 349 cata-fun 350 cata-defs 351 dotted-vars)]) 352 (values (with-syntax ([ax attr-exp] 353 [matched-attrs attr-key-lst] 354 [body tests]) 355 (syntax (let ([var (filter-attributes 'matched-attrs ax)]) 356 body))) 357 new-pvar-lst 358 new-cata-defs 359 new-dotted-vars))] 360 [((atag [(unquote [cata -> cvar ...]) default]) . rst) 361 (identifier? (syntax atag)) 362 (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))]) 363 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) 364 (compile-attr-list (syntax rst) 365 body-lst 366 attr-exp 367 body-exp 368 (cons (syntax atag) attr-key-lst) 369 nextp 370 fail-k 371 (add-pat-var ctemp pvar-lst) 372 depth 373 cata-fun 374 (add-cata-def depth 375 (syntax [cvar ...]) 376 (syntax cata) 377 ctemp 378 cata-defs) 379 dotted-vars)]) 380 (values (with-syntax ([ax attr-exp] 381 [ct ctemp] 382 [body tests]) 383 (syntax (let ([binding (match-xml-attribute 'atag ax)]) 384 (let ([ct (if binding 385 (cadr binding) 386 default)]) 387 body)))) 388 new-pvar-lst 389 new-cata-defs 390 new-dotted-vars)))] 391 [((atag [(unquote [cvar ...]) default]) . rst) 392 (identifier? (syntax atag)) 393 (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))]) 394 (if (not cata-fun) 395 (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context" 396 stx 397 (syntax [cvar ...]))) 398 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) 399 (compile-attr-list (syntax rst) 400 body-lst 401 attr-exp 402 body-exp 403 (cons (syntax atag) attr-key-lst) 404 nextp 405 fail-k 406 (add-pat-var ctemp pvar-lst) 407 depth 408 cata-fun 409 (add-cata-def depth 410 (syntax [cvar ...]) 411 cata-fun 412 ctemp 413 cata-defs) 414 dotted-vars)]) 415 (values (with-syntax ([ax attr-exp] 416 [ct ctemp] 417 [body tests]) 418 (syntax (let ([binding (match-xml-attribute 'atag ax)]) 419 (let ([ct (if binding 420 (cadr binding) 421 default)]) 422 body)))) 423 new-pvar-lst 424 new-cata-defs 425 new-dotted-vars)))] 426 [((atag [(unquote var) default]) . rst) 427 (and (identifier? (syntax atag)) (identifier? (syntax var))) 428 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) 429 (compile-attr-list (syntax rst) 430 body-lst 431 attr-exp 432 body-exp 433 (cons (syntax atag) attr-key-lst) 434 nextp 435 fail-k 436 (add-pat-var (syntax var) pvar-lst) 437 depth 438 cata-fun 439 cata-defs 440 dotted-vars)]) 441 (values (with-syntax ([ax attr-exp] 442 [body tests]) 443 (syntax (let ([binding (match-xml-attribute 'atag ax)]) 444 (let ([var (if binding 445 (cadr binding) 446 default)]) 447 body)))) 448 new-pvar-lst 449 new-cata-defs 450 new-dotted-vars))] 451 [((atag (unquote [cata -> cvar ...])) . rst) 452 (identifier? (syntax atag)) 453 (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))]) 454 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) 455 (compile-attr-list (syntax rst) 456 body-lst 457 attr-exp 458 body-exp 459 (cons (syntax atag) attr-key-lst) 460 nextp 461 fail-k 462 (add-pat-var ctemp pvar-lst) 463 depth 464 cata-fun 465 (add-cata-def depth 466 (syntax [cvar ...]) 467 (syntax cata) 468 ctemp 469 cata-defs) 470 dotted-vars)]) 471 (values (with-syntax ([ax attr-exp] 472 [ct ctemp] 473 [body tests] 474 [fail-to fail-k]) 475 (syntax (let ([binding (match-xml-attribute 'atag ax)]) 476 (if binding 477 (let ([ct (cadr binding)]) 478 body) 479 (fail-to))))) 480 new-pvar-lst 481 new-cata-defs 482 new-dotted-vars)))] 483 [((atag (unquote [cvar ...])) . rst) 484 (identifier? (syntax atag)) 485 (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))]) 486 (if (not cata-fun) 487 (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context" 488 stx 489 (syntax [cvar ...]))) 490 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) 491 (compile-attr-list (syntax rst) 492 body-lst 493 attr-exp 494 body-exp 495 (cons (syntax atag) attr-key-lst) 496 nextp 497 fail-k 498 (add-pat-var ctemp pvar-lst) 499 depth 500 cata-fun 501 (add-cata-def depth 502 (syntax [cvar ...]) 503 cata-fun 504 ctemp 505 cata-defs) 506 dotted-vars)]) 507 (values (with-syntax ([ax attr-exp] 508 [ct ctemp] 509 [body tests] 510 [fail-to fail-k]) 511 (syntax (let ([binding (match-xml-attribute 'atag ax)]) 512 (if binding 513 (let ([ct (cadr binding)]) 514 body) 515 (fail-to))))) 516 new-pvar-lst 517 new-cata-defs 518 new-dotted-vars)))] 519 [((atag (unquote var)) . rst) 520 (and (identifier? (syntax atag)) (identifier? (syntax var))) 521 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) 522 (compile-attr-list (syntax rst) 523 body-lst 524 attr-exp 525 body-exp 526 (cons (syntax atag) attr-key-lst) 527 nextp 528 fail-k 529 (add-pat-var (syntax var) pvar-lst) 530 depth 531 cata-fun 532 cata-defs 533 dotted-vars)]) 534 (values (with-syntax ([ax attr-exp] 535 [body tests] 536 [fail-to fail-k]) 537 (syntax (let ([binding (match-xml-attribute 'atag ax)]) 538 (if binding 539 (let ([var (cadr binding)]) 540 body) 541 (fail-to))))) 542 new-pvar-lst 543 new-cata-defs 544 new-dotted-vars))] 545 [((atag (i ...)) . rst) 546 (identifier? (syntax atag)) 547 (sxml-match-syntax-error "bad attribute pattern" 548 stx 549 (syntax (kwd (i ...))))] 550 [((atag i) . rst) 551 (and (identifier? (syntax atag)) (identifier? (syntax i))) 552 (sxml-match-syntax-error "bad attribute pattern" 553 stx 554 (syntax (kwd i)))] 555 [((atag literal) . rst) 556 (and (identifier? (syntax atag)) (literal? (syntax literal))) 557 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars) 558 (compile-attr-list (syntax rst) 559 body-lst 560 attr-exp 561 body-exp 562 (cons (syntax atag) attr-key-lst) 563 nextp 564 fail-k 565 pvar-lst 566 depth 567 cata-fun 568 cata-defs 569 dotted-vars)]) 570 (values (with-syntax ([ax attr-exp] 571 [body tests] 572 [fail-to fail-k]) 573 (syntax (let ([binding (match-xml-attribute 'atag ax)]) 574 (if binding 575 (if (equal? (cadr binding) literal) 576 body 577 (fail-to)) 578 (fail-to))))) 579 new-pvar-lst 580 new-cata-defs 581 new-dotted-vars))] 582 [() 583 (compile-item-list body-lst 584 body-exp 585 nextp 586 fail-k 587 #t 588 pvar-lst 589 depth 590 cata-fun 591 cata-defs 592 dotted-vars)]))] 593 [compile-item-list 594 (lambda (lst exp nextp fail-k ellipsis-allowed? pvar-lst depth cata-fun cata-defs dotted-vars) 595 (syntax-case lst (unquote ->) 596 [() (compile-end-element exp nextp fail-k pvar-lst cata-defs dotted-vars)] 597 [(unquote var) 598 (identifier? (syntax var)) 599 (if (not ellipsis-allowed?) 600 (sxml-match-syntax-error "improper list pattern not allowed in this context" 601 stx 602 (syntax dots)) 603 (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars) 604 (nextp (add-pat-var (syntax var) pvar-lst) cata-defs dotted-vars)]) 605 (values (with-syntax ([x exp] 606 [body next-tests]) 607 (syntax (let ([var x]) body))) 608 new-pvar-lst 609 new-cata-defs 610 new-dotted-vars)))] 611 [(unquote [cata -> cvar ...]) 612 (if (not ellipsis-allowed?) 613 (sxml-match-syntax-error "improper list pattern not allowed in this context" 614 stx 615 (syntax dots)) 616 (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))]) 617 (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars) 618 (nextp (add-pat-var ctemp pvar-lst) 619 (add-cata-def depth 620 (syntax [cvar ...]) 621 (syntax cata) 622 ctemp 623 cata-defs) 624 dotted-vars)]) 625 (values (with-syntax ([ct ctemp] 626 [x exp] 627 [body next-tests]) 628 (syntax (let ([ct x]) body))) 629 new-pvar-lst 630 new-cata-defs 631 new-dotted-vars))))] 632 [(unquote [cvar ...]) 633 (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))]) 634 (if (not cata-fun) 635 (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context" 636 stx 637 (syntax [cvar ...]))) 638 (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars) 639 (nextp (add-pat-var ctemp pvar-lst) 640 (add-cata-def depth 641 (syntax [cvar ...]) 642 cata-fun 643 ctemp 644 cata-defs) 645 dotted-vars)]) 646 (values (with-syntax ([ct ctemp] 647 [x exp] 648 [body next-tests]) 649 (syntax (let ([ct x]) body))) 650 new-pvar-lst 651 new-cata-defs 652 new-dotted-vars)))] 653 [(item dots . rst) 654 (ellipsis? (syntax dots)) 655 (if (not ellipsis-allowed?) 656 (sxml-match-syntax-error "ellipses not allowed in this context" 657 stx 658 (syntax dots)) 659 (compile-dotted-pattern-list (syntax item) 660 (syntax rst) 661 exp 662 nextp 663 fail-k 664 pvar-lst 665 depth 666 cata-fun 667 cata-defs 668 dotted-vars))] 669 [(item . rst) 670 (compile-item (syntax item) 671 exp 672 (lambda (new-exp new-pvar-lst new-cata-defs new-dotted-vars) 673 (compile-item-list (syntax rst) 674 new-exp 675 nextp 676 fail-k 677 ellipsis-allowed? 678 new-pvar-lst 679 depth 680 cata-fun 681 new-cata-defs 682 new-dotted-vars)) 683 fail-k 684 pvar-lst 685 depth 686 cata-fun 687 cata-defs 688 dotted-vars)]))] 689 [compile-dotted-pattern-list 690 (lambda (item 691 tail 692 exp 693 nextp 694 fail-k 695 pvar-lst 696 depth 697 cata-fun 698 cata-defs 699 dotted-vars) 700 (let-values ([(tail-tests tail-pvar-lst tail-cata-defs tail-dotted-vars) 701 (compile-item-list tail 702 (syntax lst) 703 (lambda (new-pvar-lst new-cata-defs new-dotted-vars) 704 (values (with-syntax ([(npv ...) new-pvar-lst]) 705 (syntax (values #t npv ...))) 706 new-pvar-lst 707 new-cata-defs 708 new-dotted-vars)) 709 (syntax fail) 710 #f 711 '() 712 depth 713 '() 714 '() 715 dotted-vars)] 716 [(item-tests item-pvar-lst item-cata-defs item-dotted-vars) 717 (compile-item item 718 (syntax lst) 719 (lambda (new-exp new-pvar-lst new-cata-defs new-dotted-vars) 720 (values (with-syntax ([(npv ...) new-pvar-lst]) 721 (syntax (values #t (cdr lst) npv ...))) 722 new-pvar-lst 723 new-cata-defs 724 new-dotted-vars)) 725 (syntax fail) 726 '() 727 (+ 1 depth) 728 cata-fun 729 '() 730 dotted-vars)]) 731 ; more here: check for duplicate pat-vars, cata-defs 732 (let-values ([(final-tests final-pvar-lst final-cata-defs final-dotted-vars) 733 (nextp (append tail-pvar-lst item-pvar-lst pvar-lst) 734 (append tail-cata-defs item-cata-defs cata-defs) 735 (append item-pvar-lst 736 (cata-defs->pvar-lst item-cata-defs) 737 tail-dotted-vars 738 dotted-vars))]) 739 (let ([temp-item-pvar-lst (generate-temporaries item-pvar-lst)]) 740 (values 741 (with-syntax 742 ([x exp] 743 [fail-to fail-k] 744 [tail-body tail-tests] 745 [item-body item-tests] 746 [final-body final-tests] 747 [(ipv ...) item-pvar-lst] 748 [(gpv ...) temp-item-pvar-lst] 749 [(tpv ...) tail-pvar-lst] 750 [(item-void ...) (map (lambda (i) (syntax (void))) item-pvar-lst)] 751 [(tail-void ...) (map (lambda (i) (syntax (void))) tail-pvar-lst)] 752 [(item-null ...) (map (lambda (i) (syntax '())) item-pvar-lst)] 753 [(item-cons ...) (map (lambda (a b) 754 (with-syntax ([xa a] 755 [xb b]) 756 (syntax (cons xa xb)))) 757 item-pvar-lst 758 temp-item-pvar-lst)]) 759 (syntax (letrec ([match-tail 760 (lambda (lst fail) 761 tail-body)] 762 [match-item 763 (lambda (lst) 764 (let ([fail (lambda () 765 (values #f 766 lst 767 item-void ...))]) 768 item-body))] 769 [match-dotted 770 (lambda (x) 771 (let-values ([(tail-res tpv ...) 772 (match-tail x 773 (lambda () 774 (values #f 775 tail-void ...)))]) 776 (if tail-res 777 (values item-null ... 778 tpv ...) 779 (let-values ([(res new-x ipv ...) (match-item x)]) 780 (if res 781 (let-values ([(gpv ... tpv ...) 782 (match-dotted new-x)]) 783 (values item-cons ... tpv ...)) 784 (let-values ([(last-tail-res tpv ...) 785 (match-tail x fail-to)]) 786 (values item-null ... tpv ...)))))))]) 787 (let-values ([(ipv ... tpv ...) 788 (match-dotted x)]) 789 final-body)))) 790 final-pvar-lst 791 final-cata-defs 792 final-dotted-vars)))))] 793 [compile-item 794 (lambda (item exp nextp fail-k pvar-lst depth cata-fun cata-defs dotted-vars) 795 (syntax-case item (unquote ->) 796 ; normal pattern var 797 [(unquote var) 798 (identifier? (syntax var)) 799 (let ([new-exp (car (generate-temporaries (list exp)))]) 800 (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars) 801 (nextp new-exp (add-pat-var (syntax var) pvar-lst) cata-defs dotted-vars)]) 802 (values (with-syntax ([x exp] 803 [nx new-exp] 804 [body next-tests] 805 [fail-to fail-k]) 806 (syntax (if (pair? x) 807 (let ([nx (cdr x)] 808 [var (car x)]) 809 body) 810 (fail-to)))) 811 new-pvar-lst 812 new-cata-defs 813 new-dotted-vars)))] 814 ; named catamorphism 815 [(unquote [cata -> cvar ...]) 816 (let ([new-exp (car (generate-temporaries (list exp)))] 817 [ctemp (car (generate-temporaries (syntax ([cvar ...]))))]) 818 (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars) 819 (nextp new-exp 820 (add-pat-var ctemp pvar-lst) 821 (add-cata-def depth 822 (syntax [cvar ...]) 823 (syntax cata) 824 ctemp 825 cata-defs) 826 dotted-vars)]) 827 (values (with-syntax ([x exp] 828 [nx new-exp] 829 [ct ctemp] 830 [body next-tests] 831 [fail-to fail-k]) 832 (syntax (if (pair? x) 833 (let ([nx (cdr x)] 834 [ct (car x)]) 835 body) 836 (fail-to)))) 837 new-pvar-lst 838 new-cata-defs 839 new-dotted-vars)))] 840 ; basic catamorphism 841 [(unquote [cvar ...]) 842 (let ([new-exp (car (generate-temporaries (list exp)))] 843 [ctemp (car (generate-temporaries (syntax ([cvar ...]))))]) 844 (if (not cata-fun) 845 (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context" 846 stx 847 (syntax [cvar ...]))) 848 (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars) 849 (nextp new-exp 850 (add-pat-var ctemp pvar-lst) 851 (add-cata-def depth 852 (syntax [cvar ...]) 853 cata-fun 854 ctemp 855 cata-defs) 856 dotted-vars)]) 857 (values (with-syntax ([x exp] 858 [nx new-exp] 859 [ct ctemp] 860 [body next-tests] 861 [fail-to fail-k]) 862 (syntax (if (pair? x) 863 (let ([nx (cdr x)] 864 [ct (car x)]) 865 body) 866 (fail-to)))) 867 new-pvar-lst 868 new-cata-defs 869 new-dotted-vars)))] 870 [(tag item ...) 871 (identifier? (syntax tag)) 872 (let ([new-exp (car (generate-temporaries (list exp)))]) 873 (let-values ([(after-tests after-pvar-lst after-cata-defs after-dotted-vars) 874 (compile-element-pat (syntax (tag item ...)) 875 (with-syntax ([x exp]) 876 (syntax (car x))) 877 (lambda (more-pvar-lst more-cata-defs more-dotted-vars) 878 (let-values ([(next-tests new-pvar-lst 879 new-cata-defs 880 new-dotted-vars) 881 (nextp new-exp 882 more-pvar-lst 883 more-cata-defs 884 more-dotted-vars)]) 885 (values (with-syntax ([x exp] 886 [nx new-exp] 887 [body next-tests]) 888 (syntax (let ([nx (cdr x)]) 889 body))) 890 new-pvar-lst 891 new-cata-defs 892 new-dotted-vars))) 893 fail-k 894 pvar-lst 895 depth 896 cata-fun 897 cata-defs 898 dotted-vars)]) 899 ; test that we are not at the end of an item-list, BEFORE 900 ; entering tests for the element pattern (against the 'car' of the item-list) 901 (values (with-syntax ([x exp] 902 [body after-tests] 903 [fail-to fail-k]) 904 (syntax (if (pair? x) 905 body 906 (fail-to)))) 907 after-pvar-lst 908 after-cata-defs 909 after-dotted-vars)))] 910 [(i ...) 911 (sxml-match-syntax-error "bad pattern syntax (not an element pattern)" 912 stx 913 (syntax (i ...)))] 914 [i 915 (identifier? (syntax i)) 916 (sxml-match-syntax-error "bad pattern syntax (symbol not allowed in this context)" 917 stx 918 (syntax i))] 919 [literal 920 (literal? (syntax literal)) 921 (let ([new-exp (car (generate-temporaries (list exp)))]) 922 (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars) 923 (nextp new-exp pvar-lst cata-defs dotted-vars)]) 924 (values (with-syntax ([x exp] 925 [nx new-exp] 926 [body next-tests] 927 [fail-to fail-k]) 928 (syntax (if (and (pair? x) (equal? literal (car x))) 929 (let ([nx (cdr x)]) 930 body) 931 (fail-to)))) 932 new-pvar-lst 933 new-cata-defs 934 new-dotted-vars)))]))]) 935 (let ([fail-k (syntax failure)]) 936 (syntax-case stx (unquote guard ->) 937 [(compile-clause ((unquote var) (guard gexp ...) action0 action ...) 938 exp 939 cata-fun 940 fail-exp) 941 (identifier? (syntax var)) 942 (syntax (let ([var exp]) 943 (if (and gexp ...) 944 (begin action0 action ...) 945 (fail-exp))))] 946 [(compile-clause ((unquote [cata -> cvar ...]) (guard gexp ...) action0 action ...) 947 exp 948 cata-fun 949 fail-exp) 950 (syntax (if (and gexp ...) 951 (let-values ([(cvar ...) (cata exp)]) 952 (begin action0 action ...)) 953 (fail-exp)))] 954 [(compile-clause ((unquote [cvar ...]) (guard gexp ...) action0 action ...) 955 exp 956 cata-fun 957 fail-exp) 958 (if (not (extract-cata-fun (syntax cata-fun))) 959 (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context" 960 stx 961 (syntax [cvar ...])) 962 (syntax (if (and gexp ...) 963 (let-values ([(cvar ...) (cata-fun exp)]) 964 (begin action0 action ...)) 965 (fail-exp))))] 966 [(compile-clause ((unquote var) action0 action ...) exp cata-fun fail-exp) 967 (identifier? (syntax var)) 968 (syntax (let ([var exp]) 969 action0 action ...))] 970 [(compile-clause ((unquote [cata -> cvar ...]) action0 action ...) exp cata-fun fail-exp) 971 (syntax (let-values ([(cvar ...) (cata exp)]) 972 action0 action ...))] 973 [(compile-clause ((unquote [cvar ...]) action0 action ...) exp cata-fun fail-exp) 974 (if (not (extract-cata-fun (syntax cata-fun))) 975 (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context" 976 stx 977 (syntax [cvar ...])) 978 (syntax (let-values ([(cvar ...) (cata-fun exp)]) 979 action0 action ...)))] 980 [(compile-clause ((lst . rst) (guard gexp ...) action0 action ...) exp cata-fun fail-exp) 981 (and (identifier? (syntax lst)) (eq? 'list (syntax-object->datum (syntax lst)))) 982 (let-values ([(result pvar-lst cata-defs dotted-vars) 983 (compile-item-list (syntax rst) 984 (syntax exp) 985 (lambda (new-pvar-lst new-cata-defs new-dotted-vars) 986 (values 987 (with-syntax 988 ([exp-body (process-cata-defs new-cata-defs 989 (process-output-action 990 (syntax (begin action0 991 action ...)) 992 new-dotted-vars))] 993 [fail-to fail-k]) 994 (syntax (if (and gexp ...) exp-body (fail-to)))) 995 new-pvar-lst 996 new-cata-defs 997 new-dotted-vars)) 998 fail-k 999 #t 1000 '() 1001 0 1002 (extract-cata-fun (syntax cata-fun)) 1003 '() 1004 '())]) 1005 (with-syntax ([fail-to fail-k] 1006 [body result]) 1007 (syntax (let ([fail-to fail-exp]) 1008 (if (nodeset? exp) 1009 body 1010 (fail-to))))))] 1011 [(compile-clause ((lst . rst) action0 action ...) exp cata-fun fail-exp) 1012 (and (identifier? (syntax lst)) (eq? 'list (syntax-object->datum (syntax lst)))) 1013 (let-values ([(result pvar-lst cata-defs dotted-vars) 1014 (compile-item-list (syntax rst) 1015 (syntax exp) 1016 (lambda (new-pvar-lst new-cata-defs new-dotted-vars) 1017 (values (process-cata-defs new-cata-defs 1018 (process-output-action 1019 (syntax (begin action0 1020 action ...)) 1021 new-dotted-vars)) 1022 new-pvar-lst 1023 new-cata-defs 1024 new-dotted-vars)) 1025 fail-k 1026 #t 1027 '() 1028 0 1029 (extract-cata-fun (syntax cata-fun)) 1030 '() 1031 '())]) 1032 (with-syntax ([body result] 1033 [fail-to fail-k]) 1034 (syntax (let ([fail-to fail-exp]) 1035 (if (nodeset? exp) 1036 body 1037 (fail-to))))))] 1038 [(compile-clause ((fst . rst) (guard gexp ...) action0 action ...) exp cata-fun fail-exp) 1039 (identifier? (syntax fst)) 1040 (let-values ([(result pvar-lst cata-defs dotted-vars) 1041 (compile-element-pat (syntax (fst . rst)) 1042 (syntax exp) 1043 (lambda (new-pvar-lst new-cata-defs new-dotted-vars) 1044 (values 1045 (with-syntax 1046 ([body (process-cata-defs new-cata-defs 1047 (process-output-action 1048 (syntax (begin action0 1049 action ...)) 1050 new-dotted-vars))] 1051 [fail-to fail-k]) 1052 (syntax (if (and gexp ...) body (fail-to)))) 1053 new-pvar-lst 1054 new-cata-defs 1055 new-dotted-vars)) 1056 fail-k 1057 '() 1058 0 1059 (extract-cata-fun (syntax cata-fun)) 1060 '() 1061 '())]) 1062 (with-syntax ([fail-to fail-k] 1063 [body result]) 1064 (syntax (let ([fail-to fail-exp]) 1065 body))))] 1066 [(compile-clause ((fst . rst) action0 action ...) exp cata-fun fail-exp) 1067 (identifier? (syntax fst)) 1068 (let-values ([(result pvar-lst cata-defs dotted-vars) 1069 (compile-element-pat (syntax (fst . rst)) 1070 (syntax exp) 1071 (lambda (new-pvar-lst new-cata-defs new-dotted-vars) 1072 (values (process-cata-defs new-cata-defs 1073 (process-output-action 1074 (syntax (begin action0 1075 action ...)) 1076 new-dotted-vars)) 1077 new-pvar-lst 1078 new-cata-defs 1079 new-dotted-vars)) 1080 fail-k 1081 '() 1082 0 1083 (extract-cata-fun (syntax cata-fun)) 1084 '() 1085 '())]) 1086 (with-syntax ([fail-to fail-k] 1087 [body result]) 1088 (syntax (let ([fail-to fail-exp]) 1089 body))))] 1090 [(compile-clause ((i ...) (guard gexp ...) action0 action ...) exp cata-fun fail-exp) 1091 (sxml-match-syntax-error "bad pattern syntax (not an element pattern)" 1092 stx 1093 (syntax (i ...)))] 1094 [(compile-clause ((i ...) action0 action ...) exp cata-fun fail-exp) 1095 (sxml-match-syntax-error "bad pattern syntax (not an element pattern)" 1096 stx 1097 (syntax (i ...)))] 1098 [(compile-clause (pat (guard gexp ...) action0 action ...) exp cata-fun fail-exp) 1099 (identifier? (syntax pat)) 1100 (sxml-match-syntax-error "bad pattern syntax (symbol not allowed in this context)" 1101 stx 1102 (syntax pat))] 1103 [(compile-clause (pat action0 action ...) exp cata-fun fail-exp) 1104 (identifier? (syntax pat)) 1105 (sxml-match-syntax-error "bad pattern syntax (symbol not allowed in this context)" 1106 stx 1107 (syntax pat))] 1108 [(compile-clause (literal (guard gexp ...) action0 action ...) exp cata-fun fail-exp) 1109 (literal? (syntax literal)) 1110 (syntax (if (and (equal? literal exp) (and gexp ...)) 1111 (begin action0 action ...) 1112 (fail-exp)))] 1113 [(compile-clause (literal action0 action ...) exp cata-fun fail-exp) 1114 (literal? (syntax literal)) 1115 (syntax (if (equal? literal exp) 1116 (begin action0 action ...) 1117 (fail-exp)))]))))) 1118 1119 (define-syntax sxml-match1 1120 (syntax-rules () 1121 [(sxml-match1 exp cata-fun clause) 1122 (compile-clause clause exp cata-fun 1123 (lambda () (error 'sxml-match "no matching clause found")))] 1124 [(sxml-match1 exp cata-fun clause0 clause ...) 1125 (let/ec escape 1126 (compile-clause clause0 exp cata-fun 1127 (lambda () (call-with-values 1128 (lambda () (sxml-match1 exp cata-fun 1129 clause ...)) 1130 escape))))])) 1131 1132 (define-syntax sxml-match 1133 (syntax-rules () 1134 ((sxml-match val clause0 clause ...) 1135 (letrec ([cfun (lambda (exp) 1136 (sxml-match1 exp cfun clause0 clause ...))]) 1137 (cfun val))))) 1138 1139 (define-syntax sxml-match-let1 1140 (syntax-rules () 1141 [(sxml-match-let1 syntag synform () body0 body ...) 1142 (let () body0 body ...)] 1143 [(sxml-match-let1 syntag synform ([pat exp]) body0 body ...) 1144 (compile-clause (pat (let () body0 body ...)) 1145 exp 1146 #f 1147 (lambda () (error 'syntag "could not match pattern ~s" 'pat)))] 1148 [(sxml-match-let1 syntag synform ([pat0 exp0] [pat exp] ...) body0 body ...) 1149 (compile-clause (pat0 (sxml-match-let1 syntag synform ([pat exp] ...) body0 body ...)) 1150 exp0 1151 #f 1152 (lambda () (error 'syntag "could not match pattern ~s" 'pat0)))])) 1153 1154 (define-syntax sxml-match-let-help 1155 (lambda (stx) 1156 (syntax-case stx () 1157 [(sxml-match-let-help syntag synform ([pat exp] ...) body0 body ...) 1158 (with-syntax ([(temp-name ...) (generate-temporaries (syntax (exp ...)))]) 1159 (syntax (let ([temp-name exp] ...) 1160 (sxml-match-let1 syntag synform ([pat temp-name] ...) body0 body ...))))]))) 1161 1162 (define-syntax sxml-match-let 1163 (lambda (stx) 1164 (syntax-case stx () 1165 [(sxml-match-let ([pat exp] ...) body0 body ...) 1166 (with-syntax ([synform stx]) 1167 (syntax (sxml-match-let-help sxml-match-let synform ([pat exp] ...) body0 body ...)))]))) 1168 1169 (define-syntax sxml-match-let* 1170 (lambda (stx) 1171 (syntax-case stx () 1172 [(sxml-match-let* () body0 body ...) 1173 (syntax (let () body0 body ...))] 1174 [(sxml-match-let* ([pat0 exp0] [pat exp] ...) body0 body ...) 1175 (with-syntax ([synform stx]) 1176 (syntax (sxml-match-let-help sxml-match-let* synform ([pat0 exp0]) 1177 (sxml-match-let* ([pat exp] ...) 1178 body0 body ...))))]))) 1179 1180 ) 1181 1182