diff --git a/collects/tests/mztake/mztake-test.ss b/collects/tests/mztake/mztake-test.ss new file mode 100644 index 0000000000..87b1446b74 --- /dev/null +++ b/collects/tests/mztake/mztake-test.ss @@ -0,0 +1,7 @@ +(require (as-is mzscheme load) + (as-is "test-harness.ss" test)) +(load "../demos/dijkstra/dijkstra-mztake.ss") +(map-e (lambda (e) + (unless e + (test (dv:vector-length (t-data heap)) 5))) + (debug-process-running-e (current-process))) \ No newline at end of file diff --git a/collects/tests/mztake/test-harness.ss b/collects/tests/mztake/test-harness.ss new file mode 100644 index 0000000000..342fca28ce --- /dev/null +++ b/collects/tests/mztake/test-harness.ss @@ -0,0 +1,76 @@ +(module test-harness mzscheme + (provide (all-defined)) + (require (lib "list.ss") + (lib "etc.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 + (opt-lambda (result expected [compare equal?]) + (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)]) + (compare 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 + ([void (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) + ) + +