summaryrefslogtreecommitdiff
path: root/test-suite/tests/sxml.fold.test
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests/sxml.fold.test')
-rw-r--r--test-suite/tests/sxml.fold.test210
1 files changed, 210 insertions, 0 deletions
diff --git a/test-suite/tests/sxml.fold.test b/test-suite/tests/sxml.fold.test
new file mode 100644
index 000000000..6daa64953
--- /dev/null
+++ b/test-suite/tests/sxml.fold.test
@@ -0,0 +1,210 @@
+;;;; sxml.fold.test -*- scheme -*-
+;;;;
+;;;; 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
+
+;;; Commentary:
+;;
+;; Unit tests for (sxml fold).
+;;
+;;; Code:
+
+(define-module (test-suite sxml-fold)
+ #:use-module (test-suite lib)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (sxml fold))
+
+(define atom? (@@ (sxml fold) atom?))
+(define (id x) x)
+(define-syntax accept
+ (syntax-rules ()
+ ((_ expr)
+ (call-with-values (lambda () expr) list))))
+
+(with-test-prefix "test-fold"
+ (define test-doc
+ '(presentation
+ (@ (width 1024)
+ (height 768)
+ (title-style "font-family:Georgia")
+ (title-height 72)
+ (title-baseline-y 96)
+ (title-x 48)
+ (text-height 64)
+ (text-style "font-family:Georgia")
+ (text-upper-left-x 96)
+ (text-upper-left-y 216))
+ (slide
+ (@ (title "Declarative interface"))
+ (p "The declarative interface"
+ "lets you be more concise"
+ "when making the slides."))
+ (slide
+ (@ (title "Still cumbersome"))
+ (p "Parentheses are still"
+ "cumbersome."))))
+
+ (pass-if (atom? 'foo))
+ (pass-if (atom? '()))
+ (pass-if (not (atom? '(1 2 3))))
+
+ (pass-if "foldt identity"
+ (equal? (foldt id id test-doc) test-doc))
+
+ (pass-if "fold cons == reverse"
+ (equal? (fold cons '() test-doc)
+ (reverse test-doc)))
+
+ (pass-if "foldts identity"
+ (equal? (foldts (lambda (seed tree) '())
+ (lambda (seed kid-seed tree)
+ (cons (reverse kid-seed) seed))
+ (lambda (seed tree)
+ (cons tree seed))
+ '()
+ test-doc)
+ (cons test-doc '())))
+
+ (pass-if "foldts* identity"
+ (equal? (foldts* (lambda (seed tree) (values '() tree))
+ (lambda (seed kid-seed tree)
+ (cons (reverse kid-seed) seed))
+ (lambda (seed tree)
+ (cons tree seed))
+ '()
+ test-doc)
+ (cons test-doc '())))
+
+ (pass-if "fold-values == fold"
+ (equal? (fold-values cons test-doc '())
+ (fold cons '() test-doc)))
+
+ (pass-if "foldts*-values == foldts*"
+ (equal? (foldts*-values
+ (lambda (tree seed) (values tree '()))
+ (lambda (tree seed kid-seed)
+ (cons (reverse kid-seed) seed))
+ (lambda (tree seed)
+ (cons tree seed))
+ test-doc
+ '())
+ (foldts* (lambda (seed tree) (values '() tree))
+ (lambda (seed kid-seed tree)
+ (cons (reverse kid-seed) seed))
+ (lambda (seed tree)
+ (cons tree seed))
+ '()
+ test-doc)))
+
+ (let ()
+ (define (replace pred val list)
+ (reverse
+ (fold
+ (lambda (x xs)
+ (cons (if (pred x) val x) xs))
+ '()
+ list)))
+
+ (define (car-eq? x what)
+ (and (pair? x) (eq? (car x) what)))
+
+ ;; avoid entering <slide>
+ (pass-if "foldts* *pre* behaviour"
+ (equal? (foldts*-values
+ (lambda (tree seed)
+ (values (if (car-eq? tree 'slide) '() tree) '()))
+ (lambda (tree seed kid-seed)
+ (cons (reverse kid-seed) seed))
+ (lambda (tree seed)
+ (cons tree seed))
+ test-doc
+ '())
+ (cons
+ (replace (lambda (x) (car-eq? x 'slide))
+ '()
+ test-doc)
+ '()))))
+
+ (let ()
+ (define (all-elts tree)
+ (reverse!
+ (foldts*-values
+ (lambda (tree seed)
+ (values tree seed))
+ (lambda (tree seed kid-seed)
+ kid-seed)
+ (lambda (tree seed)
+ (cons tree seed))
+ tree
+ '())))
+
+ (define (len tree)
+ (foldts*-values
+ (lambda (tree seed)
+ (values tree seed))
+ (lambda (tree seed kid-seed)
+ kid-seed)
+ (lambda (tree seed)
+ (1+ seed))
+ tree
+ 0))
+
+ (pass-if "foldts length"
+ (equal? (length (all-elts test-doc))
+ (len test-doc)))))
+
+(with-test-prefix "test-fold-layout"
+ (define test-doc
+ '(presentation
+ (@ (width 1024)
+ (height 768)
+ (title-style "font-family:Georgia")
+ (title-height 72)
+ (title-baseline-y 96)
+ (title-x 48)
+ (text-height 64)
+ (text-style "font-family:Georgia")
+ (text-upper-left-x 96)
+ (text-upper-left-y 216))
+ (slide
+ (@ (title "Declarative interface"))
+ (p "The declarative interface"
+ "lets you be more concise"
+ "when making the slides."))
+ (slide
+ (@ (title "Still cumbersome"))
+ (p "Parentheses are still"
+ "cumbersome."))))
+
+ (define (identity-layout tree)
+ (fold-layout
+ tree
+ `((*default*
+ . ,(lambda (tag params old-layout layout kids)
+ (values layout
+ (if (null? (car params))
+ (cons tag kids)
+ (cons* tag (cons '@ (car params)) kids)))))
+ (*text*
+ . ,(lambda (text params layout)
+ (values layout text))))
+ '()
+ (cons 0 0)
+ '()))
+
+ (pass-if "fold-layout"
+ (equal? (accept (identity-layout test-doc))
+ (list test-doc (cons 0 0)))))