(module sxml-match mzscheme
(provide sxml-match
sxml-match-let
sxml-match-let*)
(require (rename (lib "fold.ss" "srfi" "1") fold-right fold-right)
(rename (lib "filter.ss" "srfi" "1") filter filter))
(define (nodeset? x)
(or (and (pair? x) (not (symbol? (car x)))) (null? x)))
(define (xml-element-tag s)
(if (and (pair? s) (symbol? (car s)))
(car s)
(error 'xml-element-tag "expected an xml-element, given" s)))
(define (xml-element-attributes s)
(if (and (pair? s) (symbol? (car s)))
(fold-right (lambda (a b)
(if (and (pair? a) (eq? '@ (car a)))
(if (null? b)
(filter (lambda (i) (not (and (pair? i) (eq? '@ (car i))))) (cdr a))
(fold-right (lambda (c d)
(if (and (pair? c) (eq? '@ (car c)))
d
(cons c d)))
b (cdr a)))
b))
'()
(cdr s))
(error 'xml-element-attributes "expected an xml-element, given" s)))
(define (xml-element-contents s)
(if (and (pair? s) (symbol? (car s)))
(filter (lambda (i)
(not (and (pair? i) (eq? '@ (car i)))))
(cdr s))
(error 'xml-element-contents "expected an xml-element, given" s)))
(define (match-xml-attribute key l)
(if (not (pair? l))
#f
(if (eq? (car (car l)) key)
(car l)
(match-xml-attribute key (cdr l)))))
(define (filter-attributes keys lst)
(if (null? lst)
'()
(if (member (caar lst) keys)
(filter-attributes keys (cdr lst))
(cons (car lst) (filter-attributes keys (cdr lst))))))
(define-syntax compile-clause
(lambda (stx)
(letrec
([sxml-match-syntax-error
(lambda (msg exp sub)
(raise-syntax-error #f msg (with-syntax ([s exp]) (syntax (sxml-match s))) sub))]
[ellipsis?
(lambda (stx)
(and (identifier? stx) (eq? '... (syntax-object->datum stx))))]
[literal?
(lambda (stx)
(let ([x (syntax-object->datum stx)])
(or (string? x)
(char? x)
(number? x)
(boolean? x))))]
[keyword?
(lambda (stx)
(and (identifier? stx)
(let ([str (symbol->string (syntax-object->datum stx))])
(char=? #\: (string-ref str (- (string-length str) 1))))))]
[extract-cata-fun
(lambda (cf)
(syntax-case cf ()
[#f #f]
[other cf]))]
[add-pat-var
(lambda (pvar pvar-lst)
(define (check-pvar lst)
(if (null? lst)
(void)
(if (bound-identifier=? (car lst) pvar)
(sxml-match-syntax-error "duplicate pattern variable not allowed"
stx
pvar)
(check-pvar (cdr lst)))))
(check-pvar pvar-lst)
(cons pvar pvar-lst))]
[add-cata-def
(lambda (depth cvars cfun ctemp cdefs)
(cons (list depth cvars cfun ctemp) cdefs))]
[process-cata-exp
(lambda (depth cfun ctemp)
(if (= depth 0)
(with-syntax ([cf cfun]
[ct ctemp])
(syntax (cf ct)))
(let ([new-ctemp (car (generate-temporaries (list ctemp)))])
(with-syntax ([ct ctemp]
[nct new-ctemp]
[body (process-cata-exp (- depth 1) cfun new-ctemp)])
(syntax (map (lambda (nct) body) ct))))))]
[process-cata-defs
(lambda (cata-defs body)
(if (null? cata-defs)
body
(with-syntax ([(cata-binding ...)
(map (lambda (def)
(with-syntax ([bvar (cadr def)]
[bval (process-cata-exp (car def)
(caddr def)
(cadddr def))])
(syntax (bvar bval))))
cata-defs)]
[body-stx body])
(syntax (let-values (cata-binding ...)
body-stx)))))]
[cata-defs->pvar-lst
(lambda (lst)
(if (null? lst)
'()
(let iter ([items (cadr (car lst))])
(syntax-case items ()
[() (cata-defs->pvar-lst (cdr lst))]
[(fst . rst) (cons (syntax fst) (iter (syntax rst)))]))))]
[process-output-action
(lambda (action dotted-vars)
(define (finite-lst? lst)
(syntax-case lst ()
(item
(identifier? (syntax item))
#f)
(()
#t)
((fst dots . rst)
(ellipsis? (syntax dots))
#f)
((fst . rst)
(finite-lst? (syntax rst)))))
(define (expand-lst lst)
(syntax-case lst ()
[() (syntax '())]
[item
(identifier? (syntax item))
(syntax item)]
[(fst dots . rst)
(ellipsis? (syntax dots))
(with-syntax ([exp-lft (expand-dotted-item
(process-output-action (syntax fst)
dotted-vars))]
[exp-rgt (expand-lst (syntax rst))])
(syntax (append exp-lft exp-rgt)))]
[(fst . rst)
(with-syntax ([exp-lft (process-output-action (syntax fst)
dotted-vars)]
[exp-rgt (expand-lst (syntax rst))])
(syntax (cons exp-lft exp-rgt)))]))
(define (member-var? var lst)
(let iter ([lst lst])
(if (null? lst)
#f
(if (or (bound-identifier=? var (car lst))
(free-identifier=? var (car lst)))
#t
(iter (cdr lst))))))
(define (dotted-var? var)
(member-var? var dotted-vars))
(define (merge-pvars lst1 lst2)
(if (null? lst1)
lst2
(if (member-var? (car lst1) lst2)
(merge-pvars (cdr lst1) lst2)
(cons (car lst1) (merge-pvars (cdr lst1) lst2)))))
(define (select-dotted-vars x)
(define (walk-quasi-body y)
(syntax-case y (unquote unquote-splicing)
[((unquote a) . rst)
(merge-pvars (select-dotted-vars (syntax a))
(walk-quasi-body (syntax rst)))]
[((unquote-splicing a) . rst)
(merge-pvars (select-dotted-vars (syntax a))
(walk-quasi-body (syntax rst)))]
[(fst . rst)
(merge-pvars (walk-quasi-body (syntax fst))
(walk-quasi-body (syntax rst)))]
[other
'()]))
(syntax-case x (quote quasiquote)
[(quote . rst) '()]
[(quasiquote . rst) (walk-quasi-body (syntax rst))]
[(fst . rst)
(merge-pvars (select-dotted-vars (syntax fst))
(select-dotted-vars (syntax rst)))]
[item
(and (identifier? (syntax item))
(dotted-var? (syntax item)))
(list (syntax item))]
[item '()]))
(define (expand-dotted-item item)
(let ([dvars (select-dotted-vars item)])
(syntax-case item ()
[x
(identifier? (syntax x))
(syntax x)]
[x (with-syntax ([(dv ...) dvars])
(syntax (map (lambda (dv ...) x) dv ...)))])))
(define (expand-quasiquote-body x)
(syntax-case x (unquote unquote-splicing quasiquote)
[(quasiquote . rst) (process-quasiquote x)]
[(unquote item)
(with-syntax ([expanded-item (process-output-action (syntax item)
dotted-vars)])
(syntax (unquote expanded-item)))]
[(unquote-splicing item)
(with-syntax ([expanded-item (process-output-action (syntax item)
dotted-vars)])
(syntax (unquote-splicing expanded-item)))]
[((unquote item) dots . rst)
(ellipsis? (syntax dots))
(with-syntax ([expanded-item (expand-dotted-item
(process-output-action (syntax item)
dotted-vars))]
[expanded-rst (expand-quasiquote-body (syntax rst))])
(syntax ((unquote-splicing expanded-item) . expanded-rst)))]
[(item dots . rst)
(ellipsis? (syntax dots))
(with-syntax ([expanded-item (expand-dotted-item
(process-output-action (syntax (quasiquote item))
dotted-vars))]
[expanded-rst (expand-quasiquote-body (syntax rst))])
(syntax ((unquote-splicing expanded-item) . expanded-rst)))]
[(fst . rst)
(with-syntax ([expanded-fst (expand-quasiquote-body (syntax fst))]
[expanded-rst (expand-quasiquote-body (syntax rst))])
(syntax (expanded-fst . expanded-rst)))]
[other x]))
(define (process-quasiquote x)
(syntax-case x ()
[(quasiquote term) (with-syntax ([expanded-body (expand-quasiquote-body (syntax term))])
(syntax (quasiquote expanded-body)))]
[else (sxml-match-syntax-error "bad quasiquote-form"
stx
x)]))
(syntax-case action (quote quasiquote)
[(quote . rst) action]
[(quasiquote . rst) (process-quasiquote action)]
[(fst . rst) (if (finite-lst? action)
(with-syntax ([exp-lft (process-output-action (syntax fst) dotted-vars)]
[exp-rgt (process-output-action (syntax rst) dotted-vars)])
(syntax (exp-lft . exp-rgt)))
(with-syntax ([exp-lft (process-output-action (syntax fst)
dotted-vars)]
[exp-rgt (expand-lst (syntax rst))])
(syntax (apply exp-lft exp-rgt))))]
[item action]))]
[compile-element-pat
(lambda (ele exp nextp fail-k pvar-lst depth cata-fun cata-defs dotted-vars)
(syntax-case ele (@)
[(tag (@ . attr-items) . items)
(identifier? (syntax tag))
(let ([attr-exp (car (generate-temporaries (list exp)))]
[body-exp (car (generate-temporaries (list exp)))])
(let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
(compile-attr-list (syntax attr-items)
(syntax items)
attr-exp
body-exp
'()
nextp
fail-k
pvar-lst
depth
cata-fun
cata-defs
dotted-vars)])
(values (with-syntax ([x exp]
[ax attr-exp]
[bx body-exp]
[body tests]
[fail-to fail-k])
(syntax (if (and (pair? x) (eq? 'tag (xml-element-tag x)))
(let ([ax (xml-element-attributes x)]
[bx (xml-element-contents x)])
body)
(fail-to))))
new-pvar-lst
new-cata-defs
new-dotted-vars)))]
[(tag . items)
(identifier? (syntax tag))
(let ([body-exp (car (generate-temporaries (list exp)))])
(let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
(compile-item-list (syntax items)
body-exp
nextp
fail-k
#t
pvar-lst
depth
cata-fun
cata-defs
dotted-vars)])
(values (with-syntax ([x exp]
[bx body-exp]
[body tests]
[fail-to fail-k])
(syntax (if (and (pair? x) (eq? 'tag (xml-element-tag x)))
(let ([bx (xml-element-contents x)])
body)
(fail-to))))
new-pvar-lst
new-cata-defs
new-dotted-vars)))]))]
[compile-end-element
(lambda (exp nextp fail-k pvar-lst cata-defs dotted-vars)
(let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
(nextp pvar-lst cata-defs dotted-vars)])
(values (with-syntax ([x exp]
[body next-tests]
[fail-to fail-k])
(syntax (if (null? x) body (fail-to))))
new-pvar-lst
new-cata-defs
new-dotted-vars)))]
[compile-attr-list
(lambda (attr-lst body-lst attr-exp body-exp attr-key-lst nextp fail-k pvar-lst depth cata-fun cata-defs dotted-vars)
(syntax-case attr-lst (unquote ->)
[(unquote var)
(identifier? (syntax var))
(let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
(compile-item-list body-lst
body-exp
nextp
fail-k
#t
(add-pat-var (syntax var) pvar-lst)
depth
cata-fun
cata-defs
dotted-vars)])
(values (with-syntax ([ax attr-exp]
[matched-attrs attr-key-lst]
[body tests])
(syntax (let ([var (filter-attributes 'matched-attrs ax)])
body)))
new-pvar-lst
new-cata-defs
new-dotted-vars))]
[((atag [(unquote [cata -> cvar ...]) default]) . rst)
(identifier? (syntax atag))
(let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
(let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
(compile-attr-list (syntax rst)
body-lst
attr-exp
body-exp
(cons (syntax atag) attr-key-lst)
nextp
fail-k
(add-pat-var ctemp pvar-lst)
depth
cata-fun
(add-cata-def depth
(syntax [cvar ...])
(syntax cata)
ctemp
cata-defs)
dotted-vars)])
(values (with-syntax ([ax attr-exp]
[ct ctemp]
[body tests])
(syntax (let ([binding (match-xml-attribute 'atag ax)])
(let ([ct (if binding
(cadr binding)
default)])
body))))
new-pvar-lst
new-cata-defs
new-dotted-vars)))]
[((atag [(unquote [cvar ...]) default]) . rst)
(identifier? (syntax atag))
(let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
(if (not cata-fun)
(sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
stx
(syntax [cvar ...])))
(let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
(compile-attr-list (syntax rst)
body-lst
attr-exp
body-exp
(cons (syntax atag) attr-key-lst)
nextp
fail-k
(add-pat-var ctemp pvar-lst)
depth
cata-fun
(add-cata-def depth
(syntax [cvar ...])
cata-fun
ctemp
cata-defs)
dotted-vars)])
(values (with-syntax ([ax attr-exp]
[ct ctemp]
[body tests])
(syntax (let ([binding (match-xml-attribute 'atag ax)])
(let ([ct (if binding
(cadr binding)
default)])
body))))
new-pvar-lst
new-cata-defs
new-dotted-vars)))]
[((atag [(unquote var) default]) . rst)
(and (identifier? (syntax atag)) (identifier? (syntax var)))
(let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
(compile-attr-list (syntax rst)
body-lst
attr-exp
body-exp
(cons (syntax atag) attr-key-lst)
nextp
fail-k
(add-pat-var (syntax var) pvar-lst)
depth
cata-fun
cata-defs
dotted-vars)])
(values (with-syntax ([ax attr-exp]
[body tests])
(syntax (let ([binding (match-xml-attribute 'atag ax)])
(let ([var (if binding
(cadr binding)
default)])
body))))
new-pvar-lst
new-cata-defs
new-dotted-vars))]
[((atag (unquote [cata -> cvar ...])) . rst)
(identifier? (syntax atag))
(let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
(let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
(compile-attr-list (syntax rst)
body-lst
attr-exp
body-exp
(cons (syntax atag) attr-key-lst)
nextp
fail-k
(add-pat-var ctemp pvar-lst)
depth
cata-fun
(add-cata-def depth
(syntax [cvar ...])
(syntax cata)
ctemp
cata-defs)
dotted-vars)])
(values (with-syntax ([ax attr-exp]
[ct ctemp]
[body tests]
[fail-to fail-k])
(syntax (let ([binding (match-xml-attribute 'atag ax)])
(if binding
(let ([ct (cadr binding)])
body)
(fail-to)))))
new-pvar-lst
new-cata-defs
new-dotted-vars)))]
[((atag (unquote [cvar ...])) . rst)
(identifier? (syntax atag))
(let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
(if (not cata-fun)
(sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
stx
(syntax [cvar ...])))
(let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
(compile-attr-list (syntax rst)
body-lst
attr-exp
body-exp
(cons (syntax atag) attr-key-lst)
nextp
fail-k
(add-pat-var ctemp pvar-lst)
depth
cata-fun
(add-cata-def depth
(syntax [cvar ...])
cata-fun
ctemp
cata-defs)
dotted-vars)])
(values (with-syntax ([ax attr-exp]
[ct ctemp]
[body tests]
[fail-to fail-k])
(syntax (let ([binding (match-xml-attribute 'atag ax)])
(if binding
(let ([ct (cadr binding)])
body)
(fail-to)))))
new-pvar-lst
new-cata-defs
new-dotted-vars)))]
[((atag (unquote var)) . rst)
(and (identifier? (syntax atag)) (identifier? (syntax var)))
(let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
(compile-attr-list (syntax rst)
body-lst
attr-exp
body-exp
(cons (syntax atag) attr-key-lst)
nextp
fail-k
(add-pat-var (syntax var) pvar-lst)
depth
cata-fun
cata-defs
dotted-vars)])
(values (with-syntax ([ax attr-exp]
[body tests]
[fail-to fail-k])
(syntax (let ([binding (match-xml-attribute 'atag ax)])
(if binding
(let ([var (cadr binding)])
body)
(fail-to)))))
new-pvar-lst
new-cata-defs
new-dotted-vars))]
[((atag (i ...)) . rst)
(identifier? (syntax atag))
(sxml-match-syntax-error "bad attribute pattern"
stx
(syntax (kwd (i ...))))]
[((atag i) . rst)
(and (identifier? (syntax atag)) (identifier? (syntax i)))
(sxml-match-syntax-error "bad attribute pattern"
stx
(syntax (kwd i)))]
[((atag literal) . rst)
(and (identifier? (syntax atag)) (literal? (syntax literal)))
(let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
(compile-attr-list (syntax rst)
body-lst
attr-exp
body-exp
(cons (syntax atag) attr-key-lst)
nextp
fail-k
pvar-lst
depth
cata-fun
cata-defs
dotted-vars)])
(values (with-syntax ([ax attr-exp]
[body tests]
[fail-to fail-k])
(syntax (let ([binding (match-xml-attribute 'atag ax)])
(if binding
(if (equal? (cadr binding) literal)
body
(fail-to))
(fail-to)))))
new-pvar-lst
new-cata-defs
new-dotted-vars))]
[()
(compile-item-list body-lst
body-exp
nextp
fail-k
#t
pvar-lst
depth
cata-fun
cata-defs
dotted-vars)]))]
[compile-item-list
(lambda (lst exp nextp fail-k ellipsis-allowed? pvar-lst depth cata-fun cata-defs dotted-vars)
(syntax-case lst (unquote ->)
[() (compile-end-element exp nextp fail-k pvar-lst cata-defs dotted-vars)]
[(unquote var)
(identifier? (syntax var))
(if (not ellipsis-allowed?)
(sxml-match-syntax-error "improper list pattern not allowed in this context"
stx
(syntax dots))
(let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
(nextp (add-pat-var (syntax var) pvar-lst) cata-defs dotted-vars)])
(values (with-syntax ([x exp]
[body next-tests])
(syntax (let ([var x]) body)))
new-pvar-lst
new-cata-defs
new-dotted-vars)))]
[(unquote [cata -> cvar ...])
(if (not ellipsis-allowed?)
(sxml-match-syntax-error "improper list pattern not allowed in this context"
stx
(syntax dots))
(let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
(let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
(nextp (add-pat-var ctemp pvar-lst)
(add-cata-def depth
(syntax [cvar ...])
(syntax cata)
ctemp
cata-defs)
dotted-vars)])
(values (with-syntax ([ct ctemp]
[x exp]
[body next-tests])
(syntax (let ([ct x]) body)))
new-pvar-lst
new-cata-defs
new-dotted-vars))))]
[(unquote [cvar ...])
(let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
(if (not cata-fun)
(sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
stx
(syntax [cvar ...])))
(let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
(nextp (add-pat-var ctemp pvar-lst)
(add-cata-def depth
(syntax [cvar ...])
cata-fun
ctemp
cata-defs)
dotted-vars)])
(values (with-syntax ([ct ctemp]
[x exp]
[body next-tests])
(syntax (let ([ct x]) body)))
new-pvar-lst
new-cata-defs
new-dotted-vars)))]
[(item dots . rst)
(ellipsis? (syntax dots))
(if (not ellipsis-allowed?)
(sxml-match-syntax-error "ellipses not allowed in this context"
stx
(syntax dots))
(compile-dotted-pattern-list (syntax item)
(syntax rst)
exp
nextp
fail-k
pvar-lst
depth
cata-fun
cata-defs
dotted-vars))]
[(item . rst)
(compile-item (syntax item)
exp
(lambda (new-exp new-pvar-lst new-cata-defs new-dotted-vars)
(compile-item-list (syntax rst)
new-exp
nextp
fail-k
ellipsis-allowed?
new-pvar-lst
depth
cata-fun
new-cata-defs
new-dotted-vars))
fail-k
pvar-lst
depth
cata-fun
cata-defs
dotted-vars)]))]
[compile-dotted-pattern-list
(lambda (item
tail
exp
nextp
fail-k
pvar-lst
depth
cata-fun
cata-defs
dotted-vars)
(let-values ([(tail-tests tail-pvar-lst tail-cata-defs tail-dotted-vars)
(compile-item-list tail
(syntax lst)
(lambda (new-pvar-lst new-cata-defs new-dotted-vars)
(values (with-syntax ([(npv ...) new-pvar-lst])
(syntax (values #t npv ...)))
new-pvar-lst
new-cata-defs
new-dotted-vars))
(syntax fail)
#f
'()
depth
'()
'()
dotted-vars)]
[(item-tests item-pvar-lst item-cata-defs item-dotted-vars)
(compile-item item
(syntax lst)
(lambda (new-exp new-pvar-lst new-cata-defs new-dotted-vars)
(values (with-syntax ([(npv ...) new-pvar-lst])
(syntax (values #t (cdr lst) npv ...)))
new-pvar-lst
new-cata-defs
new-dotted-vars))
(syntax fail)
'()
(+ 1 depth)
cata-fun
'()
dotted-vars)])
(let-values ([(final-tests final-pvar-lst final-cata-defs final-dotted-vars)
(nextp (append tail-pvar-lst item-pvar-lst pvar-lst)
(append tail-cata-defs item-cata-defs cata-defs)
(append item-pvar-lst
(cata-defs->pvar-lst item-cata-defs)
tail-dotted-vars
dotted-vars))])
(let ([temp-item-pvar-lst (generate-temporaries item-pvar-lst)])
(values
(with-syntax
([x exp]
[fail-to fail-k]
[tail-body tail-tests]
[item-body item-tests]
[final-body final-tests]
[(ipv ...) item-pvar-lst]
[(gpv ...) temp-item-pvar-lst]
[(tpv ...) tail-pvar-lst]
[(item-void ...) (map (lambda (i) (syntax (void))) item-pvar-lst)]
[(tail-void ...) (map (lambda (i) (syntax (void))) tail-pvar-lst)]
[(item-null ...) (map (lambda (i) (syntax '())) item-pvar-lst)]
[(item-cons ...) (map (lambda (a b)
(with-syntax ([xa a]
[xb b])
(syntax (cons xa xb))))
item-pvar-lst
temp-item-pvar-lst)])
(syntax (letrec ([match-tail
(lambda (lst fail)
tail-body)]
[match-item
(lambda (lst)
(let ([fail (lambda ()
(values #f
lst
item-void ...))])
item-body))]
[match-dotted
(lambda (x)
(let-values ([(tail-res tpv ...)
(match-tail x
(lambda ()
(values #f
tail-void ...)))])
(if tail-res
(values item-null ...
tpv ...)
(let-values ([(res new-x ipv ...) (match-item x)])
(if res
(let-values ([(gpv ... tpv ...)
(match-dotted new-x)])
(values item-cons ... tpv ...))
(let-values ([(last-tail-res tpv ...)
(match-tail x fail-to)])
(values item-null ... tpv ...)))))))])
(let-values ([(ipv ... tpv ...)
(match-dotted x)])
final-body))))
final-pvar-lst
final-cata-defs
final-dotted-vars)))))]
[compile-item
(lambda (item exp nextp fail-k pvar-lst depth cata-fun cata-defs dotted-vars)
(syntax-case item (unquote ->)
[(unquote var)
(identifier? (syntax var))
(let ([new-exp (car (generate-temporaries (list exp)))])
(let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
(nextp new-exp (add-pat-var (syntax var) pvar-lst) cata-defs dotted-vars)])
(values (with-syntax ([x exp]
[nx new-exp]
[body next-tests]
[fail-to fail-k])
(syntax (if (pair? x)
(let ([nx (cdr x)]
[var (car x)])
body)
(fail-to))))
new-pvar-lst
new-cata-defs
new-dotted-vars)))]
[(unquote [cata -> cvar ...])
(let ([new-exp (car (generate-temporaries (list exp)))]
[ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
(let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
(nextp new-exp
(add-pat-var ctemp pvar-lst)
(add-cata-def depth
(syntax [cvar ...])
(syntax cata)
ctemp
cata-defs)
dotted-vars)])
(values (with-syntax ([x exp]
[nx new-exp]
[ct ctemp]
[body next-tests]
[fail-to fail-k])
(syntax (if (pair? x)
(let ([nx (cdr x)]
[ct (car x)])
body)
(fail-to))))
new-pvar-lst
new-cata-defs
new-dotted-vars)))]
[(unquote [cvar ...])
(let ([new-exp (car (generate-temporaries (list exp)))]
[ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
(if (not cata-fun)
(sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
stx
(syntax [cvar ...])))
(let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
(nextp new-exp
(add-pat-var ctemp pvar-lst)
(add-cata-def depth
(syntax [cvar ...])
cata-fun
ctemp
cata-defs)
dotted-vars)])
(values (with-syntax ([x exp]
[nx new-exp]
[ct ctemp]
[body next-tests]
[fail-to fail-k])
(syntax (if (pair? x)
(let ([nx (cdr x)]
[ct (car x)])
body)
(fail-to))))
new-pvar-lst
new-cata-defs
new-dotted-vars)))]
[(tag item ...)
(identifier? (syntax tag))
(let ([new-exp (car (generate-temporaries (list exp)))])
(let-values ([(after-tests after-pvar-lst after-cata-defs after-dotted-vars)
(compile-element-pat (syntax (tag item ...))
(with-syntax ([x exp])
(syntax (car x)))
(lambda (more-pvar-lst more-cata-defs more-dotted-vars)
(let-values ([(next-tests new-pvar-lst
new-cata-defs
new-dotted-vars)
(nextp new-exp
more-pvar-lst
more-cata-defs
more-dotted-vars)])
(values (with-syntax ([x exp]
[nx new-exp]
[body next-tests])
(syntax (let ([nx (cdr x)])
body)))
new-pvar-lst
new-cata-defs
new-dotted-vars)))
fail-k
pvar-lst
depth
cata-fun
cata-defs
dotted-vars)])
(values (with-syntax ([x exp]
[body after-tests]
[fail-to fail-k])
(syntax (if (pair? x)
body
(fail-to))))
after-pvar-lst
after-cata-defs
after-dotted-vars)))]
[(i ...)
(sxml-match-syntax-error "bad pattern syntax (not an element pattern)"
stx
(syntax (i ...)))]
[i
(identifier? (syntax i))
(sxml-match-syntax-error "bad pattern syntax (symbol not allowed in this context)"
stx
(syntax i))]
[literal
(literal? (syntax literal))
(let ([new-exp (car (generate-temporaries (list exp)))])
(let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
(nextp new-exp pvar-lst cata-defs dotted-vars)])
(values (with-syntax ([x exp]
[nx new-exp]
[body next-tests]
[fail-to fail-k])
(syntax (if (and (pair? x) (equal? literal (car x)))
(let ([nx (cdr x)])
body)
(fail-to))))
new-pvar-lst
new-cata-defs
new-dotted-vars)))]))])
(let ([fail-k (syntax failure)])
(syntax-case stx (unquote guard ->)
[(compile-clause ((unquote var) (guard gexp ...) action0 action ...)
exp
cata-fun
fail-exp)
(identifier? (syntax var))
(syntax (let ([var exp])
(if (and gexp ...)
(begin action0 action ...)
(fail-exp))))]
[(compile-clause ((unquote [cata -> cvar ...]) (guard gexp ...) action0 action ...)
exp
cata-fun
fail-exp)
(syntax (if (and gexp ...)
(let-values ([(cvar ...) (cata exp)])
(begin action0 action ...))
(fail-exp)))]
[(compile-clause ((unquote [cvar ...]) (guard gexp ...) action0 action ...)
exp
cata-fun
fail-exp)
(if (not (extract-cata-fun (syntax cata-fun)))
(sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
stx
(syntax [cvar ...]))
(syntax (if (and gexp ...)
(let-values ([(cvar ...) (cata-fun exp)])
(begin action0 action ...))
(fail-exp))))]
[(compile-clause ((unquote var) action0 action ...) exp cata-fun fail-exp)
(identifier? (syntax var))
(syntax (let ([var exp])
action0 action ...))]
[(compile-clause ((unquote [cata -> cvar ...]) action0 action ...) exp cata-fun fail-exp)
(syntax (let-values ([(cvar ...) (cata exp)])
action0 action ...))]
[(compile-clause ((unquote [cvar ...]) action0 action ...) exp cata-fun fail-exp)
(if (not (extract-cata-fun (syntax cata-fun)))
(sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
stx
(syntax [cvar ...]))
(syntax (let-values ([(cvar ...) (cata-fun exp)])
action0 action ...)))]
[(compile-clause ((lst . rst) (guard gexp ...) action0 action ...) exp cata-fun fail-exp)
(and (identifier? (syntax lst)) (eq? 'list (syntax-object->datum (syntax lst))))
(let-values ([(result pvar-lst cata-defs dotted-vars)
(compile-item-list (syntax rst)
(syntax exp)
(lambda (new-pvar-lst new-cata-defs new-dotted-vars)
(values
(with-syntax
([exp-body (process-cata-defs new-cata-defs
(process-output-action
(syntax (begin action0
action ...))
new-dotted-vars))]
[fail-to fail-k])
(syntax (if (and gexp ...) exp-body (fail-to))))
new-pvar-lst
new-cata-defs
new-dotted-vars))
fail-k
#t
'()
0
(extract-cata-fun (syntax cata-fun))
'()
'())])
(with-syntax ([fail-to fail-k]
[body result])
(syntax (let ([fail-to fail-exp])
(if (nodeset? exp)
body
(fail-to))))))]
[(compile-clause ((lst . rst) action0 action ...) exp cata-fun fail-exp)
(and (identifier? (syntax lst)) (eq? 'list (syntax-object->datum (syntax lst))))
(let-values ([(result pvar-lst cata-defs dotted-vars)
(compile-item-list (syntax rst)
(syntax exp)
(lambda (new-pvar-lst new-cata-defs new-dotted-vars)
(values (process-cata-defs new-cata-defs
(process-output-action
(syntax (begin action0
action ...))
new-dotted-vars))
new-pvar-lst
new-cata-defs
new-dotted-vars))
fail-k
#t
'()
0
(extract-cata-fun (syntax cata-fun))
'()
'())])
(with-syntax ([body result]
[fail-to fail-k])
(syntax (let ([fail-to fail-exp])
(if (nodeset? exp)
body
(fail-to))))))]
[(compile-clause ((fst . rst) (guard gexp ...) action0 action ...) exp cata-fun fail-exp)
(identifier? (syntax fst))
(let-values ([(result pvar-lst cata-defs dotted-vars)
(compile-element-pat (syntax (fst . rst))
(syntax exp)
(lambda (new-pvar-lst new-cata-defs new-dotted-vars)
(values
(with-syntax
([body (process-cata-defs new-cata-defs
(process-output-action
(syntax (begin action0
action ...))
new-dotted-vars))]
[fail-to fail-k])
(syntax (if (and gexp ...) body (fail-to))))
new-pvar-lst
new-cata-defs
new-dotted-vars))
fail-k
'()
0
(extract-cata-fun (syntax cata-fun))
'()
'())])
(with-syntax ([fail-to fail-k]
[body result])
(syntax (let ([fail-to fail-exp])
body))))]
[(compile-clause ((fst . rst) action0 action ...) exp cata-fun fail-exp)
(identifier? (syntax fst))
(let-values ([(result pvar-lst cata-defs dotted-vars)
(compile-element-pat (syntax (fst . rst))
(syntax exp)
(lambda (new-pvar-lst new-cata-defs new-dotted-vars)
(values (process-cata-defs new-cata-defs
(process-output-action
(syntax (begin action0
action ...))
new-dotted-vars))
new-pvar-lst
new-cata-defs
new-dotted-vars))
fail-k
'()
0
(extract-cata-fun (syntax cata-fun))
'()
'())])
(with-syntax ([fail-to fail-k]
[body result])
(syntax (let ([fail-to fail-exp])
body))))]
[(compile-clause ((i ...) (guard gexp ...) action0 action ...) exp cata-fun fail-exp)
(sxml-match-syntax-error "bad pattern syntax (not an element pattern)"
stx
(syntax (i ...)))]
[(compile-clause ((i ...) action0 action ...) exp cata-fun fail-exp)
(sxml-match-syntax-error "bad pattern syntax (not an element pattern)"
stx
(syntax (i ...)))]
[(compile-clause (pat (guard gexp ...) action0 action ...) exp cata-fun fail-exp)
(identifier? (syntax pat))
(sxml-match-syntax-error "bad pattern syntax (symbol not allowed in this context)"
stx
(syntax pat))]
[(compile-clause (pat action0 action ...) exp cata-fun fail-exp)
(identifier? (syntax pat))
(sxml-match-syntax-error "bad pattern syntax (symbol not allowed in this context)"
stx
(syntax pat))]
[(compile-clause (literal (guard gexp ...) action0 action ...) exp cata-fun fail-exp)
(literal? (syntax literal))
(syntax (if (and (equal? literal exp) (and gexp ...))
(begin action0 action ...)
(fail-exp)))]
[(compile-clause (literal action0 action ...) exp cata-fun fail-exp)
(literal? (syntax literal))
(syntax (if (equal? literal exp)
(begin action0 action ...)
(fail-exp)))])))))
(define-syntax sxml-match1
(syntax-rules ()
[(sxml-match1 exp cata-fun clause)
(compile-clause clause exp cata-fun
(lambda () (error 'sxml-match "no matching clause found")))]
[(sxml-match1 exp cata-fun clause0 clause ...)
(let/ec escape
(compile-clause clause0 exp cata-fun
(lambda () (escape (sxml-match1 exp cata-fun clause ...)))))]))
(define-syntax sxml-match
(syntax-rules ()
((sxml-match val clause0 clause ...)
(letrec ([cfun (lambda (exp)
(sxml-match1 exp cfun clause0 clause ...))])
(cfun val)))))
(define-syntax sxml-match-let1
(syntax-rules ()
[(sxml-match-let1 syntag synform () body0 body ...)
(let () body0 body ...)]
[(sxml-match-let1 syntag synform ([pat exp]) body0 body ...)
(compile-clause (pat (let () body0 body ...))
exp
#f
(lambda () (error 'syntag "could not match pattern ~s" 'pat)))]
[(sxml-match-let1 syntag synform ([pat0 exp0] [pat exp] ...) body0 body ...)
(compile-clause (pat0 (sxml-match-let1 syntag synform ([pat exp] ...) body0 body ...))
exp0
#f
(lambda () (error 'syntag "could not match pattern ~s" 'pat0)))]))
(define-syntax sxml-match-let-help
(lambda (stx)
(syntax-case stx ()
[(sxml-match-let-help syntag synform ([pat exp] ...) body0 body ...)
(with-syntax ([(temp-name ...) (generate-temporaries (syntax (exp ...)))])
(syntax (let ([temp-name exp] ...)
(sxml-match-let1 syntag synform ([pat temp-name] ...) body0 body ...))))])))
(define-syntax sxml-match-let
(lambda (stx)
(syntax-case stx ()
[(sxml-match-let ([pat exp] ...) body0 body ...)
(with-syntax ([synform stx])
(syntax (sxml-match-let-help sxml-match-let synform ([pat exp] ...) body0 body ...)))])))
(define-syntax sxml-match-let*
(lambda (stx)
(syntax-case stx ()
[(sxml-match-let* () body0 body ...)
(syntax (let () body0 body ...))]
[(sxml-match-let* ([pat0 exp0] [pat exp] ...) body0 body ...)
(with-syntax ([synform stx])
(syntax (sxml-match-let-help sxml-match-let* synform ([pat0 exp0])
(sxml-match-let* ([pat exp] ...)
body0 body ...))))])))
)
![[logo]](/logo.png){kind=logo}