diff --git a/collects/deinprogramm/contract/contract-test-display.ss b/collects/deinprogramm/contract/contract-test-display.ss index ab2907edf2..72b2abe941 100644 --- a/collects/deinprogramm/contract/contract-test-display.ss +++ b/collects/deinprogramm/contract/contract-test-display.ss @@ -12,6 +12,7 @@ string-constants (lib "test-engine/test-info.scm") (lib "test-engine/test-engine.scm") + (lib "test-engine/print.ss") deinprogramm/contract/contract deinprogramm/contract/contract-test-engine) @@ -54,6 +55,25 @@ (send drscheme-frame display-test-panel content) (send curr-win show #f))))))) + (define/public (display-success-summary port count) + (unless (test-silence) + (display (case count + [(0) (string-constant test-engine-0-tests-passed)] + [(1) (string-constant test-engine-1-test-passed)] + [(2) (string-constant test-engine-both-tests-passed)] + [else (format (string-constant test-engine-all-n-tests-passed) + count)]) + port))) + + (define/public (display-untested-summary port) + (unless (test-silence) + (fprintf port (string-constant test-engine-should-be-tested)) + (display "\n" port))) + + (define/public (display-disabled-summary port) + (display (string-constant test-engine-tests-disabled) port) + (display "\n" port)) + (define/public (display-results) (let* ([curr-win (and current-tab (send current-tab get-test-window))] [window (or curr-win (make-object test-window%))] @@ -90,28 +110,34 @@ (send editor insert (cond [(zero? total-checks) zero-message] - [(= 1 total-checks) "Ran 1 check.\n"] - [else (format "Ran ~a checks.\n" total-checks)])) + [(= 1 total-checks) + (string-append (string-constant test-engine-ran-1-check) "\n")] + [else (format (string-append (string-constant test-engine-ran-n-checks) "\n") + total-checks)])) (when (> total-checks 0) (send editor insert (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" + (string-append (string-constant test-engine-1-check-passed) "\n\n")] + [(zero? failed-checks) + (string-append (string-constant test-engine-all-checks-passed) "\n\n")] + [(= failed-checks total-checks) + (string-append (string-constant test-engine-0-checks-passed) "\n")] + [else (format (string-append (string-constant test-engine-m-of-n-checks-failed) "\n\n") failed-checks total-checks)]))) (send editor insert (cond ((null? violated-contracts) - "No contract violations!\n\n") + (string-append (string-constant test-engine-no-contract-violations) "\n\n")) + ((null? (cdr violated-contracts)) + (string-append (string-constant test-engine-1-contract-violation) "\n\n")) (else - (format "~a contract violations.\n\n" + (format (string-append (string-constant test-engine-n-contract-violations) "\n\n") (length violated-contracts))))) )]) (case style [(check-require) - (check-outcomes "This program is unchecked!\n")] + (check-outcomes (string-append (string-constant test-engine-is-unchecked) "\n"))] [else (check-outcomes "")]) (unless (and (zero? total-checks) @@ -126,24 +152,24 @@ (define/public (display-check-failures checks editor test-info src-editor) (when (pair? checks) - (send editor insert "Check failures:\n")) + (send editor insert (string-append (string-constant test-engine-check-failures) "\n"))) (for ([failed-check (reverse checks)]) (send editor insert "\t") (if (failed-check-exn? failed-check) (make-error-link editor - (failed-check-msg failed-check) + (failed-check-reason failed-check) (failed-check-exn? failed-check) - (failed-check-src failed-check) + (check-fail-src (failed-check-reason failed-check)) src-editor) (make-link editor - (failed-check-msg failed-check) - (failed-check-src failed-check) + (failed-check-reason failed-check) + (check-fail-src (failed-check-reason failed-check)) src-editor)) (send editor insert "\n"))) (define/public (display-contract-violations violations editor test-info src-editor) (when (pair? violations) - (send editor insert "Contract violations:\n")) + (send editor insert (string-append (string-constant test-engine-contract-violations) "\n"))) (for-each (lambda (violation) (send editor insert "\t") (make-contract-link editor violation src-editor) @@ -154,9 +180,9 @@ ;Inserts a newline and a tab into editor (define/public (next-line editor) (send editor insert "\n\t")) - ;; make-link: text% (listof (U string snip%)) src editor -> void - (define (make-link text msg dest src-editor) - (insert-messages text msg) + ;; make-link: text% check-fail src editor -> void + (define (make-link text reason dest src-editor) + (display-reason text reason) (let ((start (send text get-end-position))) (send text insert (format-src dest)) (when (and src-editor current-rep) @@ -165,12 +191,53 @@ (lambda (t s e) (highlight-check-error dest src-editor)) #f #f) (set-clickback-style text start "royalblue")))) - - ;; make-error-link: text% (listof (U string snip%)) exn src editor -> void - (define (make-error-link text msg exn dest src-editor) - (make-link text msg dest src-editor) + + (define (display-reason text fail) + (let* ((print-string + (lambda (m) + (send text insert m))) + (print-formatted + (lambda (m) + (when (is-a? m snip%) + (send m set-style (send (send text get-style-list) + find-named-style "Standard"))) + (send text insert m))) + (print + (lambda (fstring . vals) + (apply print-with-values fstring print-string print-formatted vals))) + (formatter (check-fail-format fail))) + (cond + [(unexpected-error? fail) + (print (string-constant test-engine-check-encountered-error) + (formatter (unexpected-error-expected fail)) + (unexpected-error-message fail))] + [(unequal? fail) + (print (string-constant test-engine-actual-value-differs-error) + (formatter (unequal-test fail)) + (formatter (unequal-actual fail)))] + [(outofrange? fail) + (print (string-constant test-engine-actual-value-not-within-error) + (formatter (outofrange-test fail)) + (outofrange-range fail) + (formatter (outofrange-actual fail)))] + [(incorrect-error? fail) + (print (string-constant test-engine-encountered-error-error) + (incorrect-error-expected fail) + (incorrect-error-message fail))] + [(expected-error? fail) + (print (string-constant test-engine-expected-error-error) + (formatter (expected-error-value fail)) + (expected-error-message fail))] + [(message-error? fail) + (for-each print-formatted (message-error-strings fail))]) + (print-string "\n"))) + + ;; make-error-link: text% check-fail exn src editor -> void + (define (make-error-link text reason exn dest src-editor) + (make-link text reason dest src-editor) (let ((start (send text get-end-position))) - (send text insert "Trace error ") + (send text insert (string-constant test-engine-trace-error)) + (send text insert " ") (when (and src-editor current-rep) (send text set-clickback start (send text get-end-position) @@ -188,8 +255,16 @@ (define (make-contract-link text violation src-editor) (let* ((contract (contract-violation-contract violation)) (stx (contract-syntax contract)) - (srcloc (contract-violation-srcloc violation))) - (insert-messages text (contract-violation-messages violation)) + (srcloc (contract-violation-srcloc violation)) + (message (contract-violation-message violation))) + (cond + ((string? message) + (send text insert message)) + ((contract-got? message) + (insert-messages text (list (string-constant test-engine-got) + " " + ((contract-got-format message) + (contract-got-value message)))))) (when srcloc (send text insert " ") (let ((source (srcloc-source srcloc)) @@ -205,13 +280,16 @@ (highlight-error line column pos span src-editor)) #f #f) (set-clickback-style text start "blue"))) - (send text insert ", contract ") + (send text insert ", ") + (send text insert (string-constant test-engine-contract)) + (send text insert " ") (format-clickable-syntax-src text stx src-editor) (cond ((contract-violation-blame violation) => (lambda (blame) (next-line text) - (send text insert "to blame: procedure ") + (send text insert (string-constant test-engine-to-blame)) + (send text insert " ") (format-clickable-syntax-src text blame src-editor)))))) (define (format-clickable-syntax-src text stx src-editor) @@ -243,18 +321,23 @@ (format-position (car src) (cadr src) (caddr src))) (define (format-position file line column) - (string-append - (if (path? file) - (let-values (((base name must-be-dir?) - (split-path file))) - (if (path? name) - (string-append " in " (path->string name) " at ") - "")) - "") - "at line " (cond [line => number->string] - [else "(unknown)"]) - " column " (cond [column => number->string] - [else "(unknown)"]))) + (let ([line (cond [line => number->string] + [else + (string-constant test-engine-unknown)])] + [col + (cond [column => number->string] + [else (string-constant test-engine-unknown)])]) + + (if (path? file) + (let-values (((base name must-be-dir?) + (split-path file))) + (if (path? name) + (format (string-constant test-engine-in-at-line-column) + (path->string name) line col) + (format (string-constant test-engine-at-line-column) + line col))) + (format (string-constant test-engine-at-line-column) + line col)))) (define (highlight-error line column position span src-editor) (when (and current-rep src-editor) diff --git a/collects/deinprogramm/contract/contract-test-engine.ss b/collects/deinprogramm/contract/contract-test-engine.ss index e62a6fdb15..8c86518af6 100644 --- a/collects/deinprogramm/contract/contract-test-engine.ss +++ b/collects/deinprogramm/contract/contract-test-engine.ss @@ -2,8 +2,9 @@ (provide build-contract-test-engine contract-violation? - contract-violation-obj contract-violation-contract contract-violation-messages - contract-violation-blame contract-violation-srcloc) + contract-violation-obj contract-violation-contract contract-violation-message + contract-violation-blame contract-violation-srcloc + contract-got? contract-got-value contract-got-format) (require scheme/class (lib "test-engine/test-engine.scm") @@ -18,7 +19,7 @@ (class* test-engine% () (super-instantiate ()) (inherit-field test-info test-display) - (inherit setup-info display-untested) + (inherit setup-info display-untested display-disabled) (define display-rep #f) (define display-event-space #f) @@ -72,18 +73,11 @@ [(mixed-results) (display-results display-rep display-event-space)])))) (else - (fprintf port "Tests disabled.\n")))) + (display-disabled port)))) (define/private (display-success port event-space count) (clear-results event-space) - (unless (test-silence) - (fprintf port "~a test~a passed!\n" - (case count - [(0) "Zero"] - [(1) "The only"] - [(2) "Both"] - [else (format "All ~a" count)]) - (if (= count 1) "" "s")))) + (send test-display display-success-summary port count)) (define/override (display-results rep event-space) (cond @@ -98,7 +92,9 @@ )) -(define-struct contract-violation (obj contract messages srcloc blame)) +(define-struct contract-got (value format)) + +(define-struct contract-violation (obj contract message srcloc blame)) (define contract-test-info% (class* test-info-base% () @@ -123,13 +119,12 @@ (make-srcloc source line col pos span)) mark))) (else #f))) - (messages - (if message - (list message) - (list "got " ((test-format) obj))))) + (message + (or message + (make-contract-got obj (test-format))))) (set! contract-violations - (cons (make-contract-violation obj contract messages srcloc blame) + (cons (make-contract-violation obj contract message srcloc blame) contract-violations))) (inner (void) contract-failed obj contract message)) diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index b3504fc66d..42971871d6 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -1363,7 +1363,63 @@ please adhere to these guidelines: ;;Following two appear in Scheme (Java, etc) menu, cause Tests to be Run automatically or not (test-engine-enable-tests "Enable Tests") (test-engine-disable-tests "Disable Tests") - + + (test-engine-ran-1-test "Ran 1 test.") + (test-engine-ran-1-check "Ran 1 check.") + ;; ditto, only plural + (test-engine-ran-n-tests "Ran ~a tests.") + (test-engine-ran-n-checks "Ran ~a checks.") + (test-engine-1-test-passed "The test passed!") + (test-engine-1-check-passed "The check passed!") + (test-engine-both-tests-passed "Both tests passed!") + (test-engine-both-checks-passed "Both checks passed!") + (test-engine-all-tests-passed "All tests passed!") + (test-engine-all-checks-passed "All checks passed!") + (test-engine-all-n-tests-passed "All ~a tests passed!") + (test-engine-all-n-checks-passed "All ~a checks passed!") + (test-engine-0-tests-passed "0 tests passed.") + (test-engine-0-checks-passed "0 checks passed.") + (test-engine-m-of-n-tests-failed "~a of the ~a tests failed.") + (test-engine-m-of-n-checks-failed "~a of the ~a checks failed.") + (test-engine-must-be-tested "This program must be tested!") + (test-engine-is-unchecked "This program is unchecked!") + (test-engine-tests-disabled "Tests disabled.") + (test-engine-should-be-tested "This program should be tested.") + (test-engine-at-line-column "at line ~a, column ~a") + (test-engine-in-at-line-column "in ~a, line ~a, column ~a") + ; as in "column (unknown)" + (test-engine-unknown "(unknown)") + (test-engine-trace-error "Trace error") + + ; The ~F is special marker for the offending values, which may be + ; printed specially in DrScheme. + (test-engine-check-encountered-error + "check-expect encountered the following error instead of the expected value, ~F. ~n :: ~a") + (test-engine-actual-value-differs-error + "Actual value ~F differs from ~F, the expected value.") + (test-engine-actual-value-not-within-error + "Actual value ~F is not within ~v of expected value ~F.") + (test-engine-encountered-error-error + "check-error encountered the following error instead of the expected ~a~n :: ~a") + (test-engine-expected-error-error + "check-error expected the following error, but instead received the value ~F.~n ~a") + + ; section header + (test-engine-check-failures "Check failures:") + ; section header + (test-engine-contract-violations "Contract violations:") + + ; part of one phrase "contract to blame: procedure <...> + (test-engine-contract "contract") + (test-engine-to-blame "to blame: procedure") + + (test-engine-no-contract-violations "No contract violations.") + (test-engine-1-contract-violation "1 contract violation.") + (test-engine-n-contract-violations "~a contract violations.") + + ; as in got , contract + (test-engine-got "got") + (profjWizward-insert-java-class "Insert Java Class") (profjWizard-insert-java-union "Insert Java Union") diff --git a/collects/string-constants/german-string-constants.ss b/collects/string-constants/german-string-constants.ss index 2280eb68d0..c93aa957ed 100644 --- a/collects/string-constants/german-string-constants.ss +++ b/collects/string-constants/german-string-constants.ss @@ -1267,6 +1267,65 @@ (test-engine-enable-tests "Test aktivieren") (test-engine-disable-tests "Tests deaktivieren Tests") + (test-engine-ran-1-test "1 Test gelaufen.") + (test-engine-ran-1-check "1 Check gelaufen.") + ;; ditto, only plural + (test-engine-ran-n-tests "~a Tests gelaufen.") + (test-engine-ran-n-checks "~a Checks gelaufen.") + (test-engine-1-test-passed "Der eine Test ist bestanden!") + (test-engine-1-check-passed "Der eine Check ist bestanden!") + (test-engine-both-tests-passed "Beide Tests bestanden!") + (test-engine-both-checks-passed "Beide Checks bestanden!") + (test-engine-all-tests-passed "Alle Tests bestanden!") + (test-engine-all-checks-passed "Alle Checks bestanden!") + (test-engine-all-n-tests-passed "Alle ~a Tests bestanden!") + (test-engine-all-n-checks-passed "Alle ~a Checks bestanden!") + (test-engine-0-tests-passed "0 Tests bestanden.") + (test-engine-0-checks-passed "0 Checks bestanden.") + (test-engine-m-of-n-tests-failed "~a der ~a Tests fehlgeschlagen.") + (test-engine-m-of-n-checks-failed "~a der ~a Checks fehlgeschlagen.") + (test-engine-must-be-tested "Dieses Programm muss noch getestet werden!") + (test-engine-is-unchecked "Dieses Programm hat keine Checks!") + (test-engine-tests-disabled "Tests deaktiviert.") + (test-engine-zero-tests-passed "Keine Tests waren erfolgreich!") + (test-engine-the-only-test-passed "Der einzige Test war erfolgreich.") + (test-engine-both-tests-passed "Beide Tests waren erfolgreich.") + ; ~a is replaced by count + (test-engine-all-tests-passed "Alle ~a Tests waren erfolgreich!") + (test-engine-should-be-tested "Dieses Programm sollte getestet werden.") + (test-engine-at-line-column "in Zeile ~a, Spalte ~a") + (test-engine-in-at-line-column "in ~a, Zeile ~a, Spalte ~a") + ; as in "column (unknown)" + (test-engine-unknown "(unbekannt)") + (test-engine-trace-error "Trace-Fehler") + + (test-engine-check-encountered-error + "check-expect bekam den folgenden Fehler statt des erwarteten Werts, ~F. ~n :: ~a") + (test-engine-actual-value-differs-error + "Der tatsächliche Wert ~F ist nicht der erwartete Wert ~F.") + (test-engine-actual-value-not-within-error + "Der tatsächliche Wert ~F ist nicht innerhalb von ~v des erwarteten Werts ~F.") + (test-engine-encountered-error-error + "check-error bekam den folgenden Fehler anstatt des erwarteten ~a~n :: ~a") + (test-engine-expected-error-error + "check-error erwartete den folgenden Fehler, bekam aber den Wert ~F.~n ~a") + + ; section header + (test-engine-check-failures "Check-Fehler:") + ; section header + (test-engine-contract-violations "Vertragsverletzungen:") + + ; part of one phrase "contract to blame: procedure + (test-engine-contract "Vertrag") + (test-engine-to-blame "verantwortlich: Prozedur") + + (test-engine-no-contract-violations "Keine Vertragsverletzungen.") + (test-engine-1-contract-violation "1 Vertragsverletzung.") + (test-engine-n-contract-violations "~a Vertragsverletzungen.") + + ; as in got , contract + (test-engine-got "bekam") + (profjWizward-insert-java-class "Java-Klasse einfügen") (profjWizard-insert-java-union "Java-Vereinigung einfügen") diff --git a/collects/test-engine/java-tests.scm b/collects/test-engine/java-tests.scm index 81ef2bfc69..2425a3f803 100644 --- a/collects/test-engine/java-tests.scm +++ b/collects/test-engine/java-tests.scm @@ -174,7 +174,7 @@ (when current-testcase (set-tc-stat-checks! current-testcase - (cons (make-failed-check src msg exn) + (cons (make-failed-check msg exn) (tc-stat-checks current-testcase)))) (inner (void) check-failed msg src exn)) diff --git a/collects/test-engine/print.ss b/collects/test-engine/print.ss new file mode 100644 index 0000000000..7f66297c30 --- /dev/null +++ b/collects/test-engine/print.ss @@ -0,0 +1,31 @@ +#lang scheme/base + +(provide print-with-values) + +; This is like the printf procedures---it uses `print-string' to print +; the string portions, and print-formatted to print the values +; referenced via ~F. ~ is not supported. + +(define (print-with-values fstring print-string print-formatted + . vals) + (let ((size (string-length fstring))) + (let loop ((start 0) + (i 0) + (vals vals) + (seen-vals '())) ; reversed + (cond + ((>= i size) + (print-string (apply format (substring fstring start i) (reverse seen-vals)))) + ((char=? (string-ref fstring i) #\~) + (case (string-ref fstring (+ 1 i)) + ((#\n #\~) (loop start (+ 1 i) vals seen-vals)) + ((#\F #\f) + (print-string (apply format (substring fstring start i) (reverse seen-vals))) + (print-formatted (car vals)) + (loop (+ 2 i) (+ 2 i) (cdr vals) '())) + (else + (loop start (+ 2 i) (cdr vals) (cons (car vals) seen-vals))))) + (else + (loop start (+ 1 i) vals seen-vals)))))) + + diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss index 89e72076dd..6eacf70146 100644 --- a/collects/test-engine/scheme-tests.ss +++ b/collects/test-engine/scheme-tests.ss @@ -5,6 +5,7 @@ scheme/match (only scheme/base for) "test-engine.scm" + "test-info.scm" ) (require-for-syntax stepper/private/shared) @@ -40,19 +41,6 @@ (define-for-syntax CHECK-ERROR-DEFN-STR CHECK-EXPECT-DEFN-STR) -(define-struct check-fail (src)) - -;; (make-unexpected-error src string exn) -(define-struct (unexpected-error check-fail) (expected message exn)) -;; (make-unequal src scheme-val scheme-val) -(define-struct (unequal check-fail) (test actual)) -;; (make-outofrange src scheme-val scheme-val inexact) -(define-struct (outofrange check-fail) (test actual range)) -;; (make-incorrect-error src string exn) -(define-struct (incorrect-error check-fail) (expected message exn)) -;; (make-expected-error src string scheme-val) -(define-struct (expected-error check-fail) (message value)) - ;; check-expect-maker : syntax? syntax? (listof syntax?) symbol? -> syntax? ;; the common part of all three test forms. (define-for-syntax (check-expect-maker @@ -121,7 +109,7 @@ (error-check (lambda (v) (not (procedure? v))) actual FUNCTION-FMT #f) (send (send test-info get-info) add-check) (run-and-check (lambda (v1 v2 _) (beginner-equal? v1 v2)) - (lambda (src v1 v2 _) (make-unequal src v1 v2)) + (lambda (src format v1 v2 _) (make-unequal src format v1 v2)) test actual #f src test-info 'check-expect)) @@ -158,14 +146,14 @@ (let ([result (with-handlers ([exn? (lambda (e) (or (equal? (exn-message e) error) - (make-incorrect-error src error + (make-incorrect-error src (test-format) error (exn-message e) e)))]) (let ([test-val (test)]) - (make-expected-error src error test-val)))]) + (make-expected-error src (test-format) error test-val)))]) (if (check-fail? result) (begin (send (send test-info get-info) check-failed - (check->message result) (check-fail-src result) + result (check-fail-src result) (and (incorrect-error? result) (incorrect-error-exn result))) #f) #t))) @@ -180,14 +168,14 @@ ;; run-and-check: (scheme-val scheme-val scheme-val -> boolean) -;; (scheme-val scheme-val scheme-val -> check-fail) +;; (src format scheme-val scheme-val scheme-val -> check-fail) ;; ( -> scheme-val) scheme-val scheme-val object symbol? -> void (define (run-and-check check maker test expect range src test-info kind) (match-let ([(list result result-val exn?) (with-handlers ([exn? (lambda (e) (raise e) (let ([display (error-display-handler)]) #;((error-display-handler) (exn-message e) e) - (list (make-unexpected-error src expect + (list (make-unexpected-error src (test-format) expect (exn-message e) e) 'error (lambda () (printf "~a~n" e) @@ -195,42 +183,13 @@ (let ([test-val (test)]) (cond [(check expect test-val range) (list #t test-val #f)] [else - (list (maker src test-val expect range) test-val #f)])))]) + (list (maker src (test-format) test-val expect range) test-val #f)])))]) (cond [(check-fail? result) - (send (send test-info get-info) check-failed (check->message result) (check-fail-src result) exn?) + (send (send test-info get-info) check-failed result (check-fail-src result) exn?) #f] [else #t]))) - -(define (check->message fail) - (cond - [(unexpected-error? fail) - (list "check encountered the following error instead of the expected value, " - ((test-format) (unexpected-error-expected fail)) - (format ". ~n :: ~a~n" (unexpected-error-message fail)))] - [(unequal? fail) - (list "Actual value " - ((test-format) (unequal-test fail)) - " differs from " - ((test-format) (unequal-actual fail)) - ", the expected value.\n")] - [(outofrange? fail) - (list "Actual value " - ((test-format) (outofrange-test fail)) - (format " is not within ~v of expected value " (outofrange-range fail)) - ((test-format) (outofrange-actual fail)) - ".\n")] - [(incorrect-error? fail) - (list (format "check-error encountered the following error instead of the expected ~a~n :: ~a ~n" - (incorrect-error-expected fail) - (incorrect-error-message fail)))] - [(expected-error? fail) - (list "check-error expected the following error, but instead received the value " - ((test-format) (expected-error-value fail)) - (format ".~n ~a~n" (expected-error-message fail)))])) - - (define (builder) (let ([te (build-test-engine)]) (namespace-set-variable-value! 'test~object te (current-namespace)) diff --git a/collects/test-engine/test-display.scm b/collects/test-engine/test-display.scm index 28c6632601..3e73771cd1 100644 --- a/collects/test-engine/test-display.scm +++ b/collects/test-engine/test-display.scm @@ -6,7 +6,8 @@ framework string-constants "test-info.scm" - "test-engine.scm") + "test-engine.scm" + "print.ss") (define test-display% (class* object% () @@ -45,8 +46,26 @@ (when current-tab (send current-tab current-test-editor content)) (when (and curr-win (docked?)) (send drscheme-frame display-test-panel content) - #;(send curr-win show #f)) - ))) + #;(send curr-win show #f))))) + + (define/public (display-success-summary port count) + (unless (test-silence) + (display (case count + [(0) (string-constant test-engine-0-tests-passed)] + [(1) (string-constant test-engine-1-test-passed)] + [(2) (string-constant test-engine-both-tests-passed)] + [else (format (string-constant test-engine-all-n-tests-passed) + count)]) + port))) + + (define/public (display-untested-summary port) + (unless (test-silence) + (display (string-constant test-engine-should-be-tested) port) + (display "\n" port))) + + (define/public (display-disabled-summary port) + (display (string-constant test-engine-tests-disabled) port) + (display "\n" port)) (define/public (display-results) (let* ([curr-win (and current-tab (send current-tab get-test-window))] @@ -80,49 +99,78 @@ [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) + [outcomes + (lambda (total failed zero-message ck?) (send editor insert (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) + [(zero? total) zero-message] + [(= 1 total) + (string-append + (if ck? + (string-constant test-engine-ran-1-check) + (string-constant test-engine-ran-1-test)) + "\n")] + [else + (format (string-append + (if ck? + (string-constant test-engine-ran-n-checks) + (string-constant test-engine-ran-n-tests)) + "\n") + total)])) + (when (> total 0) (send editor insert (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 (format "~a of the ~a tests failed.\n\n" failed-tests total-tests)]))))] - [check-outcomes - (lambda (zero-message ck) - (send editor insert - (cond - [(zero? total-checks) zero-message] - [(= 1 total-checks) (format "Ran 1 ~a.\n" ck)] - [else (format "Ran ~a ~as.\n" total-checks ck)])) - (when (> total-checks 0) - (send editor insert - (cond - [(and (zero? failed-checks) (= 1 total-checks)) - (format "The ~a passed!\n\n" ck)] - [(zero? failed-checks) (format "All ~as passed!\n\n" ck)] - [(= failed-checks total-checks) (format "0 ~as passed.\n" ck)] - [else (format "~a of the ~a ~as failed.\n\n" - failed-checks total-checks ck)]))))]) + [(and (zero? failed) (= 1 total)) + (string-append (if ck? + (string-constant test-engine-1-check-passed) + (string-constant test-engine-1-test-passed)) + "\n\n")] + [(zero? failed) + (string-append (if ck? + (string-constant test-engine-all-checks-passed) + (string-constant test-engine-all-tests-passed)) + "\n\n")] + [(= failed total) + (string-append (if ck? + (string-constant test-engine-0-checks-passed) + (string-constant test-engine-0-tests-passed)) + "\n")] + [else + (format + (string-append (if ck? + (string-constant test-engine-m-of-n-checks-failed) + (string-constant test-engine-m-of-n-tests-failed)) + "\n\n") + failed total)]))))] + [check-outcomes/check + (lambda (zero-message) + (outcomes total-checks failed-checks + zero-message #t))] + [check-outcomes/test + (lambda (zero-message) + (outcomes total-checks failed-checks + zero-message #f))] + [test-outcomes + (lambda (zero-message) + (outcomes total-tests failed-tests + zero-message #f))]) (case style [(test-require) - (test-outcomes "This program must be tested!\n") - (check-outcomes "This program is unchecked!\n" "check")] + (test-outcomes + (string-append (string-constant test-engine-must-be-tested) "\n")) + (check-outcomes/check + (string-append (string-constant test-engine-is-unchecked) "\n"))] [(check-require) - (check-outcomes "This program is unchecked!\n" "check")] + (check-outcomes/check + (string-append (string-constant test-engine-is-unchecked) "\n"))] [(test-basic) (test-outcomes "") - (check-outcomes "" "check")] + (check-outcomes/check "")] [(test-check) - (check-outcomes "This program must be tested.\n" "test")] - [else (check-outcomes "" "check")]) + (check-outcomes/test + (string-append (string-constant test-engine-must-be-tested) + "\n"))] + [else (check-outcomes/check "")]) (unless (and (zero? total-checks) (zero? total-tests)) (inner (display-check-failures (send test-info failed-checks) @@ -134,13 +182,13 @@ (send editor insert "\t") (if (failed-check-exn? failed-check) (make-error-link editor - (failed-check-msg failed-check) + (failed-check-reason failed-check) (failed-check-exn? failed-check) - (failed-check-src failed-check) + (check-fail-src (failed-check-reason failed-check)) src-editor) (make-link editor - (failed-check-msg failed-check) - (failed-check-src failed-check) + (failed-check-reason failed-check) + (check-fail-src (failed-check-reason failed-check)) src-editor)) (send editor insert "\n"))) @@ -148,13 +196,9 @@ ;Inserts a newline and a tab into editor (define/public (next-line editor) (send editor insert "\n\t")) - ;; make-link: text% (listof (U string snip%)) src editor -> void - (define (make-link text msg dest src-editor) - (for ([m msg]) - (when (is-a? m snip%) - (send m set-style (send (send text get-style-list) - find-named-style "Standard"))) - (send text insert m)) + ;; make-link: text% check-fail src editor -> void + (define (make-link text reason dest src-editor) + (display-reason text reason) (let ((start (send text get-end-position))) (send text insert (format-src dest)) (when (and src-editor current-rep) @@ -170,12 +214,57 @@ start end #f) (send c set-delta-foreground "royalblue") (send text change-style c start end #f))))) + + (define (display-reason text fail) + (write (list 'display-reason fail (check-fail? fail) (message-error? fail)) + (current-error-port)) + (newline (current-error-port)) + + (let* ((print-string + (lambda (m) + (send text insert m))) + (print-formatted + (lambda (m) + (when (is-a? m snip%) + (send m set-style (send (send text get-style-list) + find-named-style "Standard"))) + (send text insert m))) + (print + (lambda (fstring . vals) + (apply print-with-values fstring print-string print-formatted vals))) + (formatter (check-fail-format fail))) + (cond + [(unexpected-error? fail) + (print (string-constant test-engine-check-encountered-error) + (formatter (unexpected-error-expected fail)) + (unexpected-error-message fail))] + [(unequal? fail) + (print (string-constant test-engine-actual-value-differs-error) + (formatter (unequal-test fail)) + (formatter (unequal-actual fail)))] + [(outofrange? fail) + (print (string-constant test-engine-actual-value-not-within-error) + (formatter (outofrange-test fail)) + (outofrange-range fail) + (formatter (outofrange-actual fail)))] + [(incorrect-error? fail) + (print (string-constant test-engine-encountered-error-error) + (incorrect-error-expected fail) + (incorrect-error-message fail))] + [(expected-error? fail) + (print (string-constant test-engine-expected-error-error) + (formatter (expected-error-value fail)) + (expected-error-message fail))] + [(message-error? fail) + (for-each print-formatted (message-error-strings fail))]) + (print-string "\n"))) - ;; make-error-link: text% (listof (U string snip%)) exn src editor -> void - (define (make-error-link text msg exn dest src-editor) - (make-link text msg dest src-editor) + ;; make-error-link: text% check-fail exn src editor -> void + (define (make-error-link text reason exn dest src-editor) + (make-link text reason dest src-editor) (let ((start (send text get-end-position))) - (send text insert "Trace error ") + (send text insert (string-constant test-engine-trace-error)) + (send text insert " ") (when (and src-editor current-rep) (send text set-clickback start (send text get-end-position) @@ -195,15 +284,22 @@ (let ([src-file car] [src-line cadr] [src-col caddr]) - (string-append - (cond - [(symbol? (src-file src)) (string-append " At ")] - [(path? (src-file src)) (string-append " In " (path->string (src-file src)) " at ")] - [(is-a? (src-file src) editor<%>) " At "]) - "line " (cond [(src-line src) => number->string] - [else "(unknown)"]) - " column " (cond [(src-col src) => number->string] - [else "(unknown)"])))) + (let ([line (cond [(src-line src) => number->string] + [else + (string-constant test-engine-unknown)])] + [col + (cond [(src-col src) => number->string] + [else (string-constant test-engine-unknown)])]) + (string-append + " " + (cond + [(or (symbol? (src-file src)) + (is-a? (src-file src) editor<%>)) + (format (string-constant test-engine-at-line-column) line col)] + [(path? (src-file src)) + (format (string-constant test-engine-in-at-line-column) + (path->string (src-file src)) + line col)]))))) (define (highlight-check-error srcloc src-editor) (let* ([src-pos cadddr] diff --git a/collects/test-engine/test-engine.scm b/collects/test-engine/test-engine.scm index 9a321a80e4..361837844c 100644 --- a/collects/test-engine/test-engine.scm +++ b/collects/test-engine/test-engine.scm @@ -71,17 +71,34 @@ (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)) + (make-link (failed-check-reason failed-check) + (check-fail-src (failed-check-reason failed-check))) (printf "~a" "\n"))) (define/public (report-success) (void)) + + (define/public (display-success-summary port count) + (unless (test-silence) + (fprintf port "~a test~a passed!\n" + (case count + [(0) "Zero"] + [(1) "The only"] + [(2) "Both"] + [else (format "All ~a" count)]) + (if (= count 1) "" "s")))) + (define (display-untested-summary port) + (unless (test-silence) + (fprintf port "This program should be tested.~n"))) + + (define (display-disabled-summary port) + (fprintf port "Tests disabled.\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) + ;; make-link: (listof (U check-fail (U string snip%))) src -> void + (define (make-link reason dest) + (print-reason display display reason) (printf (format-src dest))) (define (format-src src) @@ -142,24 +159,21 @@ [(mixed-results) (display-results display-rep display-event-space)]))] [else - (fprintf port "Tests disabled.\n")])) + (display-disabled port)])) (define/private (display-success port event count) (when event (parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event]) ((dynamic-require 'scheme/gui 'queue-callback) (lambda () (send test-display report-success))))) - (unless (test-silence) - (fprintf port "~a test~a passed!\n" - (case count - [(0) "Zero"] - [(1) "The only"] - [(2) "Both"] - [else (format "All ~a" count)]) - (if (= count 1) "" "s")))) + (send test-display display-success-summary port count)) + (define/public (display-untested port) - (unless (test-silence) - (fprintf port "This program should be tested.~n"))) + (send test-display display-untested-summary port)) + + (define/public (display-disabled port) + (send test-display display-disabled-summary port)) + (define/public (display-results rep event-space) (cond [(and rep event-space) diff --git a/collects/test-engine/test-info.scm b/collects/test-engine/test-info.scm index b7db3e200a..f2c2a694d6 100644 --- a/collects/test-engine/test-info.scm +++ b/collects/test-engine/test-info.scm @@ -1,11 +1,28 @@ #lang scheme/base -(require scheme/class) +(require scheme/class + "print.ss") (provide (all-defined-out)) -;; (make-failed-check src (listof (U string snip%)) (U #f exn)) -(define-struct failed-check (src msg exn?)) +;; (make-failed-check check-fail (U #f exn) +(define-struct failed-check (reason exn?)) + +(define-struct check-fail (src format)) + +;; (make-unexpected-error src format string exn) +(define-struct (unexpected-error check-fail) (expected message exn)) +;; (make-unequal src format scheme-val scheme-val) +(define-struct (unequal check-fail) (test actual)) +;; (make-outofrange src format scheme-val scheme-val inexact) +(define-struct (outofrange check-fail) (test actual range)) +;; (make-incorrect-error src format string exn) +(define-struct (incorrect-error check-fail) (expected message exn)) +;; (make-expected-error src format string scheme-val) +(define-struct (expected-error check-fail) (message value)) + +;; (make-message-error src format (listof string)) +(define-struct (message-error check-fail) (strings)) (define test-info-base% (class* object% () @@ -41,11 +58,18 @@ (set! total-tsts (add1 total-tsts)) (inner (void) add-test)) - ;; check-failed: (list (U string snip%)) src (U exn false) -> void + ;; check-failed: (U check-fail (list (U string snip%))) src (U exn false) -> void (define/pubment (check-failed msg src exn?) (set! failed-cks (add1 failed-cks)) - (set! failures (cons (make-failed-check src msg exn?) failures)) - (inner (void) check-failed msg src exn?)) + (let ((fail + ;; We'd like every caller to make a check-fail object, + ;; but some (such as ProfessorJ's run time) cannot because + ;; of phase problems. Therefore, do the coercion here. + (if (check-fail? msg) + msg + (make-message-error src #f msg)))) + (set! failures (cons (make-failed-check fail exn?) failures)) + (inner (void) check-failed fail src exn?))) (define/pubment (test-failed failed-info) (set! failed-tsts (add1 failed-tsts)) @@ -57,3 +81,36 @@ (for ([a analyses]) (send a analyze src vals))) (define/public (extract-info pred?) (filter pred? (map (lambda (a) (send a provide-info)) analyses))))) + +; helper for printing error messages +(define (print-reason print-string print-formatted fail) + (let ((print + (lambda (fstring . vals) + (apply print-with-values fstring print-string print-formatted vals))) + (formatter (check-fail-format fail))) + (cond + [(unexpected-error? fail) + (print "check-expect encountered the following error instead of the expected value, ~F. ~n :: ~a" + (formatter (unexpected-error-expected fail)) + (unexpected-error-message fail))] + [(unequal? fail) + (print "Actual value ~F differs from ~F, the expected value." + (formatter (unequal-test fail)) + (formatter (unequal-actual fail)))] + [(outofrange? fail) + (print "Actual value ~F is not within ~v of expected value ~F." + (formatter (outofrange-test fail)) + (format (outofrange-range fail)) + (formatter (outofrange-actual fail)))] + [(incorrect-error? fail) + (print "check-error encountered the following error instead of the expected ~a~n :: ~a" + (incorrect-error-expected fail) + (incorrect-error-message fail))] + [(expected-error? fail) + (print "check-error expected the following error, but instead received the value ~F.~n ~a" + (formatter (expected-error-value fail)) + (expected-error-message fail))] + [(message-error? fail) + (for-each print-formatted (message-error-strings fail))]) + (print-string "\n"))) +