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

;; usage: (require "drscheme-mp5-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-mp5-init mzscheme
  
  (let ((version "plt360 2/25/07")
        (filename "drscheme-mp5-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
   )

  (require (only mzscheme values let*-values)) 
  
  ;; 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)))))

  ;; Trace = [Listof b] | error
  ;;
  ;; run-experiment :
  ;;  ((a ...) -> b) * (a ...) *  Trace  (b * b->bool)
  ;;  -> (cons bool b) (cons bool [Listof b]) 
  
  ;; usage: (run-experiment fn args correct-trace equal-answer?)
  ;; Applies fn to args.  Compares the result to correct-trace. First value 
  ;; returned holds (bool b) where bool indicates whether the trace is correct. 
  ;;
  ;; Also, logs any output of fn (through logged:print). Compares logged output 
  ;; to correct-trace using equal-answer?. The second value returned holds (bool 
  ;; [Listof b]), where bool indicates whether the logged output matches 
  ;; correct-trace.
  (define run-experiment
    (lambda (fn args correct-trace equal-answer?)
      (let*
          ( ;; init logged-stream
           (dummy1 (initialize-logged-stream!))
           (result (apply-safely fn args))
           ;; get the list of values given to logged:print
           (logged-prints (get-logged-stream))
           ;; ans is either the answer or the args to eopl:error
           (error-thrown? (not (car result)))
           (ans (cdr result))
           (correct-anwser?  (if (eqv? correct-trace 'error)
                               error-thrown?
                               (correct-trace? correct-trace 
                                logged-prints equal-answer?))))
                               

          (values (cons correct-anwser? ans) 
                  (cons correct-anwser? logged-prints)))))
                   
  ;; NumOrBool = Number | Boolean 
  ;; Printval = (num-val n) | (bool-val b)
  ;;
  ;; correct-trace? : [Listof NumOrBool] [Listof Printval]
  ;;                  (Printval NumOrBool -> Boolean) -> Boolean | Error
  ;;
  ;; usage : (correct-trace? a e test)
  ;; produces : true if for all corresponding elements of a and e (test a e)=#t
  ;;            false if one of (test a e) =#f  and error if (test a e) = error
  (define correct-trace? 
   (lambda (expected actual equal-answer?)
    (if (= (length actual) (length expected))
      (andmap equal-answer? actual expected)
      (error 'correct-trace? 
       "Trace mismatch. ~% actual trace = ~s ~% correct-trace = ~s ~%"
       actual expected))))
         
    
  
  (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 trace 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-trace (caddr test-item)))
           (printf "test: ~a~%~a~%" name pgm)
           (let*-values (((result traces-result)
                           (run-experiment
                             run-fn (list pgm) correct-trace equal-answer? )))
            (let ((correct? (car result))
                  (correct-trace? (car traces-result))
                  (actual-answer (cdr result))
                  (actual-trace (cdr traces-result)))
             ;;(printf "correct outcome: ~a~%" correct-answer)
             ;;(printf "actual outcome:  ")
             ;;(pretty-display actual-answer)
             (printf "correct trace: ~a~%" correct-trace)
             (printf "actual trace:  ~a~%" actual-trace)
             (if correct-trace?
               (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)))))



;;skotthe@ccs.neu.edu 
;;Sat Mar  4 18:21:05 EST 2006
;;
;; Provides logged:printf that can be used instead of eopl:printf.  
;; logged:printf logs its arguments in logged-stream using mutation.  The 
;; functions initialize-logged-stream! reset the logged data and get-logged-stream
;; return the logged data as a scheme list. 

  (provide logged:printf)

 ;; initialize-logged-stream! : -> void
 ;; produces : Sets logged-stream to '()
 (define initialize-logged-stream! 
  (lambda ()
   (set! logged-stream '())))

 ;; get-logged-stream : -> [Listof Expval]
 ;; produces : returns the logged expvals printed tou stdout
 (define get-logged-stream 
  (lambda ()
   logged-stream))

 (define logged-stream '())

 ;; logged:printf : a1 a2 ... -> void
 ;; produces : Wrapper to eopl:printf. Logs the values passed to eopl:printf 
 ;; excluding the format string (1st argument to eopl:printf). Then calls 
 ;; eopl:printf. 
 (define logged:printf
  (lambda args
   (let ((fstr (car args))
         (vals (cdr args)))
    (begin 
     (set! logged-stream (append logged-stream vals))
     (apply printf args)))))
     

)