136 lines
3.9 KiB
Scheme
136 lines
3.9 KiB
Scheme
;;;
|
|
;;; Time-stamp: <2008-08-11 21:10:24 noel>
|
|
;;;
|
|
;;; Copyright (C) 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:
|
|
|
|
#lang scheme/base
|
|
|
|
(require
|
|
(file "base.ss")
|
|
(file "test-suite.ss"))
|
|
|
|
(provide (all-defined-out))
|
|
|
|
;; 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)
|
|
(apply-test-suite test fdown fup fhere seed))
|
|
(else
|
|
(raise
|
|
(make-exn:test
|
|
(format "foldts: Don't know what to do with ~a. It isn't a test case or test suite." test)
|
|
(current-continuation-marks))))))
|
|
|
|
|
|
;; Useful in fold-test-results below
|
|
(define 2nd-arg (lambda (a b) b))
|
|
|
|
;; fold-test-results :
|
|
;; ('b 'c ... 'a -> 'a)
|
|
;; 'a
|
|
;; test
|
|
;; #:run (string (() -> any) -> 'b 'c ...)
|
|
;; #:fdown (string 'a -> 'a)
|
|
;; #:fup (string 'a -> 'a)
|
|
;; ->
|
|
;; 'a
|
|
;;
|
|
;; Fold collector pre-order L-to-R depth-first over the
|
|
;; result of run. By default these are test results, and
|
|
;; hence by default result-fn is
|
|
;;
|
|
;; test-result 'a -> 'a
|
|
(define (fold-test-results result-fn seed test
|
|
#:run [run run-test-case]
|
|
#:fdown [fdown 2nd-arg]
|
|
#:fup [fup 2nd-arg])
|
|
(foldts
|
|
(lambda (suite name before after seed)
|
|
'(printf "into ~a\n" name)
|
|
(before)
|
|
(fdown name seed))
|
|
(lambda (suite name before after seed kid-seed)
|
|
'(printf "out of ~a\n" name)
|
|
(after)
|
|
(fup name kid-seed))
|
|
(lambda (case name action seed)
|
|
'(printf "running ~a\n" name)
|
|
(apply result-fn
|
|
;; Get the values returned by run-fn into a
|
|
;; list and append the seed
|
|
(append (call-with-values
|
|
(lambda () (run name action))
|
|
list)
|
|
(list seed))))
|
|
seed
|
|
test))
|
|
|
|
;; run-test-case : string thunk -> test-result
|
|
(define (run-test-case name action)
|
|
'(printf "run-test-case running ~a ~a\n" name action)
|
|
(with-handlers
|
|
([exn:test:check?
|
|
(lambda (exn)
|
|
(make-test-failure name exn))]
|
|
[(lambda _ #t)
|
|
(lambda (exn)
|
|
(make-test-error name exn))])
|
|
(let ((value (action)))
|
|
(make-test-success name value))))
|
|
|
|
;; run-test : test -> (list-of test-result)
|
|
;;
|
|
;; Run test returning a tree of test-results. Results are
|
|
;; ordered L-to-R as they occur in the tree.
|
|
(define (run-test test)
|
|
(reverse
|
|
(fold-test-results
|
|
(lambda (result seed) (cons result seed))
|
|
(list)
|
|
test)))
|
|
|