mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

Add (sxml match).

Browse source 
* 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'.
This commit is contained in:
Ludovic Courtès 2010-05-24 23:13:16 +02:00
parent adb8f30600
commit 400a5dcb8b
9 changed files with 2003 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

1
doc/ref/Makefile.am
View file

@ -58,6 +58,7 @@ guile_TEXINFOS = preface.texi \
posix.texi \ posix.texi \
expect.texi \ expect.texi \
scsh.texi \ scsh.texi \
sxml-match.texi \
scheme-scripts.texi \ scheme-scripts.texi \
api-overview.texi \ api-overview.texi \
api-discdepr.texi \ api-discdepr.texi \

5
doc/ref/guile.texi
View file

@ -359,6 +359,7 @@ available through both Scheme and C interfaces.
* Streams:: Sequences of values. * Streams:: Sequences of values.
* Buffered Input:: Ports made from a reader function. * Buffered Input:: Ports made from a reader function.
* Expect:: Controlling interactive programs with Guile. * Expect:: Controlling interactive programs with Guile.
* sxml-match:: Pattern matching of SXML.
* The Scheme shell (scsh):: Using scsh interfaces in Guile. * The Scheme shell (scsh):: Using scsh interfaces in Guile.
* Tracing:: Tracing program execution. * Tracing:: Tracing program execution.
@end menu @end menu
@ -370,6 +371,10 @@ available through both Scheme and C interfaces.
@include repl-modules.texi @include repl-modules.texi
@include misc-modules.texi @include misc-modules.texi
@include expect.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 scsh.texi
@include scheme-debugging.texi @include scheme-debugging.texi

377
doc/ref/sxml-match.texi Normal file
View file

@ -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 <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:

2
module/Makefile.am
View file

@ -321,6 +321,7 @@ LIB_SOURCES = \
statprof.scm \ statprof.scm \
sxml/apply-templates.scm \ sxml/apply-templates.scm \
sxml/fold.scm \ sxml/fold.scm \
sxml/match.scm \
sxml/simple.scm \ sxml/simple.scm \
sxml/ssax/input-parse.scm \ sxml/ssax/input-parse.scm \
sxml/ssax.scm \ sxml/ssax.scm \
@ -354,6 +355,7 @@ NOCOMP_SOURCES = \
ice-9/debugging/trace.scm \ ice-9/debugging/trace.scm \
ice-9/debugging/traps.scm \ ice-9/debugging/traps.scm \
ice-9/debugging/trc.scm \ ice-9/debugging/trc.scm \
sxml/sxml-match.ss \
sxml/upstream/SSAX.scm \ sxml/upstream/SSAX.scm \
sxml/upstream/SXML-tree-trans.scm \ sxml/upstream/SXML-tree-trans.scm \
sxml/upstream/SXPath-old.scm \ sxml/upstream/SXPath-old.scm \

92
module/sxml/match.scm Normal file
View file

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

1178
module/sxml/sxml-match.ss Normal file
View file

File diff suppressed because it is too large Load diff

3
test-suite/Makefile.am
View file

@ -121,6 +121,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/strings.test \ tests/strings.test \
tests/structs.test \ tests/structs.test \
tests/sxml.fold.test \ tests/sxml.fold.test \
tests/sxml.match.test \
tests/sxml.simple.test \ tests/sxml.simple.test \
tests/sxml.ssax.test \ tests/sxml.ssax.test \
tests/sxml.transform.test \ tests/sxml.transform.test \
@ -187,4 +188,4 @@ LALR_EXTRA += \
TESTS = $(LALR_TESTS) TESTS = $(LALR_TESTS)
TESTS_ENVIRONMENT = $(top_builddir)/meta/guile --no-autocompile 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

301
test-suite/tests/sxml-match-tests.ss Normal file
View file

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

45
test-suite/tests/sxml.match.test Normal file
View file

@ -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
;; <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")