;; @(#)$Id: testing.scm,v 1.3 2006/01/18 23:17:27 leavens Exp $
;;; Copyright (C) 2006 Iowa State University
;;;
;;; This file is part of Typedscm.
;;;
;;; 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 Typedscm; see the file LesserGPL.txt.  If not,
;;; write to the Free Software Foundation, Inc., 51 Franklin St, Fifth
;;; Floor, Boston, MA 02110-1301 USA.

(module testing mzscheme
  (provide show-test-output! hide-test-output!
	   run-test-case-maker run-test-case regression-test-maker
           run-regression-test run-regression-tests-maker
           run-regression-tests-equal?
	   displayln writeln)

  (require (lib "displayln-mod.scm" "typedscm")
	   (lib "writeln-mod.scm" "typedscm")
           (lib "pretty.ss" "mzlib"))
  
  (define *show-test-output* #f)

  (define show-test-output!
    (lambda ()
      (set! *show-test-output* #t)))

  (define hide-test-output!
    (lambda ()
      (set! *show-test-output* #f)))

  (define testing:print-test-case-prefix writeln)
  
  (define run-test-case-maker
    (lambda (print-code eval-print-result)
      ;; REQUIRES: eval-print-result prints a separator and the result,
      ;;           with a newline at the end of it all.
      ;; EFFECT: prints the code and the result of executing the code.
      (lambda (code)
        (print-code code)
        (eval-print-result code))))
  
  (define testing:evals-to-symbol '==>)
  (define testing:equals-symbol '=)
  
  (define testing:before-connective-spaces "        ")
  
  (define testing:print-connective-maker
    (lambda (connective)
      (lambda ()
        (display testing:before-connective-spaces)
        (display connective)
        (display " "))))
  
  (define testing:eval-print-maker
    (lambda (writeln)
      (lambda (code)
	((testing:print-connective-maker testing:evals-to-symbol))
	(writeln (eval code)))))
  
  (define run-test-case
    (lambda (code)
      ((run-test-case-maker
	pretty-print
	(testing:eval-print-maker pretty-print))
       code)))
  
  (define testing:num-wrong
    0)
  
  (define testing:regression-test-maker-maker
    (lambda (print-connective-maker)
      (let ((print-arrow (print-connective-maker testing:evals-to-symbol))
            (print-equal-sign (print-connective-maker testing:equals-symbol)))
        (lambda (okay? print-code print-result)
          ;; REQUIRES: connective is either testing:evals-to-symbol
          ;;                         or testing:equals-symbol
          (lambda (code connective expected)
	    (if *show-test-output*
		(print-code code))
            (let ((result (eval code)))
              (cond
	       ((eq? connective testing:evals-to-symbol)
		(if (okay? result expected)
		    (if *show-test-output*
			(begin
			  (print-arrow)
			  (print-result result)))
		    (begin
		      (if (not *show-test-output*)
			    (print-code code))
		      (set! testing:num-wrong (+ testing:num-wrong 1))
		      (print-arrow)
		      (print-result result)
		      (display "  EXPECTED: ")
		      (print-result expected))))
	       ((eq? connective testing:equals-symbol)
		(let ((expected-result (eval expected)))
		  (if (okay? result expected-result)
		      (if *show-test-output*
			  (begin
			    (print-equal-sign)
			    (print-code expected)))
		      (begin
			(if (not *show-test-output*)
			    (print-code code))
			(set! testing:num-wrong (+ testing:num-wrong 1))
			(print-arrow)
			(print-result result)
			(display "  EXPECTED: ")
			(print-result expected-result)
			(display "        <== ")
			(print-code expected)))))
	       (else (error "Bad connective in test case : " connective)))
              ))))))
  
  (define regression-test-maker
    (lambda (okay? print-code print-result)
      ((testing:regression-test-maker-maker testing:print-connective-maker)
       okay? print-code print-result)))
  
  (define run-regression-test
    (lambda (code connective expected)
      ((regression-test-maker equal? pretty-print pretty-print)
       code connective expected)))
  
  (define run-regression-tests-maker
    (lambda (okay? print-code print-result)
      (let ((regress (regression-test-maker okay? print-code print-result)))
        (lambda (test-table)
          (let ((old-num-wrong testing:num-wrong))
            (for-each
             (lambda (test) (regress (car test) (cadr test) (caddr test)))
             test-table)
            (if (not (= old-num-wrong testing:num-wrong))
                (displayln "TOTAL UNEXPECTED RESULTS THIS TEST RUN: "
                           (- testing:num-wrong old-num-wrong))
                (displayln "All tests passed!")))))))
  
  (define run-regression-tests-equal?
    (lambda (test-table)
      ((run-regression-tests-maker equal? pretty-print pretty-print)
       test-table)))
  )