From: Ludovic Courtès Date: Mon, 24 May 2010 21:13:16 +0000 (+0200) Subject: Add (sxml match). X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/400a5dcb8b3bb042d8106f0aca69aecc6fd0628c Add (sxml match). * 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'. --- diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 60146a3a9..feadec607 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -58,6 +58,7 @@ guile_TEXINFOS = preface.texi \ posix.texi \ expect.texi \ scsh.texi \ + sxml-match.texi \ scheme-scripts.texi \ api-overview.texi \ api-discdepr.texi \ diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 27d6c7b7f..32cf1d64d 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -359,6 +359,7 @@ available through both Scheme and C interfaces. * 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 @@ -370,6 +371,10 @@ available through both Scheme and C interfaces. @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 diff --git a/doc/ref/sxml-match.texi b/doc/ref/sxml-match.texi new file mode 100644 index 000000000..58c2d8cb3 --- /dev/null +++ b/doc/ref/sxml-match.texi @@ -0,0 +1,377 @@ +@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 , +@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: diff --git a/module/Makefile.am b/module/Makefile.am index 92c0e5837..4ea899715 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -321,6 +321,7 @@ LIB_SOURCES = \ statprof.scm \ sxml/apply-templates.scm \ sxml/fold.scm \ + sxml/match.scm \ sxml/simple.scm \ sxml/ssax/input-parse.scm \ sxml/ssax.scm \ @@ -354,6 +355,7 @@ NOCOMP_SOURCES = \ 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 \ diff --git a/module/sxml/match.scm b/module/sxml/match.scm new file mode 100644 index 000000000..5b21deee8 --- /dev/null +++ b/module/sxml/match.scm @@ -0,0 +1,92 @@ +;;; -*- 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 . + +(define-module (sxml match) + #:export (sxml-match + sxml-match-let + sxml-match-let*) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11)) + + +;;; 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: + + + +;;; +;;; 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 ...)))) + + +;;; +;;; Include upstream source file. +;;; + +;; This file was taken unmodified from +;; on +;; 2010-05-24. It was written by Jim Bender and released +;; under the MIT/X11 license +;; . + +(include-from-path "sxml/sxml-match.ss") + +;;; match.scm ends here diff --git a/module/sxml/sxml-match.ss b/module/sxml/sxml-match.ss new file mode 100644 index 000000000..b13971858 --- /dev/null +++ b/module/sxml/sxml-match.ss @@ -0,0 +1,1178 @@ +;; 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 ...))))]))) + + ) + diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 51870e6e2..2c1f2293d 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -121,6 +121,7 @@ SCM_TESTS = tests/00-initial-env.test \ 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 \ @@ -187,4 +188,4 @@ LALR_EXTRA += \ 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 diff --git a/test-suite/tests/sxml-match-tests.ss b/test-suite/tests/sxml-match-tests.ss new file mode 100644 index 000000000..39772b451 --- /dev/null +++ b/test-suite/tests/sxml-match-tests.ss @@ -0,0 +1,301 @@ +(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)) diff --git a/test-suite/tests/sxml.match.test b/test-suite/tests/sxml.match.test new file mode 100644 index 000000000..b3dbbe729 --- /dev/null +++ b/test-suite/tests/sxml.match.test @@ -0,0 +1,45 @@ +;;;; 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))))) + + +;;; +;;; Include upstream source file. +;;; + +;; This file was taken unmodified from +;; on +;; 2010-05-24. It was written by Jim Bender and released +;; under the MIT/X11 license +;; . +;; +;; 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")