generic/foldts.ss
;;;
;;; 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"))))