;;;
;;; Time-stamp: <2006-11-28 16:24:11 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 <[email protected]>
;;
;;
;; Commentary:

(module result mzscheme

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

  (provide (all-defined))

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

  ;; 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/kw (fold-test-results result-fn seed test
                                #:key
                                [run run-test-case]
                                [fdown 2nd-arg]
                                [fup 2nd-arg])
    (foldts
     (lambda (suite name before after seed)
       (before)
       (fdown name seed))
     (lambda (suite name before after seed kid-seed)
       (after)
       (fup name kid-seed))
     (lambda (case name action seed)
       (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)
    (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)))
  )