fixed source location reporting, test annotation; Rackety tests

pkgs/htdp-pkgs/htdp-lib/test-engine/racket-tests.rkt

@@ -153,18 +153,33 @@
     [_ (raise-syntax-error 'check-expect (argcount-error-message/stx 2 stx) stx)]))
 
 ;; checking random values 
-(define-syntax-rule 
+(define-syntax (check-random stx)
-  (check-random e1 e2)
+  (syntax-case stx ()
-  (begin
+    [(check-random e1 e2)
+     (let ([test
+	     #`(lambda (rng k)
+		 (parameterize ((current-pseudo-random-generator rng)) (random-seed k)
+		   e1))]
+	   [actuals
+	     (list
+	       #`(lambda (rng k)
+		   (parameterize ((current-pseudo-random-generator rng)) (random-seed k)
+		     e2)))])
+;; ---------------------------------------------------------------------------------------------------
+       (check-expect-maker stx #'check-random-values test actuals 'comes-from-check-expect))]))
+
+;; check-values-expected: (-> scheme-val) (-> nat scheme-val) src test-engine -> void
+(define (check-random-values test actual-maker src test-engine)
   (define rng (make-pseudo-random-generator))
   (define k (modulo (current-milliseconds) (sub1 (expt 2 31))))
-    (check-expect
+  (define actual (actual-maker rng k))
-     (parameterize ((current-pseudo-random-generator rng))
+  (error-check (lambda (v) (if (number? v) (exact? v) #t))
-       (random-seed k)
+               actual INEXACT-NUMBERS-FMT #t)
-       e1)
+  (error-check (lambda (v) (not (procedure? v))) actual FUNCTION-FMT #f)
-     (parameterize ((current-pseudo-random-generator rng))
+  (send (send test-engine get-info) add-check)
-       (random-seed k)
+  (run-and-check (lambda (v1 v2 _) (teach-equal? v1 v2))
-       e2))))
+                 (lambda (src format v1 v2 _) (make-unequal src format v1 v2))
+                 (lambda () ((test) rng k)) actual #f src test-engine 'check-expect))
 
 ;; check-values-expected: (-> scheme-val) scheme-val src test-engine -> void
 (define (check-values-expected test actual src test-engine)

pkgs/htdp-pkgs/htdp-test/tests/test-engine/TestEngineTest.rkt

@@ -1,7 +1,7 @@
 ;; The first three lines of this file were inserted by DrRacket. They record metadata
 ;; about the language level of this file in a form that our tools can easily process.
 #reader(lib "htdp-advanced-reader.ss" "lang")((modname TestEngineTest) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #t #t none #f ())))
-;;Expect 37 checks, 17 failures
+;;Expect 42 checks, 19 failures
 
 (define (count f)
   (cond
@@ -31,21 +31,25 @@
 (check-within "hello" "Hello" .03) ;fails
 
 (define-struct ball (point rad color))
+(define blue-ball (make-ball (make-posn 1 3) 3.4 "blue"))
 
 (check-expect (make-ball 4 5 'blue) (make-ball 4 5 'blue))
 (check-expect (make-ball (make-posn 1 2) 3.5 'blue) (make-ball (make-posn 1 2) 3.5 'blue))
 (check-expect (make-ball 3 (make-posn 1 2) "blue") (make-ball (make-posn 1 2) 3.3 "blue")) ;fails
-(check-within (make-ball (make-posn 1 3) 3.4 "blue") (make-ball (make-posn 1 3) 3.3 "blue") .1)
+(check-within blue-ball (make-ball (make-posn 1 3) 3.3 "blue") .1)
-(check-within (make-ball (make-posn 1 3) 3.4 "blue") (make-ball (make-posn 1 3) 3.3 "blue") .01) ;fails
+(check-within blue-ball (make-ball (make-posn 1 3) 3.3 "blue") .01) ;fails
 
 (check-error (error 'test "hi") "test: hi")
 (check-error (/ 1 0) "/: division by zero")
 (check-error 3 "some message") ;fails
 (check-error (first empty) "another message") ;fails
 
-(check-member-of (make-ball 1 1 'blue) (make-ball 1 2 'blue) (make-ball 1 1 'blue) (make-ball 1 2 'red) 'red)
+(define (create n)
+  (make-ball n n 'blue))
+
+(check-member-of (create 1) (make-ball 1 2 'blue) (make-ball 1 1 'blue) (make-ball 1 2 'red) 'red)
 (check-member-of 1 1 1 1 1)
-(check-member-of (make-ball 2 2 'blue) (make-ball 1 2 'blue) (make-ball 1 1 'blue) (make-ball 1 2 'red) 'red) ;fails
+(check-member-of (create 2) (make-ball 1 2 'blue) (make-ball 1 1 'blue) (make-ball 1 2 'red) 'fails)
 
 (check-range 5 0 10)
 (check-range 0 0 10)
@@ -74,12 +78,12 @@
 (check-random (f 0) (list (random 10) (random 20)))
 
 (check-random (g 0)
-              (let ((x2 (random 20))
+              (let* ((x2 (random 20))
                      (x1 (random 10)))
-                (list x1 x2)))
+                (list x1 x2))) ;; fails 
 
 (define (h _x) (first (list (random 50) (random 20))))
 
-(check-random (h) (begin (random 50) (random 20)))
+(check-random (h 0) (begin0 (random 50) (random 20)))
 
-(check-random (h) (begin (random 20) (random 50))) ;; fails 
+(check-random (h 0) (begin (random 20) (random 50))) ;; fails