1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
guile/test-suite/tests/sxml.fold.test
Ludovic Courtès 6c76da4c32 Remove `fold' from (sxml fold).
* module/sxml/fold.scm: Use (srfi srfi-1).
  (fold): Remove.
  (fold-values): Update docstring accordingly.

* test-suite/tests/sxml.fold.test: Use (srfi srfi-1).
2010-04-09 00:32:14 +02:00

210 lines
6.1 KiB
Scheme

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