Follow test-engine rewrite.

deinprogramm-signature/deinprogramm/quickcheck/quickcheck.rkt

@@ -1,6 +1,7 @@
 #lang scheme/base
 (provide check check-results make-config
 	 quickcheck quickcheck-results
+         make-result
 	 check-result? result-arguments-list
 	 choose-integer choose-real
 	 choose-ascii-char choose-ascii-letter choose-printable-ascii-char choose-char

deinprogramm/deinprogramm/DMdA/private/DMdA-langs.rkt

@@ -33,10 +33,12 @@
 	 lang/private/continuation-mark-key
          lang/private/rewrite-error-message
 
-	 (only-in test-engine/racket-gui make-formatter)
-	 test-engine/racket-tests
 	 lang/private/tp-dialog
-	 (lib "test-display.scm" "test-engine")
+         (only-in test-engine/racket-tests
+                  report-signature-violation! test-execute test)
+	 (except-in test-engine/test-engine signature-violation)
+	 test-engine/test-markup
+	 test-engine/test-display-gui
 	 deinprogramm/signature/signature
          lang/htdp-langs-interface
 	 )
@@ -198,27 +200,29 @@
                  (namespace-attach-module drs-namespace scheme-signature-module-name)
                  (namespace-require scheme-signature-module-name)
 
-		 ;; hack: the test-engine code knows about the test~object name; we do, too
-		 (namespace-set-variable-value! 'test~object (build-test-engine))
+                 (initialize-test-object!)
 		 ;; record signature violations with the test engine
 		 (signature-violation-proc
 		  (lambda (obj signature message blame)
-		    (cond
-		     ((namespace-variable-value 'test~object #f (lambda () #f))
-		      => (lambda (engine)
-			   (send (send engine get-info) signature-failed
-				 obj signature message blame))))))
-                 (scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace test-display%))
+                    (report-signature-violation! obj signature message blame)))
+                 (display-test-results-parameter
+                  (lambda (markup)
+                    (test-display-results! (drscheme:rep:current-rep)
+                                           drs-eventspace
+                                           markup)))
+                 (get-rewritten-error-message-parameter get-rewriten-error-message)
                  (test-execute tests-on?)
 		 (signature-checking-enabled?
 		  (if (preferences:default-set? 'signatures:enable-checking?) ; Signatures tool not present
 		      (preferences:get 'signatures:enable-checking?)
 		      #t))
-                 (test-format (make-formatter (lambda (v o)
-						(render-value/format (if (procedure? v)
-									 generic-proc
+                 (render-value-parameter (λ (v)
+                                           (let ([o (open-output-string)])
+                                             (render-value/format (if (procedure? v)
+                                                                      generic-proc
 									 v)
-								     settings o 40))))
+                                                                  settings o 40)
+                                             (get-output-string o))))
 		 )))
             (super on-execute settings run-in-user-thread)
 
@@ -754,25 +758,25 @@
 
           (define/override (front-end/interaction port settings)
             (let ([reader (get-reader)] ;; DeinProgramm addition:
-					;; needed for test boxes; see
-					;; the code in
-					;; collects/drracket/private/language.rkt
-		  [start? #t]
-                  [done? #f])
+                  ;; needed for test boxes; see
+                  ;; the code in
+                  ;; collects/drracket/private/language.rkt
+                  [done? #f]
+                  [test-object (test-object-copy (current-test-object))])
               (λ ()
                 (cond
-		  [start?
-		   (set! start? #f)
-		   #'(#%plain-app reset-tests)]
                   [done? eof]
                   [else
                    (let ([ans (reader (object-name port) port)])
                      (cond
                        [(eof-object? ans)
-                        (set! done? #t)
-                        #`(test)]
-                       [else
-                        ans]))]))))
+                        (if (test-object=? test-object (current-test-object))
+                            eof
+                            (begin
+                              ; only retest if something has changed
+                              (set! done? #t)
+                              #`(test)))]
+                       [else ans]))]))))
 
           (define/augment (capability-value key)
             (case key

deinprogramm/deinprogramm/DMdA/private/primitives.rkt

@@ -3,8 +3,6 @@
 (require syntax/docprovide)
 
 (require test-engine/racket-tests
-	 (lib "test-info.scm" "test-engine")
-	 test-engine/racket-tests
 	 scheme/class)
 
 (require deinprogramm/signature/module-begin

deinprogramm/deinprogramm/private/runtime.rkt

@@ -0,0 +1,83 @@
+#lang racket/base
+(require mzlib/pconvert
+         racket/pretty
+         lang/private/set-result
+         deinprogramm/sdp/private/rewrite-error-message
+         mrlib/image-core
+         racket/snip
+         racket/class
+         (only-in test-engine/test-markup get-rewritten-error-message-parameter)
+         (only-in test-engine/racket-tests report-signature-violation!)
+         (only-in deinprogramm/signature/signature signature-violation-proc)
+         htdp/bsl/print-width) ; FIXME: might want to have our own
+
+(provide configure)
+
+(define (configure options)
+  ;; Set print-convert options:
+  (booleans-as-true/false #f)
+  (print-boolean-long-form #f)
+  (constructor-style-printing #f)
+  (add-make-prefix-to-constructor #f)
+  (abbreviate-cons-as-list #t)
+  (current-print-convert-hook
+   (let ([ph (current-print-convert-hook)])
+     (lambda (val basic sub)
+       (cond
+         [(is-image? val) val]
+         [else (ph val basic sub)]))))
+  (use-named/undefined-handler
+   (lambda (x)
+     (and (memq 'use-function-output-syntax options)
+          (procedure? x)
+          (object-name x))))
+  (named/undefined-handler
+   (lambda (x)
+     (string->symbol
+      (format "function:~a" (object-name x)))))
+  ;; Set pretty-print options:
+  (pretty-print-show-inexactness #t)
+  (pretty-print-exact-as-decimal #t)
+  (define img-str "#<image>")
+  (define (is-image? val)
+    (or (is-a? val image%)         ;; 2htdp/image
+        (is-a? val image-snip%)))  ;; literal image constant
+  (show-sharing (memq 'show-sharing options))
+
+  ;; Set print handlers to use print-convert and pretty-write:
+  (define (set-handlers thunk)
+    (parameterize ([pretty-print-print-hook
+                    (let ([oh (pretty-print-print-hook)])
+                      (λ (val display? port)
+                        (if (and (not (port-writes-special? port))
+                                 (is-image? val))
+                            (begin (display img-str port)
+                                   (string-length img-str))
+                            (oh val display? port))))]
+                   [pretty-print-size-hook
+                    (let ([oh (pretty-print-size-hook)])
+                      (λ (val display? port)
+                        (if (and (not (port-writes-special? port))
+                                 (is-image? val))
+                            (string-length img-str)
+                            (oh val display? port))))])
+      (thunk)))
+  (get-rewritten-error-message-parameter get-rewriten-error-message)
+  (error-display-handler
+   (let ([o-d-h (error-display-handler)])
+     (λ (msg exn)
+       (define x (get-rewriten-error-message exn))
+       (o-d-h x exn))))
+  (let ([orig (global-port-print-handler)])
+    (global-port-print-handler
+     (lambda (val port [depth 0])
+       (parameterize ([global-port-print-handler orig])
+         (let ([val (print-convert val)])
+           (set-handlers
+            (λ ()
+              (parameterize ([pretty-print-columns (htdp-print-columns)])
+                (pretty-write val port)))))))))
+
+  (signature-violation-proc
+   (lambda (obj signature message blame)
+     (report-signature-violation! obj signature message blame))))

deinprogramm/deinprogramm/sdp/private/primitives.rkt

@@ -2,9 +2,11 @@
 
 (require syntax/docprovide)
 
-(require test-engine/racket-tests
-	 (lib "test-info.scm" "test-engine")
+(require (only-in test-engine/test-engine
+                  add-failed-check! failed-check
+                  property-error property-fail)
 	 test-engine/racket-tests
+         test-engine/srcloc
 	 scheme/class)
 
 (require deinprogramm/signature/module-begin
@@ -1151,33 +1153,31 @@
     (_ (raise-sdp-syntax-error #f "`check-property' erwartet einen einzelnen Operanden"
 			       stx))))
 
-(define (check-property-error test src-info test-info)
-  (let ((info (send test-info get-info)))
-    (send info add-check)
-    (with-handlers ((exn:fail?
-		     (lambda (e)
-		       (send info property-error e src-info)
-		       (raise e))))
-      (call-with-values
-	  (lambda ()
-	    (with-handlers
-		((exn:assertion-violation?
-		  (lambda (e)
-		    ;; minor kludge to produce comprehensible error message
-		    (if (eq? (exn:assertion-violation-who e) 'coerce->result-generator)
-			(raise (make-exn:fail (string-append "Wert muß Eigenschaft oder boolesch sein: "
-							     ((error-value->string-handler)
-							      (car (exn:assertion-violation-irritants e))
-							      100))
-					      (exn-continuation-marks e)))
-			(raise e)))))
-	      (quickcheck-results (test))))
-	(lambda (ntest stamps result)
-	  (if (check-result? result)
-	      (begin
-		(send info property-failed result src-info)
-		#f)
-	      #t))))))
+(define (check-property-error test srcloc)
+  (with-handlers ((exn:fail?
+                   (lambda (e)
+                     (add-failed-check! (failed-check (property-error srcloc e)
+                                                      (exn-srcloc e))))))
+    (call-with-values
+     (lambda ()
+       (with-handlers
+           ((exn:assertion-violation?
+             (lambda (e)
+               ;; minor kludge to produce comprehensible error message
+               (if (eq? (exn:assertion-violation-who e) 'coerce->result-generator)
+                   (raise (make-exn:fail (string-append "Wert muß Eigenschaft oder boolesch sein: "
+                                                        ((error-value->string-handler)
+                                                         (car (exn:assertion-violation-irritants e))
+                                                         100))
+                                         (exn-continuation-marks e)))
+                   (raise e)))))
+         (quickcheck-results (test))))
+     (lambda (ntest stamps result)
+       (if (check-result? result)
+           (begin
+             (add-failed-check! (failed-check (property-fail srcloc result) #f))
+             #f)
+           #t)))))
 
 (define (expect v1 v2)
   (quickcheck:property () (teach-equal? v1 v2)))

deinprogramm/deinprogramm/sdp/private/rewrite-error-message.rkt

@@ -24,7 +24,12 @@
   (exn:fail:contract? exn))
 
 (define (ensure-number n-or-str)
-  (if (string? n-or-str) (string->number n-or-str) n-or-str))
+  (cond
+    ((number? n-or-str)
+     n-or-str)
+    ((string=? n-or-str "no") 0)
+    ((string=? n-or-str "none") 0)
+    (else (string->number n-or-str))))
 
 (define (plural-e n)
   (if (> (ensure-number n) 1) "e" ""))
@@ -44,7 +49,7 @@
   (define arity:n (ensure-number arity))
   (define found:n (ensure-number found))
   (define fn-is-large (> arity:n found:n))
-  (format "~a~a erwartet ~a~a~a Argument~a, aber ~a~a gefunden"
+  (format "~a~a ~a~a~a Argument~a erwartet, aber ~a~a gefunden"
           (or name "") (if name ":" "")
           (if at-least "mindestens " "")
           (if (or (= arity:n 0) fn-is-large) "" "nur ")
@@ -139,6 +144,10 @@
                 (lambda (all one two three) (argcount-error-message one two three #t)))
           (list #px"([^\n]*): arity mismatch;\n[^\n]*\n  expected[^:]*: (\\d+)\n  given[^:]*: (\\d+)(?:\n  arguments[.][.][.]:(?:\n   [^\n]*)*)?"
                 (lambda (all one two three) (argcount-error-message one two three)))
+          ;; see argcount-error-message/stx in racket-tests
+          (list #px"([^\n]*): expects (only )?(at least )?(\\d+|no) arguments?, but found (only )?(none|\\d+)"
+                (lambda (all name _only at-least expects _only2 found)
+                  (argcount-error-message name expects found (and at-least #t))))
 	  (list #px"([^\n]*): expects( at least)? (\\d+) arguments, but found( only)? (\\d+)"
                 (lambda (all one two three four five) (argcount-error-message one three five two)))
 	  (list #px"contract violation\n  expected: (.*?)\n  given: ([^\n]*)(?:\n  argument position: ([^\n]*))?"
@@ -185,3 +194,22 @@
   (if (exn:fail:contract? exn)
       (rewrite-contract-error-message (exn-message exn))
       (rewrite-misc-error-message (exn-message exn))))
+
+(module+ test
+  (require rackunit)
+
+  (check-equal? (rewrite-contract-error-message "foo: expects only 3 arguments, but found 4")
+                "foo: nur 3 Argumente erwartet, aber 4 gefunden")
+  (check-equal? (rewrite-contract-error-message "foo: expects 5 arguments, but found only 4")
+                "foo: 5 Argumente erwartet, aber nur 4 gefunden")
+  (check-equal? (rewrite-contract-error-message "foo: expects at least 5 arguments, but found only 4")
+                "foo: mindestens 5 Argumente erwartet, aber nur 4 gefunden")
+  (check-equal? (rewrite-contract-error-message "foo: expects no argument, but found 4")
+                "foo: kein Argument erwartet, aber 4 gefunden")
+  (check-equal? (rewrite-contract-error-message "foo: expects 1 argument, but found none")
+                "foo: 1 Argument erwartet, aber keins gefunden")
+  (check-equal? (rewrite-contract-error-message "foo: expects at least 1 argument, but found none")
+                "foo: mindestens 1 Argument erwartet, aber keins gefunden"))
+
+
+