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