plt/result.ss
;;;
;;; Time-stamp: <06/03/11 12:13:30 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:

(module result mzscheme

  (require (lib "include.ss")
           "base.ss")

  (provide (all-defined))

  (include "../generic/foldts.ss")

  ;; fold-test-results: suite-fn result-fn cons-fn seed test
  ;; (type (((String 'a) -> 'a) (Test-Result -> 'a) 'a Test) -> 'a)
  ;;
  ;; Fold collector pre-order L-to-R depth-first over test
  ;; results.
  (define (fold-test-results suite-fn case-fn seed test)
    (foldts
     (lambda (suite name before after seed)
       (before)
       (suite-fn name seed))
     (lambda (suite name before after seed kid-seed)
       (after)
       kid-seed)
     (lambda (case name action seed)
       (case-fn
        (run-test-case name action)
        seed))
     seed
     test))


  ;; run-test-case : string thunk -> test-result
  (define (run-test-case 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 (name seed)
        seed)
      (lambda (result seed) (cons result seed))
      (list)
      test)))

  
  )