mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
* 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).
210 lines
6.1 KiB
Scheme
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)))))
|