From b0ed3b49e00b27f84d5a953c9db03267d6d47555 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 27 Feb 2013 21:24:25 -0600 Subject: [PATCH] adjust plai test & co. to print only failing tests to stderr, instead of printing all of them also, adjust the plai test suites to cope with test results going to two different places --- collects/plai/scribblings/plai.scrbl | 6 ++++-- collects/plai/test-harness.rkt | 4 ++-- collects/tests/plai/datatype.rkt | 18 +++++++++--------- collects/tests/plai/gc/run-test.rkt | 5 +++-- collects/tests/plai/gc2/run-test.rkt | 5 +++-- collects/tests/plai/util.rkt | 8 ++++++++ 6 files changed, 29 insertions(+), 17 deletions(-) create mode 100644 collects/tests/plai/util.rkt diff --git a/collects/plai/scribblings/plai.scrbl b/collects/plai/scribblings/plai.scrbl index 54fdc83bcf..5da58e274a 100644 --- a/collects/plai/scribblings/plai.scrbl +++ b/collects/plai/scribblings/plai.scrbl @@ -124,8 +124,7 @@ PLAI Scheme provides the following syntactic forms for testing. @defform/subs[(test result-expr expected-expr)()]{ If @racket[_result-expr] and @racket[_expected-expr] evaluate to the same -value, @racket[_result-value], the test prints the following expression -to @racket[(current-error-port)]: +value, @racket[_result-value], the test prints the following expression: @racketresultfont{(good result-expr result-value expected-value location)}. @@ -141,6 +140,9 @@ If evaluating @racket[_expected-expr] signals an error, the test prints @racketresultfont{(pred-exception result-expr exception-message location)} +If the printout begins with @racket[good], then it is printed to +@racket[(current-output-port)]; otherwise it is printed to @racket[(current-error-port)]. + } @defform/subs[(test/pred result-expr pred?)()]{ diff --git a/collects/plai/test-harness.rkt b/collects/plai/test-harness.rkt index 0d46dc471e..f19b73121a 100644 --- a/collects/plai/test-harness.rkt +++ b/collects/plai/test-harness.rkt @@ -69,8 +69,8 @@ (set! plai-all-test-results (cons result plai-all-test-results)) (when print? (if (abridged-test-output) - (apply eprintf "(~s ~v ~v)\n" result) - (apply eprintf "(~s ~s ~v ~v ~s)\n" result))) + (apply (if error? eprintf printf) "(~s ~v ~v)\n" result) + (apply (if error? eprintf printf) "(~s ~s ~v ~v ~s)\n" result))) (when (and halt-on-errors? error?) (raise (make-exn:test (string->immutable-string (format "test failed: ~s" result)) (current-continuation-marks)))))) diff --git a/collects/tests/plai/datatype.rkt b/collects/tests/plai/datatype.rkt index 7c66dcf6d5..9460069c8b 100644 --- a/collects/tests/plai/datatype.rkt +++ b/collects/tests/plai/datatype.rkt @@ -1,5 +1,6 @@ #lang plai -(require (prefix-in eli: tests/eli-tester)) +(require (prefix-in eli: tests/eli-tester) + "util.rkt") (define-type A [mta] @@ -28,15 +29,14 @@ (define-type t1 (c1 (n number?))) - (eli:test (i 4) (regexp-match "\\(exception \\(make-i #f\\) \"make-i.+\" ' \"at line 36\"\\)" - (with-output-to-string (λ () (test/exn (make-i #f) "contract")))) + (with-both-output-to-string (λ () (test/exn (make-i #f) "contract")))) (regexp-match "\\(exception \\(i-f #f\\) \"i-f.+\" ' \"at line 39\"\\)" - (with-output-to-string (λ () (test/exn (i-f #f) "contract")))) + (with-both-output-to-string (λ () (test/exn (i-f #f) "contract")))) (type-case A (mta) @@ -46,13 +46,13 @@ 1 (regexp-match "\\(exception \\(c1 \\(quote not-a-number\\)\\) \"c1.+\" ' \"at line 49\"\\)" - (with-output-to-string (λ () (test (c1 'not-a-number) (list 5))))) + (with-both-output-to-string (λ () (test (c1 'not-a-number) (list 5))))) (regexp-match (regexp-quote "(exception (type-case t (list 1) (c () 1)) \"type-case: expected a value from type t, got: (1)\" ' \"at line 53\")") - (with-output-to-string (λ () - (test/exn - (type-case t (list 1) (c () 1)) - "expected")))) + (with-both-output-to-string (λ () + (test/exn + (type-case t (list 1) (c () 1)) + "expected")))) (type-case "foo" "bar") =error> "this must be a type defined with define-type" diff --git a/collects/tests/plai/gc/run-test.rkt b/collects/tests/plai/gc/run-test.rkt index fb17831027..bc1611f221 100644 --- a/collects/tests/plai/gc/run-test.rkt +++ b/collects/tests/plai/gc/run-test.rkt @@ -1,6 +1,7 @@ #lang racket (require tests/eli-tester - racket/runtime-path) + racket/runtime-path + "../util.rkt") (define-runtime-path here ".") @@ -23,7 +24,7 @@ (define (drop-first-line e) (regexp-replace "^[^\n]+\n" e "")) (define-syntax-rule (capture-output e) - (drop-first-line (with-output-to-string (λ () e)))) + (drop-first-line (with-both-output-to-string (λ () e)))) (test (if (run-good?) diff --git a/collects/tests/plai/gc2/run-test.rkt b/collects/tests/plai/gc2/run-test.rkt index 867f37b3aa..11598f3029 100644 --- a/collects/tests/plai/gc2/run-test.rkt +++ b/collects/tests/plai/gc2/run-test.rkt @@ -1,6 +1,7 @@ #lang racket (require tests/eli-tester - racket/runtime-path) + racket/runtime-path + "../util.rkt") (define-runtime-path here ".") @@ -23,7 +24,7 @@ (define (drop-first-line e) (regexp-replace "^[^\n]+\n" e "")) (define-syntax-rule (capture-output e) - (drop-first-line (with-output-to-string (λ () e)))) + (drop-first-line (with-both-output-to-string (λ () e)))) (test (if (run-good?) diff --git a/collects/tests/plai/util.rkt b/collects/tests/plai/util.rkt new file mode 100644 index 0000000000..dd365b4242 --- /dev/null +++ b/collects/tests/plai/util.rkt @@ -0,0 +1,8 @@ +#lang racket/base +(provide with-both-output-to-string) +(define (with-both-output-to-string thunk) + (define sp (open-output-string)) + (parameterize ([current-output-port sp] + [current-error-port sp]) + (thunk)) + (get-output-string sp)) \ No newline at end of file