Translate the messages from the test engine.

This requires some refactoring to move the relevant message generation
to test-display.scm.

svn: r14668

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)

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))
 

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 <at line ...> 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 <value>, contract <at ...>
+  (test-engine-got "got")
+
   (profjWizward-insert-java-class "Insert Java Class")
   (profjWizard-insert-java-union "Insert Java Union")
   

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 <at line ...> to blame: procedure <at line ...>
+  (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 <value>, contract <at ...>
+  (test-engine-got "bekam")
+
   (profjWizward-insert-java-class "Java-Klasse einfügen")
   (profjWizard-insert-java-union "Java-Vereinigung einfügen")
 

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))
 

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. ~<w> 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))))))
+	  
+

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))

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]

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)

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")))
+