(module test-harness mzscheme
  (provide (all-defined))
  (require (lib "list.ss")
           (lib "pretty.ss"))

  (define print-tests (make-parameter #f))
  (define test-inspector (make-parameter (current-inspector)))
  (define test-inexact-epsilon (make-parameter 0.01))

  (define-struct (exn:test exn) ())

  (define (install-test-inspector)
    (test-inspector (current-inspector))
    (current-inspector (make-inspector))
    (print-struct #t))

  (define (may-print-result result)
    (parameterize ([current-inspector (test-inspector)]
                   [print-struct #t])
      (when (or (eq? (print-tests) (first result))
                (eq? (print-tests) #t))
        
        (pretty-print result))
      (when (and (eq? (print-tests) 'stop)
                 (eq? (first result) 'bad))
        (raise (make-exn:test (string->immutable-string (format "test failed: ~a" result))
                              (current-continuation-marks))))))
    
  
  (define (test result expected)
    (let* ([test-result
            (cond [(or (and (number? result) (not (exact? result)))
                       (and (number? expected) (not (exact? expected))))
                   (< (abs (- result expected)) (test-inexact-epsilon))]
                  [else
                   (parameterize ([current-inspector (test-inspector)])
                     (equal? result expected))])]
           [to-print (if test-result 
                         (list 'good result expected)
                         (list 'bad result expected))])
      
      (may-print-result to-print)
      to-print))

  (define (test/pred result pred)
    (let* ([test-result (pred result)]
           [to-print (if test-result
                         (list 'good result test-result)
                         (list 'bad result test-result))])
      (may-print-result to-print)
      to-print))

  (define (test/exn thunk expected-exception-msg)
    (unless (and (procedure? thunk)
                 (procedure-arity-includes? thunk 0))
      (error (format
              "the first argument to test/exn should be a function of no arguments (a \"thunk\"), got ~a"
              thunk)))
    (let* ([result
           (with-handlers 
               ([exn:fail? (lambda (exn) exn)])
             (thunk))]
           [test-result
            (if (and (exn? result)
                     (regexp-match expected-exception-msg (exn-message result)))
                (list 'good result expected-exception-msg)
                (list 'bad result expected-exception-msg))])
      (may-print-result test-result)
      test-result))

  (install-test-inspector)
  )