74 lines
2.6 KiB
Scheme
74 lines
2.6 KiB
Scheme
(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))
|
|
|
|
|