mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 01:00:20 +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

3
test-suite/Makefile.am
View file

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

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