diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss index 51e7c65ae0..ae9bc2eed2 100644 --- a/collects/test-engine/scheme-tests.ss +++ b/collects/test-engine/scheme-tests.ss @@ -6,8 +6,7 @@ mzlib/pretty mzlib/pconvert mzlib/class - "scheme-gui.scm" - "test-display.scm") + "scheme-gui.scm") (require-for-syntax stepper/private/shared) @@ -48,6 +47,8 @@ (current-namespace))]) (and test-info (let ([display-data (scheme-test-data)]) + (send test-info refine-display-class + (dynamic-require '(lib "test-display.scm" "test-engine") 'test-display%)) (send test-info setup-display (car display-data) (cadr display-data)) (send test-info summarize-results (current-output-port))))) @@ -60,7 +61,6 @@ #'(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))]) (and test-info - (send test-info refine-display-class test-display-textual%) (send test-info summarize-results (current-output-port)))) 'test-call #t)])) diff --git a/collects/test-engine/test-display.scm b/collects/test-engine/test-display.scm index 1c099db48c..40e4c81a94 100644 --- a/collects/test-engine/test-display.scm +++ b/collects/test-engine/test-display.scm @@ -282,97 +282,4 @@ (list (send parent get-percentages))) (send parent delete-child this))))) -(define test-display-textual% - (class* object% () - - (init-field (current-rep #f)) - - (define test-info #f) - (define/pubment (install-info t) - (set! test-info t) - (inner (void) install-info t)) - - (define/public (display-results) - (send this insert-test-results test-info)) - - (define/pubment (insert-test-results test-info) - (let* ([style (send test-info test-style)] - [total-tests (send test-info tests-run)] - [failed-tests (send test-info tests-failed)] - [total-checks (send test-info checks-run)] - [failed-checks (send test-info checks-failed)] - [test-outcomes - (lambda (zero-message) - (printf "~a" - (cond [(zero? total-tests) zero-message] - [(= 1 total-tests) "Ran 1 test.\n"] - [else (format "Ran ~a tests.\n" total-tests)])) - (when (> total-tests 0) - (printf "~a" - (cond - [(and (zero? failed-tests) (= 1 total-tests)) - "Test passed!\n\n"] - [(zero? failed-tests) "All tests passed!\n\n"] - [(= failed-tests total-tests) "0 tests passed.\n"] - [else "~a of the ~a tests failed.\n\n"]))))] - [check-outcomes - (lambda (zero-message) - (printf "~a" - (cond - [(zero? total-checks) zero-message] - [(= 1 total-checks) "Ran 1 check.\n"] - [else (format "Ran ~a checks.\n" total-checks)])) - (when (> total-checks 0) - (printf "~a" - (cond - [(and (zero? failed-checks) (= 1 total-checks)) - "Check passed!\n\n"] - [(zero? failed-checks) "All checks passed!\n\n"] - [(= failed-checks total-checks) "0 checks passed.\n"] - [else (format "~a of the ~a checks failed.\n\n" - failed-checks total-checks)]))))]) - (case style - [(test-require) - (test-outcomes "This program must be tested!\n") - (check-outcomes "This program is unchecked!\n")] - [(check-require) - (check-outcomes "This program is unchecked!\n")] - [(test-basic) - (test-outcomes "") - (check-outcomes "")] - [else (check-outcomes "")]) - - (unless (and (zero? total-checks) (zero? total-tests)) - (inner (display-check-failures (send test-info failed-checks) - test-info) - insert-test-results test-info)))) - - (define/public (display-check-failures checks test-info) - (for ([failed-check (reverse checks)]) - (printf "~a" "\t") - (make-link (failed-check-msg failed-check) - (failed-check-src failed-check)) - (printf "~a" "\n"))) - - (define/public (next-line) (printf "~a" "\n\t")) - - ;; make-link: (listof (U string snip%)) src -> void - (define (make-link msg dest) - (for-each printf msg) - (printf (format-src dest))) - - (define (format-src src) - (let ([src-file car] - [src-line cadr] - [src-col caddr]) - (string-append - (cond [(symbol? (src-file src)) " At "] - [(path? (src-file src)) - (string-append " In " (path->string (src-file src)) " at ")] - [(is-a? (src-file src) editor<%>) " At "]) - "line " (number->string (src-line src)) - " column " (number->string (src-col src))))) - - (super-instantiate ()))) - -(provide test-panel% test-window% test-display% test-display-textual%) +(provide test-panel% test-window% test-display%) diff --git a/collects/test-engine/test-engine.scm b/collects/test-engine/test-engine.scm index 68d895ff87..dda1581ad5 100644 --- a/collects/test-engine/test-engine.scm +++ b/collects/test-engine/test-engine.scm @@ -1,15 +1,107 @@ #lang scheme/base (require scheme/class - "test-info.scm" - "test-display.scm") + "test-info.scm") + +(define test-display-textual% + (class* object% () + + (init-field (current-rep #f)) + + (define test-info #f) + (define/pubment (install-info t) + (set! test-info t) + (inner (void) install-info t)) + + (define/public (display-results) + (send this insert-test-results test-info)) + + (define/pubment (insert-test-results test-info) + (let* ([style (send test-info test-style)] + [total-tests (send test-info tests-run)] + [failed-tests (send test-info tests-failed)] + [total-checks (send test-info checks-run)] + [failed-checks (send test-info checks-failed)] + [test-outcomes + (lambda (zero-message) + (printf "~a" + (cond [(zero? total-tests) zero-message] + [(= 1 total-tests) "Ran 1 test.\n"] + [else (format "Ran ~a tests.\n" total-tests)])) + (when (> total-tests 0) + (printf "~a" + (cond + [(and (zero? failed-tests) (= 1 total-tests)) + "Test passed!\n\n"] + [(zero? failed-tests) "All tests passed!\n\n"] + [(= failed-tests total-tests) "0 tests passed.\n"] + [else "~a of the ~a tests failed.\n\n"]))))] + [check-outcomes + (lambda (zero-message) + (printf "~a" + (cond + [(zero? total-checks) zero-message] + [(= 1 total-checks) "Ran 1 check.\n"] + [else (format "Ran ~a checks.\n" total-checks)])) + (when (> total-checks 0) + (printf "~a" + (cond + [(and (zero? failed-checks) (= 1 total-checks)) + "Check passed!\n\n"] + [(zero? failed-checks) "All checks passed!\n\n"] + [(= failed-checks total-checks) "0 checks passed.\n"] + [else (format "~a of the ~a checks failed.\n\n" + failed-checks total-checks)]))))]) + (case style + [(test-require) + (test-outcomes "This program must be tested!\n") + (check-outcomes "This program is unchecked!\n")] + [(check-require) + (check-outcomes "This program is unchecked!\n")] + [(test-basic) + (test-outcomes "") + (check-outcomes "")] + [else (check-outcomes "")]) + + (unless (and (zero? total-checks) (zero? total-tests)) + (inner (display-check-failures (send test-info failed-checks) + test-info) + insert-test-results test-info)))) + + (define/public (display-check-failures checks test-info) + (for ([failed-check (reverse checks)]) + (printf "~a" "\t") + (make-link (failed-check-msg failed-check) + (failed-check-src failed-check)) + (printf "~a" "\n"))) + + (define/public (next-line) (printf "~a" "\n\t")) + + ;; make-link: (listof (U string snip%)) src -> void + (define (make-link msg dest) + (for-each printf msg) + (printf (format-src dest))) + + (define (format-src src) + (let ([src-file car] + [src-line cadr] + [src-col caddr]) + (string-append + (cond [(symbol? (src-file src)) " At "] + [(path? (src-file src)) + (string-append " In " (path->string (src-file src)) " at ")] + [else " At "]) + "line " (number->string (src-line src)) + " column " (number->string (src-col src))))) + + (super-instantiate ()))) (define test-engine% (class* object% () (field [test-info #f] [test-display #f]) - (define display-class test-display%) + (define display-class test-display-textual%) (define display-rep #f) (define display-event-space #f) @@ -62,4 +154,4 @@ (define/pubment (run-testcase testcase) (inner (void) run-testcase testcase)))) -(provide test-engine%) +(provide test-engine% test-display-textual%)