;; drscheme-init.scm - compatibility file for DrScheme
;; by Mitch Wand and Dave Herman
;; 2004-12-19

;; usage: (require "drscheme-init.scm")

;;; makes structs printable, and provides basic functionality for testing.

(module drscheme-init mzscheme
  
  (let ((version "plt209.1.3 20dec2004")
        (filename "drscheme-init.scm"))
    (printf "~a ~a~%" filename version))
  
  ;; show the contents of define-datatype values
  (print-struct #t)

  (require (lib "pretty.ss"))
  
  (provide 
   run-experiment
   run-tests!
   stop-after-first-error
   )
  
  ;; safely apply procedure fn to a list of args.
  ;; if successful, return (cons #t val)
  ;; if eopl:error is invoked, returns (cons #f string), where string is the
  ;; format string generated by eopl:error.  If somebody manages to raise a 
  ;; value other than an exception, then the raised value is reported.
  
  (define apply-safely
    (lambda (proc args)
      (with-handlers ([(lambda (exn) #t)      ; catch any error
                       (lambda (exn)          ; evaluate to a failed test result
                         (cons #f 
                               (if (exn? exn)
                                   (exn-message exn)
                                   exn)))])  
        (let ([actual (apply proc args)])
          (cons #t actual)))))
  
  ;; run-experiment :
  ;;  (args -> val) * args * val * (val * val -> bool)
  ;;  -> (cons bool (val | string))
  
  ;; usage: (run-experiment fn args correct-answer equal-answer?)
  
  ;; apply fn to args.  Compare the result to correct-answer.  If
  ;; correct-answer is 'error, then an error should have been thrown and
  ;; caught by apply-safely.
  ;; returns (cons bool val2) where bool indicates whether the
  ;; answer is correct.  If an error was thrown, val2 is the formatted 
  ;; string.
    
  (define run-experiment
    (lambda (fn args correct-answer equal-answer?)
      (let*
          ((result (apply-safely fn args))
           ;; ans is either the answer or the args to eopl:error
           (error-thrown? (not (car result)))
           (ans (cdr result)))
          
        (cons
         (if (eqv? correct-answer 'error)
             error-thrown?
             (equal-answer? ans correct-answer))
         ans))))
  
  (define stop-after-first-error (make-parameter #f))
  
   
  ;; usage: (run-tests! run-fn equal-answer? tests)

  ;; run-tests! : (arg -> outcome) * (any * any -> bool) * (list-of test)
  ;;             -> unspecified

  ;; where:
  ;; test ::= (name arg outcome)
  ;; outcome ::= ERROR | any
  
  ;; for each item in tests, apply run-fn to the arg.  Check to see if
  ;; the outcome is right, comparing values using equal-answer?.

  ;; print a log of the tests.

  ;; at the end, print either "no bugs found" or the list of tests
  ;; failed. 
  
  ;; Normally, run-tests! will recover from any error and continue to
  ;; the end of the test suite.  This behavior can be altered by
  ;; setting (stop-after-first-error #t).

  (define (run-tests! run-fn equal-answer? tests)
    (let ((tests-failed '()))
      (for-each
       (lambda (test-item)
         (let ((name (car test-item))
               (pgm (cadr test-item))
               (correct-answer (caddr test-item)))
           (printf "test: ~a~%~a~%" name pgm)
           (let* ((result
                   (run-experiment run-fn (list pgm) correct-answer equal-answer?))
                  (correct? (car result))
                  (actual-answer (cdr result)))
             (printf "correct outcome: ~a~%" correct-answer)
             (printf "actual outcome:  ")
             (pretty-display actual-answer)
             (if correct?
                 (printf "correct~%~%")
                 (begin
                   (printf "incorrect~%~%")
                   ;; stop on first error if stop-after-first? is set:
                   (if (stop-after-first-error)
                       (error name "incorrect outcome detected")) 
                   (set! tests-failed
                         (cons name tests-failed)))))))
       tests)
      (if (null? tests-failed)
          (printf "no bugs found~%")
          (printf "incorrect answers on tests: ~a~%"
            (reverse tests-failed)))))
  
  )