1 ;;;; sxml.fold.test -*- scheme -*-
3 ;;;; Copyright (C) 2010 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21 ;; Unit tests for (sxml fold).
25 (define-module (test-suite sxml-fold)
26 #:use-module (test-suite lib)
27 #:use-module ((srfi srfi-1) #:select (fold))
28 #:use-module (sxml fold))
30 (define atom? (@@ (sxml fold) atom?))
35 (call-with-values (lambda () expr) list))))
37 (with-test-prefix "test-fold"
42 (title-style "font-family:Georgia")
47 (text-style "font-family:Georgia")
48 (text-upper-left-x 96)
49 (text-upper-left-y 216))
51 (@ (title "Declarative interface"))
52 (p "The declarative interface"
53 "lets you be more concise"
54 "when making the slides."))
56 (@ (title "Still cumbersome"))
57 (p "Parentheses are still"
60 (pass-if (atom? 'foo))
62 (pass-if (not (atom? '(1 2 3))))
64 (pass-if "foldt identity"
65 (equal? (foldt id id test-doc) test-doc))
67 (pass-if "fold cons == reverse"
68 (equal? (fold cons '() test-doc)
71 (pass-if "foldts identity"
72 (equal? (foldts (lambda (seed tree) '())
73 (lambda (seed kid-seed tree)
74 (cons (reverse kid-seed) seed))
81 (pass-if "foldts* identity"
82 (equal? (foldts* (lambda (seed tree) (values '() tree))
83 (lambda (seed kid-seed tree)
84 (cons (reverse kid-seed) seed))
91 (pass-if "fold-values == fold"
92 (equal? (fold-values cons test-doc '())
93 (fold cons '() test-doc)))
95 (pass-if "foldts*-values == foldts*"
96 (equal? (foldts*-values
97 (lambda (tree seed) (values tree '()))
98 (lambda (tree seed kid-seed)
99 (cons (reverse kid-seed) seed))
104 (foldts* (lambda (seed tree) (values '() tree))
105 (lambda (seed kid-seed tree)
106 (cons (reverse kid-seed) seed))
113 (define (replace pred val list)
117 (cons (if (pred x) val x) xs))
121 (define (car-eq? x what)
122 (and (pair? x) (eq? (car x) what)))
124 ;; avoid entering <slide>
125 (pass-if "foldts* *pre* behaviour"
126 (equal? (foldts*-values
128 (values (if (car-eq? tree 'slide) '() tree) '()))
129 (lambda (tree seed kid-seed)
130 (cons (reverse kid-seed) seed))
136 (replace (lambda (x) (car-eq? x 'slide))
142 (define (all-elts tree)
147 (lambda (tree seed kid-seed)
158 (lambda (tree seed kid-seed)
165 (pass-if "foldts length"
166 (equal? (length (all-elts test-doc))
169 (with-test-prefix "test-fold-layout"
174 (title-style "font-family:Georgia")
176 (title-baseline-y 96)
179 (text-style "font-family:Georgia")
180 (text-upper-left-x 96)
181 (text-upper-left-y 216))
183 (@ (title "Declarative interface"))
184 (p "The declarative interface"
185 "lets you be more concise"
186 "when making the slides."))
188 (@ (title "Still cumbersome"))
189 (p "Parentheses are still"
192 (define (identity-layout tree)
196 . ,(lambda (tag params old-layout layout kids)
198 (if (null? (car params))
200 (cons* tag (cons '@ (car params)) kids)))))
202 . ,(lambda (text params layout)
203 (values layout text))))
208 (pass-if "fold-layout"
209 (equal? (accept (identity-layout test-doc))
210 (list test-doc (cons 0 0)))))