;; 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.

;;; revision history:

;;; 1.5 added provide make-parameter

;;; 1.4 1/25/05.  changed pretty-print to pretty-display

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

  (require (lib "pretty.ss"))
  (provide (all-from (lib "pretty.ss")))

  (require (lib "trace.ss"))
  (provide (all-from (lib "trace.ss")))

  (provide make-parameter)

  (provide 
   run-experiment
   run-tests!
   stop-after-first-error
   )
  
  (provide                          ;; for checking end-cont 
   register-value-with-test-harness)

  ;; 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 :
  ;;  ((a ...) -> b) * (a ...) * b * (b * b -> bool)
  ;;  -> (cons bool b)
  
  ;; usage: (run-experiment fn args correct-answer equal-answer?)
  ;; Applies fn to args.  Compares the result to correct-answer. 
  ;; Returns (cons bool b) where bool indicates whether the
  ;; answer is correct.

  (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))
  
   
  ;; run-tests! : (arg -> outcome) * (any * any -> bool) * (list-of test)
  ;;             -> unspecified

  ;; where:
  ;; test ::= (name arg outcome)
  ;; outcome ::= ERROR | any
  
  ;; usage: (run-tests! run-fn equal-answer? tests)

  ;; 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).
  
  ;; called-end-cont? : boolean 
  ;; purpose: #t if end-cont was called once or more, else #f. 
  (define called-end-cont? #f)

  (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))
               (dummy (set! called-end-cont? #f)) ;; for register-value-with-test-harness
               (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)))))

  
  ;; register-value-with-test-harness : expval -> Error | expval 
  ;; purpose : The first time end-cont is used return the value, 
  ;;           the second time around, throw an error. 
  (define register-value-with-test-harness
     (lambda (val)
      (if called-end-cont? 
       (error 'register-value-with-test-harness 
        "You tried to execute end-cont more than once")
       (begin 
        (set! called-end-cont? #t)
        val))))

  )