;;; ;;; Time-stamp: <06/02/23 09:27:04 noel> ;;; ;;; Copyright (C) 2005 by Noel Welsh. ;;; ;;; 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 2.1 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., 59 Temple ;;; Place, Suite 330, Boston, MA 02111-1307 USA ;;; Author: Noel Welsh <noelwelsh@yahoo.com> ;; ;; ;; Commentary: ;; foldts : ;; (test-suite string thunk thunk 'a -> 'a) ;; (test-suite string thunk thunk 'a 'a -> 'a) ;; (test-case string thunk 'a -> 'a) ;; 'a ;; test ;; -> ;; 'a ;; ;; Extended tree fold ala SSAX for tests. Note that the ;; test-case/test-suite is passed to the functions so that ;; subtypes of test-case/test-suite can be differentiated, ;; allowing extensibility [This is an interesting difference ;; between OO and FP. FP gives up extensibility on ;; functions, OO on data. Here we want extensibility on ;; data so FP is a bit ugly]. (define (foldts fdown fup fhere seed test) (cond ((schemeunit-test-case? test) (fhere test (schemeunit-test-case-name test) (schemeunit-test-case-action test) seed)) ((schemeunit-test-suite? test) (let ((name (schemeunit-test-suite-name test)) (tests (schemeunit-test-suite-tests test)) (before (schemeunit-test-suite-before test)) (after (schemeunit-test-suite-after test))) (let loop ((kid-seed (fdown test name before after seed)) (kids tests)) (if (null? kids) (fup test name before after seed kid-seed) (loop (foldts fdown fup fhere kid-seed (car kids)) (cdr kids)))))) (else (error "Incorrect type passed to foldts"))))