* module/Makefile.am (LIB_SOURCES): Add `sxml/match.scm'.
(NOCOMP_SOURCES): Add `sxml/sxml-match.ss'.
* module/sxml/match.scm, module/sxml/sxml-match.ss: New files.
* test-suite/Makefile.am (SCM_TESTS): Add `tests/sxml.match.test'.
(EXTRA_DIST): Add `tests/sxml-match-tests.ss'.
* test-suite/tests/sxml-match-tests.ss,
test-suite/tests/sxml.match.test: New files.
* doc/ref/guile.texi (Guile Modules): Include `sxml-match.texi'.
* doc/ref/sxml-match.texi: New file.
* doc/ref/Makefile.am (guile_TEXINFOS): Add `sxml-match.texi'.
posix.texi \
expect.texi \
scsh.texi \
+ sxml-match.texi \
scheme-scripts.texi \
api-overview.texi \
api-discdepr.texi \
* Streams:: Sequences of values.
* Buffered Input:: Ports made from a reader function.
* Expect:: Controlling interactive programs with Guile.
+* sxml-match:: Pattern matching of SXML.
* The Scheme shell (scsh):: Using scsh interfaces in Guile.
* Tracing:: Tracing program execution.
@end menu
@include repl-modules.texi
@include misc-modules.texi
@include expect.texi
+
+@c XXX: Would be nicer if it were close to the (sxml simple) documentation.
+@include sxml-match.texi
+
@include scsh.texi
@include scheme-debugging.texi
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 2010 Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+@c
+@c Based on the documentation at
+@c <http://planet.plt-scheme.org/package-source/jim/sxml-match.plt/1/1/doc.txt>,
+@c copyright 2005 Jim Bender, and released under the MIT/X11 license (like the
+@c rest of `sxml-match'.)
+@c
+@c Converted to Texinfo and modified by Ludovic Courtès, 2010.
+
+@node sxml-match
+@section @code{sxml-match}: Pattern Matching of SXML
+
+@cindex pattern matching (SXML)
+@cindex SXML pattern matching
+
+The @code{(sxml match)} module provides syntactic forms for pattern matching of
+SXML trees, in a ``by example'' style reminiscent of the pattern matching of the
+@code{syntax-rules} and @code{syntax-case} macro systems. @xref{sxml simple,
+the @code{(sxml simple)} module}, for more information on SXML.
+
+The following example@footnote{This example is taken from a paper by
+Krishnamurthi et al. Their paper was the first to show the usefulness of the
+@code{syntax-rules} style of pattern matching for transformation of XML, though
+the language described, XT3D, is an XML language.} provides a brief
+illustration, transforming a music album catalog language into HTML.
+
+@lisp
+(define (album->html x)
+ (sxml-match x
+ [(album (@ (title ,t)) (catalog (num ,n) (fmt ,f)) ...)
+ `(ul (li ,t)
+ (li (b ,n) (i ,f)) ...)]))
+@end lisp
+
+Three macros are provided: @code{sxml-match}, @code{sxml-match-let}, and
+@code{sxml-match-let*}.
+
+Compared to a standard s-expression pattern matcher, @code{sxml-match} provides
+the following benefits:
+
+@itemize
+@item
+matching of SXML elements does not depend on any degree of normalization of the
+SXML;
+@item
+matching of SXML attributes (within an element) is under-ordered; the order of
+the attributes specified within the pattern need not match the ordering with the
+element being matched;
+@item
+all attributes specified in the pattern must be present in the element being
+matched; in the spirit that XML is 'extensible', the element being matched may
+include additional attributes not specified in the pattern.
+@end itemize
+
+The present module is a descendant of WebIt!, and was inspired by an
+s-expression pattern matcher developed by Erik Hilsdale, Dan Friedman, and Kent
+Dybvig at Indiana University.
+
+@unnumberedsubsec Syntax
+
+@code{sxml-match} provides @code{case}-like form for pattern matching of XML
+nodes.
+
+@deffn {Scheme Syntax} sxml-match input-expression clause ...
+Match @var{input-expression}, an SXML tree, according to the given @var{clause}s
+(one or more), each consisting of a pattern and one or more expressions to be
+evaluated if the pattern match succeeds. Optionally, each @var{clause} within
+@code{sxml-match} may include a @dfn{guard expression}.
+@end deffn
+
+The pattern notation is based on that of Scheme's @code{syntax-rules} and
+@code{syntax-case} macro systems. The grammar for the @code{sxml-match} syntax
+is given below:
+
+@verbatim
+match-form ::= (sxml-match input-expression
+ clause+)
+
+clause ::= [node-pattern action-expression+]
+ | [node-pattern (guard expression*) action-expression+]
+
+node-pattern ::= literal-pattern
+ | pat-var-or-cata
+ | element-pattern
+ | list-pattern
+
+literal-pattern ::= string
+ | character
+ | number
+ | #t
+ | #f
+
+attr-list-pattern ::= (@ attribute-pattern*)
+ | (@ attribute-pattern* . pat-var-or-cata)
+
+attribute-pattern ::= (tag-symbol attr-val-pattern)
+
+attr-val-pattern ::= literal-pattern
+ | pat-var-or-cata
+ | (pat-var-or-cata default-value-expr)
+
+element-pattern ::= (tag-symbol attr-list-pattern?)
+ | (tag-symbol attr-list-pattern? nodeset-pattern)
+ | (tag-symbol attr-list-pattern?
+ nodeset-pattern? . pat-var-or-cata)
+
+list-pattern ::= (list nodeset-pattern)
+ | (list nodeset-pattern? . pat-var-or-cata)
+ | (list)
+
+nodeset-pattern ::= node-pattern
+ | node-pattern ...
+ | node-pattern nodeset-pattern
+ | node-pattern ... nodeset-pattern
+
+pat-var-or-cata ::= (unquote var-symbol)
+ | (unquote [var-symbol*])
+ | (unquote [cata-expression -> var-symbol*])
+@end verbatim
+
+Within a list or element body pattern, ellipses may appear only once, but may be
+followed by zero or more node patterns.
+
+Guard expressions cannot refer to the return values of catamorphisms.
+
+Ellipses in the output expressions must appear only in an expression context;
+ellipses are not allowed in a syntactic form.
+
+The sections below illustrate specific aspects of the @code{sxml-match} pattern
+matcher.
+
+@unnumberedsubsec Matching XML Elements
+
+The example below illustrates the pattern matching of an XML element:
+
+@lisp
+(sxml-match '(e (@ (i 1)) 3 4 5)
+ [(e (@ (i ,d)) ,a ,b ,c) (list d a b c)]
+ [,otherwise #f])
+@end lisp
+
+Each clause in @code{sxml-match} contains two parts: a pattern and one or more
+expressions which are evaluated if the pattern is successfully match. The
+example above matches an element @code{e} with an attribute @code{i} and three
+children.
+
+Pattern variables are must be ``unquoted'' in the pattern. The above expression
+binds @var{d} to @code{1}, @var{a} to @code{3}, @var{b} to @code{4}, and @var{c}
+to @code{5}.
+
+@unnumberedsubsec Ellipses in Patterns
+
+As in @code{syntax-rules}, ellipses may be used to specify a repeated pattern.
+Note that the pattern @code{item ...} specifies zero-or-more matches of the
+pattern @code{item}.
+
+The use of ellipses in a pattern is illustrated in the code fragment below,
+where nested ellipses are used to match the children of repeated instances of an
+@code{a} element, within an element @code{d}.
+
+@lisp
+(define x '(d (a 1 2 3) (a 4 5) (a 6 7 8) (a 9 10)))
+
+(sxml-match x
+ [(d (a ,b ...) ...)
+ (list (list b ...) ...)])
+@end lisp
+
+The above expression returns a value of @code{((1 2 3) (4 5) (6 7 8) (9 10))}.
+
+@unnumberedsubsec Ellipses in Quasiquote'd Output
+
+Within the body of an @code{sxml-match} form, a slightly extended version of
+quasiquote is provided, which allows the use of ellipses. This is illustrated
+in the example below.
+
+@lisp
+(sxml-match '(e 3 4 5 6 7)
+ [(e ,i ... 6 7) `("start" ,(list 'wrap i) ... "end")]
+ [,otherwise #f])
+@end lisp
+
+The general pattern is that @code{`(something ,i ...)} is rewritten as
+@code{`(something ,@@i)}.
+
+@unnumberedsubsec Matching Nodesets
+
+A nodeset pattern is designated by a list in the pattern, beginning the
+identifier list. The example below illustrates matching a nodeset.
+
+@lisp
+(sxml-match '("i" "j" "k" "l" "m")
+ [(list ,a ,b ,c ,d ,e)
+ `((p ,a) (p ,b) (p ,c) (p ,d) (p ,e))])
+@end lisp
+
+This example wraps each nodeset item in an HTML paragraph element. This example
+can be rewritten and simplified through using ellipsis:
+
+@lisp
+(sxml-match '("i" "j" "k" "l" "m")
+ [(list ,i ...)
+ `((p ,i) ...)])
+@end lisp
+
+This version will match nodesets of any length, and wrap each item in the
+nodeset in an HTML paragraph element.
+
+@unnumberedsubsec Matching the ``Rest'' of a Nodeset
+
+Matching the ``rest'' of a nodeset is achieved by using a @code{. rest)} pattern
+at the end of an element or nodeset pattern.
+
+This is illustrated in the example below:
+
+@lisp
+(sxml-match '(e 3 (f 4 5 6) 7)
+ [(e ,a (f . ,y) ,d)
+ (list a y d)])
+@end lisp
+
+The above expression returns @code{(3 (4 5 6) 7)}.
+
+@unnumberedsubsec Matching the Unmatched Attributes
+
+Sometimes it is useful to bind a list of attributes present in the element being
+matched, but which do not appear in the pattern. This is achieved by using a
+@code{. rest)} pattern at the end of the attribute list pattern. This is
+illustrated in the example below:
+
+@lisp
+(sxml-match '(a (@ (z 1) (y 2) (x 3)) 4 5 6)
+ [(a (@ (y ,www) . ,qqq) ,t ,u ,v)
+ (list www qqq t u v)])
+@end lisp
+
+The above expression matches the attribute @code{y} and binds a list of the
+remaining attributes to the variable @var{qqq}. The result of the above
+expression is @code{(2 ((z 1) (x 3)) 4 5 6)}.
+
+This type of pattern also allows the binding of all attributes:
+
+@lisp
+(sxml-match '(a (@ (z 1) (y 2) (x 3)))
+ [(a (@ . ,qqq))
+ qqq])
+@end lisp
+
+@unnumberedsubsec Default Values in Attribute Patterns
+
+It is possible to specify a default value for an attribute which is used if the
+attribute is not present in the element being matched. This is illustrated in
+the following example:
+
+@lisp
+(sxml-match '(e 3 4 5)
+ [(e (@ (z (,d 1))) ,a ,b ,c) (list d a b c)])
+@end lisp
+
+The value @code{1} is used when the attribute @code{z} is absent from the
+element @code{e}.
+
+@unnumberedsubsec Guards in Patterns
+
+Guards may be added to a pattern clause via the @code{guard} keyword. A guard
+expression may include zero or more expressions which are evaluated only if the
+pattern is matched. The body of the clause is only evaluated if the guard
+expressions evaluate to @code{#t}.
+
+The use of guard expressions is illustrated below:
+
+@lisp
+(sxml-match '(a 2 3)
+ ((a ,n) (guard (number? n)) n)
+ ((a ,m ,n) (guard (number? m) (number? n)) (+ m n)))
+@end lisp
+
+@unnumberedsubsec Catamorphisms
+
+The example below illustrates the use of explicit recursion within an
+@code{sxml-match} form. This example implements a simple calculator for the
+basic arithmetic operations, which are represented by the XML elements
+@code{plus}, @code{minus}, @code{times}, and @code{div}.
+
+@lisp
+(define simple-eval
+ (lambda (x)
+ (sxml-match x
+ [,i (guard (integer? i)) i]
+ [(plus ,x ,y) (+ (simple-eval x) (simple-eval y))]
+ [(times ,x ,y) (* (simple-eval x) (simple-eval y))]
+ [(minus ,x ,y) (- (simple-eval x) (simple-eval y))]
+ [(div ,x ,y) (/ (simple-eval x) (simple-eval y))]
+ [,otherwise (error "simple-eval: invalid expression" x)])))
+@end lisp
+
+Using the catamorphism feature of @code{sxml-match}, a more concise version of
+@code{simple-eval} can be written. The pattern @code{,[x]} recusively invokes
+the pattern matcher on the value bound in this position.
+
+@lisp
+(define simple-eval
+ (lambda (x)
+ (sxml-match x
+ [,i (guard (integer? i)) i]
+ [(plus ,[x] ,[y]) (+ x y)]
+ [(times ,[x] ,[y]) (* x y)]
+ [(minus ,[x] ,[y]) (- x y)]
+ [(div ,[x] ,[y]) (/ x y)]
+ [,otherwise (error "simple-eval: invalid expression" x)])))
+@end lisp
+
+@unnumberedsubsec Named-Catamorphisms
+
+It is also possible to explicitly name the operator in the ``cata'' position.
+Where @code{,[id*]} recurs to the top of the current @code{sxml-match},
+@code{,[cata -> id*]} recurs to @code{cata}. @code{cata} must evaluate to a
+procedure which takes one argument, and returns as many values as there are
+identifiers following @code{->}.
+
+Named catamorphism patterns allow processing to be split into multiple, mutually
+recursive procedures. This is illustrated in the example below: a
+transformation that formats a "TV Guide" into HTML.
+
+@lisp
+(define (tv-guide->html g)
+ (define (cast-list cl)
+ (sxml-match cl
+ [(CastList (CastMember (Character (Name ,ch)) (Actor (Name ,a))) ...)
+ `(div (ul (li ,ch ": " ,a) ...))]))
+ (define (prog p)
+ (sxml-match p
+ [(Program (Start ,start-time) (Duration ,dur) (Series ,series-title)
+ (Description ,desc ...))
+ `(div (p ,start-time
+ (br) ,series-title
+ (br) ,desc ...))]
+ [(Program (Start ,start-time) (Duration ,dur) (Series ,series-title)
+ (Description ,desc ...)
+ ,[cast-list -> cl])
+ `(div (p ,start-time
+ (br) ,series-title
+ (br) ,desc ...)
+ ,cl)]))
+ (sxml-match g
+ [(TVGuide (@ (start ,start-date)
+ (end ,end-date))
+ (Channel (Name ,nm) ,[prog -> p] ...) ...)
+ `(html (head (title "TV Guide"))
+ (body (h1 "TV Guide")
+ (div (h2 ,nm) ,p ...) ...))]))
+@end lisp
+
+@unnumberedsubsec @code{sxml-match-let} and @code{sxml-match-let*}
+
+@deffn {Scheme Syntax} sxml-match-let ((pat expr) ...) expression0 expression ...)
+@deffnx {Scheme Syntax} sxml-match-let* ((pat expr) ...) expression0 expression ...)
+These forms generalize the @code{let} and @code{let*} forms of Scheme to allow
+an XML pattern in the binding position, rather than a simple variable.
+@end deffn
+
+For example, the expression below:
+
+@lisp
+(sxml-match-let ([(a ,i ,j) '(a 1 2)])
+ (+ i j))
+@end lisp
+
+binds the variables @var{i} and @var{j} to @code{1} and @code{2} in the XML
+value given.
+
+@c Local Variables:
+@c coding: utf-8
+@c End:
statprof.scm \
sxml/apply-templates.scm \
sxml/fold.scm \
+ sxml/match.scm \
sxml/simple.scm \
sxml/ssax/input-parse.scm \
sxml/ssax.scm \
ice-9/debugging/trace.scm \
ice-9/debugging/traps.scm \
ice-9/debugging/trc.scm \
+ sxml/sxml-match.ss \
sxml/upstream/SSAX.scm \
sxml/upstream/SXML-tree-trans.scm \
sxml/upstream/SXPath-old.scm \
--- /dev/null
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU Lesser General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (sxml match)
+ #:export (sxml-match
+ sxml-match-let
+ sxml-match-let*)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11))
+
+\f
+;;; Commentary:
+;;;
+;;; This module provides an SXML pattern matcher, written by Jim Bender. This
+;;; allows application code to match on SXML nodes and attributes without having
+;;; to deal with the details of s-expression matching, without worrying about
+;;; the order of attributes, etc.
+;;;
+;;; It is fully documented in the Guile Reference Manual.
+;;;
+;;; Code:
+
+
+\f
+;;;
+;;; PLT compatibility layer.
+;;;
+
+(define-syntax syntax-object->datum
+ (syntax-rules ()
+ ((_ stx)
+ (syntax->datum stx))))
+
+(define-syntax void
+ (syntax-rules ()
+ ((_) *unspecified*)))
+
+(define-syntax call/ec
+ ;; aka. `call-with-escape-continuation'
+ (syntax-rules ()
+ ((_ proc)
+ (let ((prompt (make-prompt-tag)))
+ (call-with-prompt prompt
+ (lambda ()
+ (proc (lambda args
+ (apply abort-to-prompt
+ prompt args))))
+ (lambda (_ . args)
+ (apply values args)))))))
+
+(define-syntax let/ec
+ (syntax-rules ()
+ ((_ cont body ...)
+ (call/ec (lambda (cont) body ...)))))
+
+(define (raise-syntax-error x msg obj sub)
+ (throw 'sxml-match-error x msg obj sub))
+
+(define-syntax module
+ (syntax-rules (provide require)
+ ((_ name lang (provide p_ ...) (require r_ ...)
+ body ...)
+ (begin body ...))))
+
+\f
+;;;
+;;; Include upstream source file.
+;;;
+
+;; This file was taken unmodified from
+;; <http://planet.plt-scheme.org/package-source/jim/sxml-match.plt/1/1/> on
+;; 2010-05-24. It was written by Jim Bender <benderjg2@aol.com> and released
+;; under the MIT/X11 license
+;; <http://www.gnu.org/licenses/license-list.html#X11License>.
+
+(include-from-path "sxml/sxml-match.ss")
+
+;;; match.scm ends here
--- /dev/null
+;; Library: sxml-match
+;; Author: Jim Bender
+;; Version: 1.1, version for PLT Scheme
+;;
+;; Copyright 2005-9, Jim Bender
+;; sxml-match is released under the MIT License
+;;
+(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)])
+ ; more here: check for duplicate pat-vars, cata-defs
+ (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 ->)
+ ; normal pattern var
+ [(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)))]
+ ; named catamorphism
+ [(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)))]
+ ; basic catamorphism
+ [(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)])
+ ; test that we are not at the end of an item-list, BEFORE
+ ; entering tests for the element pattern (against the 'car' of the item-list)
+ (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 ...))))])))
+
+ )
+
tests/strings.test \
tests/structs.test \
tests/sxml.fold.test \
+ tests/sxml.match.test \
tests/sxml.simple.test \
tests/sxml.ssax.test \
tests/sxml.transform.test \
TESTS = $(LALR_TESTS)
TESTS_ENVIRONMENT = $(top_builddir)/meta/guile --no-autocompile
-EXTRA_DIST += $(LALR_EXTRA) $(LALR_TESTS)
+EXTRA_DIST += $(LALR_EXTRA) $(LALR_TESTS) tests/sxml-match-tests.ss
--- /dev/null
+(define-syntax compile-match
+ (syntax-rules ()
+ [(compile-match pat action0 action ...)
+ (lambda (x)
+ (sxml-match x [pat action0 action ...]))]))
+
+(run-test "basic match of a top-level pattern var"
+ (sxml-match '(e 3 4 5)
+ [,y (list "matched" y)])
+ '("matched" (e 3 4 5)))
+(run-test "match of simple element contents with pattern vars"
+ ((compile-match (e ,a ,b ,c) (list a b c)) '(e 3 4 5))
+ '(3 4 5))
+(run-test "match a literal pattern within a element pattern"
+ ((compile-match (e ,a "abc" ,c) (list a c)) '(e 3 "abc" 5))
+ '(3 5))
+(run-test "match an empty element"
+ ((compile-match (e) "match") '(e))
+ "match")
+(run-test "match a nested element"
+ ((compile-match (e ,a (f ,b ,c) ,d) (list a b c d)) '(e 3 (f 4 5) 6))
+ '(3 4 5 6))
+(run-test "match a dot-rest pattern within a nested element"
+ ((compile-match (e ,a (f . ,y) ,d) (list a y d)) '(e 3 (f 4 5) 6))
+ '(3 (4 5) 6))
+(run-test "match a basic list pattern"
+ ((compile-match (list ,a ,b ,c ,d ,e) (list a b c d e)) '("i" "j" "k" "l" "m"))
+ '("i" "j" "k" "l" "m"))
+(run-test "match a list pattern with a dot-rest pattern"
+ ((compile-match (list ,a ,b ,c . ,y) (list a b c y)) '("i" "j" "k" "l" "m"))
+ '("i" "j" "k" ("l" "m")))
+(run-test "basic test of a multi-clause sxml-match"
+ (sxml-match '(a 1 2 3)
+ ((a ,n) n)
+ ((a ,m ,n) (+ m n))
+ ((a ,m ,n ,o) (list "matched" (list m n o))))
+ '("matched" (1 2 3)))
+(run-test "basic test of a sxml-match-let"
+ (sxml-match-let ([(a ,i ,j) '(a 1 2)])
+ (+ i j))
+ 3)
+(run-test "basic test of a sxml-match-let*"
+ (sxml-match-let* ([(a ,k) '(a (b 1 2))]
+ [(b ,i ,j) k])
+ (list i j))
+ '(1 2))
+(run-test "match of top-level literal string pattern"
+ ((compile-match "abc" "match") "abc")
+ "match")
+(run-test "match of top-level literal number pattern"
+ ((compile-match 77 "match") 77)
+ "match")
+(run-test "test of multi-expression guard in pattern"
+ (sxml-match '(a 1 2 3)
+ ((a ,n) n)
+ ((a ,m ,n) (+ m n))
+ ((a ,m ,n ,o) (guard (number? m) (number? n) (number? o)) (list "guarded-matched" (list m n o))))
+ '("guarded-matched" (1 2 3)))
+(run-test "basic test of multiple action items in match clause"
+ ((compile-match 77 (display "") "match") 77)
+ "match")
+
+(define simple-eval
+ (lambda (x)
+ (sxml-match x
+ [,i (guard (integer? i)) i]
+ [(+ ,x ,y) (+ (simple-eval x) (simple-eval y))]
+ [(* ,x ,y) (* (simple-eval x) (simple-eval y))]
+ [(- ,x ,y) (- (simple-eval x) (simple-eval y))]
+ [(/ ,x ,y) (/ (simple-eval x) (simple-eval y))]
+ [,otherwise (error "simple-eval: invalid expression" x)])))
+
+(run-test "basic test of explicit recursion in match clauses"
+ (simple-eval '(* (+ 7 3) (- 7 3)))
+ 40)
+
+(define simple-eval2
+ (lambda (x)
+ (sxml-match x
+ [,i (guard (integer? i)) i]
+ [(+ ,[x] ,[y]) (+ x y)]
+ [(* ,[x] ,[y]) (* x y)]
+ [(- ,[x] ,[y]) (- x y)]
+ [(/ ,[x] ,[y]) (/ x y)]
+ [,otherwise (error "simple-eval: invalid expression" x)])))
+
+(run-test "basic test of anonymous catas"
+ (simple-eval2 '(* (+ 7 3) (- 7 3)))
+ 40)
+
+(define simple-eval3
+ (lambda (x)
+ (sxml-match x
+ [,i (guard (integer? i)) i]
+ [(+ ,[simple-eval3 -> x] ,[simple-eval3 -> y]) (+ x y)]
+ [(* ,[simple-eval3 -> x] ,[simple-eval3 -> y]) (* x y)]
+ [(- ,[simple-eval3 -> x] ,[simple-eval3 -> y]) (- x y)]
+ [(/ ,[simple-eval3 -> x] ,[simple-eval3 -> y]) (/ x y)]
+ [,otherwise (error "simple-eval: invalid expression" x)])))
+
+(run-test "test of named catas"
+ (simple-eval3 '(* (+ 7 3) (- 7 3)))
+ 40)
+
+; need a test case for cata on a ". rest)" pattern
+
+(run-test "successful test of attribute matching: pat-var in value position"
+ (sxml-match '(e (@ (z 1)) 3 4 5)
+ [(e (@ (z ,d)) ,a ,b ,c) (list d a b c)]
+ [,otherwise #f])
+ '(1 3 4 5))
+
+(run-test "failing test of attribute matching: pat-var in value position"
+ (sxml-match '(e (@ (a 1)) 3 4 5)
+ [(e (@ (z ,d)) ,a ,b ,c) (list d a b c)]
+ [,otherwise #f])
+ #f)
+
+(run-test "test of attribute matching: literal in value position"
+ ((compile-match (e (@ (z 1)) ,a ,b ,c) (list a b c)) '(e (@ (z 1)) 3 4 5))
+ '(3 4 5))
+
+(run-test "test of attribute matching: default-value spec in value position"
+ ((compile-match (e (@ (z (,d 1))) ,a ,b ,c) (list d a b c)) '(e 3 4 5))
+ '(1 3 4 5))
+
+(run-test "test of attribute matching: multiple attributes in pattern"
+ ((compile-match (e (@ (y ,e) (z ,d)) ,a ,b ,c) (list e d a b c)) '(e (@ (z 1) (y 2)) 3 4 5))
+ '(2 1 3 4 5))
+
+(run-test "basic test of ellipses in pattern; no ellipses in output"
+ ((compile-match (e ,i ...) i) '(e 3 4 5))
+ '(3 4 5))
+
+(run-test "test of non-null tail pattern following ellipses"
+ ((compile-match (e ,i ... ,a ,b) i) '(e 3 4 5 6 7))
+ '(3 4 5 ))
+
+(define simple-eval4
+ (lambda (x)
+ (sxml-match x
+ [,i (guard (integer? i)) i]
+ [(+ ,[x*] ...) (apply + x*)]
+ [(* ,[x*] ...) (apply * x*)]
+ [(- ,[x] ,[y]) (- x y)]
+ [(/ ,[x] ,[y]) (/ x y)]
+ [,otherwise (error "simple-eval: invalid expression" x)])))
+
+(run-test "test of catas with ellipses in pattern"
+ (simple-eval4 '(* (+ 7 3) (- 7 3)))
+ 40)
+
+(run-test "simple test of ellipses in pattern and output"
+ ((compile-match (e ,i ...) ((lambda rst (cons 'f rst)) i ...)) '(e 3 4 5))
+ '(f 3 4 5))
+
+(define simple-eval5
+ (lambda (x)
+ (sxml-match x
+ [,i (guard (integer? i)) i]
+ [(+ ,[x*] ...) (+ x* ...)]
+ [(* ,[x*] ...) (* x* ...)]
+ [(- ,[x] ,[y]) (- x y)]
+ [(/ ,[x] ,[y]) (/ x y)]
+ [,otherwise (error "simple-eval: invalid expression" x)])))
+
+(run-test "test of catas with ellipses in pattern and output"
+ (simple-eval5 '(* (+ 7 3) (- 7 3)))
+ 40)
+
+(run-test "test of nested dots in pattern and output"
+ ((lambda (x)
+ (sxml-match x
+ [(d (a ,b ...) ...)
+ (list (list b ...) ...)]))
+ '(d (a 1 2 3) (a 4 5) (a 6 7 8) (a 9 10)))
+ '((1 2 3) (4 5) (6 7 8) (9 10)))
+
+(run-test "test successful tail pattern match (after ellipses)"
+ (sxml-match '(e 3 4 5 6 7) ((e ,i ... 6 7) #t) (,otherwise #f))
+ #t)
+
+(run-test "test failing tail pattern match (after ellipses), too few items"
+ (sxml-match '(e 3 4 5 6) ((e ,i ... 6 7) #t) (,otherwise #f))
+ #f)
+
+(run-test "test failing tail pattern match (after ellipses), too many items"
+ (sxml-match '(e 3 4 5 6 7 8) ((e ,i ... 6 7) #t) (,otherwise #f))
+ #f)
+
+(run-test "test failing tail pattern match (after ellipses), wrong items"
+ (sxml-match '(e 3 4 5 7 8) ((e ,i ... 6 7) #t) (,otherwise #f))
+ #f)
+
+(run-test "test of ellipses in output quasiquote"
+ (sxml-match '(e 3 4 5 6 7)
+ [(e ,i ... 6 7) `("start" ,i ... "end")]
+ [,otherwise #f])
+ '("start" 3 4 5 "end"))
+
+(run-test "test of ellipses in output quasiquote, with more complex unquote expression"
+ (sxml-match '(e 3 4 5 6 7)
+ [(e ,i ... 6 7) `("start" ,(list 'wrap i) ... "end")]
+ [,otherwise #f])
+ '("start" (wrap 3) (wrap 4) (wrap 5) "end"))
+
+(run-test "test of a quasiquote expr within the dotted unquote expression"
+ (sxml-match '(e 3 4 5 6 7)
+ [(e ,i ... 6 7) `("start" ,`(wrap ,i) ... "end")]
+ [,otherwise #f])
+ '("start" (wrap 3) (wrap 4) (wrap 5) "end"))
+
+(define xyzpq '(d (a 1 2 3) (a 4 5) (a 6 7 8) (a 9 10)))
+
+(run-test "quasiquote tests"
+ (sxml-match xyzpq
+ [(d (a ,b ...) ...)
+ `(,`(,b ...) ...)])
+ '((1 2 3) (4 5) (6 7 8) (9 10)))
+
+(run-test "quasiquote tests"
+ (sxml-match xyzpq
+ [(d (a ,b ...) ...)
+ (list (list b ...) ...)])
+ '((1 2 3) (4 5) (6 7 8) (9 10)))
+
+(run-test "quasiquote tests"
+ (sxml-match xyzpq
+ [(d (a ,b ...) ...)
+ `(xx ,`(y ,b ...) ...)])
+ '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))
+
+(run-test "quasiquote tests"
+ (sxml-match xyzpq
+ [(d (a ,b ...) ...)
+ `(xx ,@(map (lambda (i) `(y ,@i)) b))])
+ '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))
+
+(run-test "quasiquote tests"
+ (sxml-match xyzpq
+ [(d (a ,b ...) ...)
+ `(xx ,(cons 'y b) ...)])
+ '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))
+
+(run-test "quasiquote tests"
+ (sxml-match xyzpq
+ [(d (a ,b ...) ...)
+ `(xx ,`(y ,b ...) ...)])
+ '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))
+
+(run-test "quasiquote tests"
+ (sxml-match xyzpq
+ [(d (a ,b ...) ...)
+ `(xx ,`(y ,@b) ...)])
+ '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))
+
+(run-test "quasiquote tests"
+ (sxml-match xyzpq
+ [(d (a ,b ...) ...)
+ `((,b ...) ...)])
+ '((1 2 3) (4 5) (6 7 8) (9 10)))
+
+(run-test "quasiquote tests"
+ (sxml-match xyzpq
+ [(d (a ,b ...) ...)
+ `(xx (y ,b ...) ...)])
+ '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))
+
+(define (prog-trans p)
+ (sxml-match p
+ [(Program (Start ,start-time) (Duration ,dur) (Series ,series-title)
+ (Description . ,desc)
+ ,cl)
+ `(div (p ,start-time
+ (br) ,series-title
+ (br) ,desc)
+ ,cl)]
+ [(Program (Start ,start-time) (Duration ,dur) (Series ,series-title)
+ (Description . ,desc))
+ `(div (p ,start-time
+ (br) ,series-title
+ (br) ,desc))]
+ [(Program (Start ,start-time) (Duration ,dur) (Series ,series-title))
+ `(div (p ,start-time
+ (br) ,series-title))]))
+
+(run-test "test for shrinking-order list of pattern clauses"
+ (prog-trans '(Program (Start "2001-07-05T20:00:00") (Duration "PT1H") (Series "HomeFront")))
+ '(div (p "2001-07-05T20:00:00" (br) "HomeFront")))
+
+(run-test "test binding of unmatched attributes"
+ (sxml-match '(a (@ (z 1) (y 2) (x 3)) 4 5 6)
+ [(a (@ (y ,www) . ,qqq) ,t ...)
+ (list www qqq t ...)])
+ '(2 ((z 1) (x 3)) 4 5 6))
+
+(run-test "test binding all attributes"
+ (sxml-match '(a (@ (z 1) (y 2) (x 3)) 4 5 6)
+ [(a (@ . ,qqq) ,t ...)
+ (list qqq t ...)])
+ '(((z 1) (y 2) (x 3)) 4 5 6))
--- /dev/null
+;;;; sxml.simple.test --- (sxml simple) -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-sxml-match)
+ #:use-module (test-suite lib)
+ #:use-module (sxml match))
+
+(define-syntax run-test
+ (syntax-rules ()
+ ((_ desc test expected-result)
+ (pass-if desc (equal? test expected-result)))))
+
+\f
+;;;
+;;; Include upstream source file.
+;;;
+
+;; This file was taken unmodified from
+;; <http://planet.plt-scheme.org/package-source/jim/sxml-match.plt/1/1/> on
+;; 2010-05-24. It was written by Jim Bender <benderjg2@aol.com> and released
+;; under the MIT/X11 license
+;; <http://www.gnu.org/licenses/license-list.html#X11License>.
+;;
+;; It was modified to remove the `#lang' and `require' forms as well as the
+;; `run-test' macro, replaced by the one above.
+;;
+;; FIXME: The `xyzpq' variable in there is originally named `x' but using that
+;; name triggers a psyntax "identifier out of context" error.
+
+(include-from-path "test-suite/tests/sxml-match-tests.ss")
HCoop / bpt / guile.git / commitdiff