run test in its own eventspace to adjust for change in running worlds…

… and universes
lassik · Aug 19, 2014 · 542860f · 542860f
1 parent 5a8479b
commit 542860f
Show file tree

Hide file tree

Showing 18 changed files with 179 additions and 156 deletions.
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/error-in-draw.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/error-in-draw.rkt
@@ -1,7 +1,6 @@
 #lang racket
 
-(require 2htdp/universe)
-(require 2htdp/image)
+(require 2htdp/universe 2htdp/image "test-aux.rkt")
 
 (define (f x)
   (cond
@@ -11,23 +10,25 @@
 
 (define txt "all questions were #f")
 
-(with-handlers ([exn? (lambda (e) (unless (string=? (exn-message e) txt) (raise e)))])
-  (big-bang 0 (on-tick add1) (to-draw f))
-  (error 'error-in-draw "test failed"))
-
-
-(let ([exn (with-handlers ([exn:fail? values])
-             (big-bang #f 
-                       [to-draw (λ (a b) #f)])
-             "no error raised")])
-(unless (regexp-match #rx"^to-draw:" (exn-message exn))
-  (eprintf "expected a error message beginning with to-draw:\n")
-  (raise exn)))
-
-(let ([exn (with-handlers ([exn:fail? values])
-             (big-bang #f 
-                       [on-draw (λ (a b) #f)])
-             "no error raised")])
-(unless (regexp-match #rx"^on-draw:" (exn-message exn))
-  (eprintf "expected a error message beginning with on-draw:\n")
-  (raise exn)))
+(testing
+
+  (with-handlers ([exn? (lambda (e) (unless (string=? (exn-message e) txt) (raise e)))])
+    (big-bang 0 (on-tick add1) (to-draw f))
+    (error 'error-in-draw "test failed"))
+
+
+  (let ([exn (with-handlers ([exn:fail? values])
+	       (big-bang #f 
+		 [to-draw (λ (a b) #f)])
+	       "no error raised")])
+    (unless (regexp-match #rx"^to-draw:" (exn-message exn))
+      (eprintf "expected a error message beginning with to-draw:\n")
+      (raise exn)))
+
+  (let ([exn (with-handlers ([exn:fail? values])
+	       (big-bang #f 
+		 [on-draw (λ (a b) #f)])
+	       "no error raised")])
+    (unless (regexp-match #rx"^on-draw:" (exn-message exn))
+      (eprintf "expected a error message beginning with on-draw:\n")
+      (raise exn))))
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/error-in-tick.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/error-in-tick.rkt
@@ -1,7 +1,6 @@
 #lang racket
 
-(require 2htdp/universe)
-(require 2htdp/image)
+(require 2htdp/universe 2htdp/image "test-aux.rkt")
 
 (define (f x) (circle 10 'solid 'red))
 
@@ -12,6 +11,7 @@
 
 (define txt "all questions were #f")
 
-(with-handlers ([exn? (lambda (e) (unless (string=? (exn-message e) txt) (raise e)))])
-  (big-bang 0 (on-tick g) (to-draw f))
-  (error 'error-in-tick "test failed"))
+(testing
+  (with-handlers ([exn? (lambda (e) (unless (string=? (exn-message e) txt) (raise e)))])
+    (big-bang 0 (on-tick g) (to-draw f))
+    (error 'error-in-tick "test failed")))
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/full-scene-visible.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/full-scene-visible.rkt
@@ -1,6 +1,7 @@
 #lang scheme/base
 
 (require 2htdp/universe
+         "test-aux.rkt"
          (prefix-in 2: 2htdp/image)
          (prefix-in 1: htdp/image))
 
@@ -10,6 +11,6 @@
             (stop-when zero?)
             (on-draw (λ (x) (f 100 100 'outline 'black)))))
 
-(see-full-rectangle 3 2:rectangle)
-
-(see-full-rectangle 3 1:rectangle)
+(testing 
+  (see-full-rectangle 3 2:rectangle)
+  (see-full-rectangle 3 1:rectangle))
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/image-too-large.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/image-too-large.rkt
@@ -1,6 +1,6 @@
 #lang racket
 
-(require 2htdp/universe 2htdp/image rackunit)
+(require 2htdp/universe 2htdp/image "test-aux.rkt")
 
 (define width 100000)
 (define height 10)
@@ -10,31 +10,31 @@
 (define (draw-large i)
   image)
 
-(check-true
- (with-handlers ([exn:fail? (lambda (x)
-                              (define msg (exn-message x))
-                              (define reg (regexp-match "draw-large" msg))
-                              (pair? reg))])
-   (big-bang 0 (to-draw draw-large) (on-tick add1) (stop-when zero?))
-   #false))
-
-
-(check-true
- (with-handlers ([exn:fail? (lambda (x)
-                              (define msg (exn-message x))
-                              (define reg (regexp-match "to-draw" msg))
-                              (pair? reg))])
-   (big-bang 0
-             (to-draw draw-large width height)
-             (on-tick add1)
-             (stop-when zero?))
-   #false))
-
-(check-true
- (local ((define first-time #true))
-   (big-bang 0
-             (to-draw (lambda (_) (begin0 (if first-time small image) (set! first-time #false))))
-             (on-tick add1)
-             (stop-when zero?))
-   #true))
+(testing
+  (check-true
+    (with-handlers ([exn:fail? (lambda (x)
+				 (define msg (exn-message x))
+				 (define reg (regexp-match "draw-large" msg))
+				 (pair? reg))])
+      (big-bang 0 (to-draw draw-large) (on-tick add1) (stop-when zero?))
+      #false))
+
+  (check-true
+    (with-handlers ([exn:fail? (lambda (x)
+				 (define msg (exn-message x))
+				 (define reg (regexp-match "to-draw" msg))
+				 (pair? reg))])
+      (big-bang 0
+	(to-draw draw-large width height)
+	(on-tick add1)
+	(stop-when zero?))
+      #false))
+
+  (check-true
+    (local ((define first-time #true))
+      (big-bang 0
+	(to-draw (lambda (_) (begin0 (if first-time small image) (set! first-time #false))))
+	(on-tick add1)
+	(stop-when zero?))
+      #true)))
 
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/key-error.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/key-error.rkt
@@ -3,33 +3,34 @@
 ;; ---------------------------------------------------------------------------------------------------
 ;; the error message should refer to the 'on-tick handler, not the lambda in the clause 
 
-(require 2htdp/universe)
-(require 2htdp/image)
+(require 2htdp/universe 2htdp/image "test-aux.rkt")
 
 (define (main)
   (big-bang 0
             (on-tick (lambda (w) "3"))
             (to-draw (lambda (w) (circle 10 'solid 'red)))
             (check-with number?)))
 
-(with-handlers ((exn:fail? (lambda (x) 
-                             (define msg (exn-message x))
-                             (define hdl (regexp-match "check-with: (.*) returned" msg))
-                             (unless (and hdl (cons? (regexp-match "on-tick" (second hdl))))
-                               (error 'test "expected: \"on-tick\", actual: ~e" (second hdl))))))
-  (main))
-
-
-(define (my-fun x) "hi")
-
-(with-handlers ((exn:fail? 
-                 (lambda (x) 
-                   (define msg (exn-message x))
-                   (define hdl (regexp-match "check-with's handler test" msg))
-                   (unless hdl
-                     (error 'test "expected: \"check-with's handler test, error says: ~e" msg)))))
-  (big-bang 0 
-            [to-draw (lambda (x) (circle 1 'solid 'red))]
-            [on-tick (lambda (x) (my-fun x))]
-            [check-with (lambda (x) (number? x))])
-  (raise `(bad "must fail")))
+(testing
+
+  (with-handlers ((exn:fail? (lambda (x) 
+			       (define msg (exn-message x))
+			       (define hdl (regexp-match "check-with: (.*) returned" msg))
+			       (unless (and hdl (cons? (regexp-match "on-tick" (second hdl))))
+				 (error 'test "expected: \"on-tick\", actual: ~e" (second hdl))))))
+    (main))
+
+
+  (define (my-fun x) "hi")
+
+  (with-handlers ((exn:fail? 
+		    (lambda (x) 
+		      (define msg (exn-message x))
+		      (define hdl (regexp-match "check-with's handler test" msg))
+		      (unless hdl
+			(error 'test "expected: \"check-with's handler test, error says: ~e" msg)))))
+    (big-bang 0 
+      [to-draw (lambda (x) (circle 1 'solid 'red))]
+      [on-tick (lambda (x) (my-fun x))]
+      [check-with (lambda (x) (number? x))])
+    (raise `(bad "must fail"))))
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/mouse-evt.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/mouse-evt.rkt
@@ -2,7 +2,7 @@
 
 (require 2htdp/universe)
 (require htdp/image)
-(require test-engine/scheme-tests)
+(require "test-aux.rkt")
 
 (define-struct posn (x y) #:transparent)
 
@@ -24,8 +24,6 @@
     [else
      (place-image sq (posn-x a-world) (posn-y a-world) mt)]))
 
-(check-expect (mouse-handler 'w 100 100 "leave") (make-posn 250 250))
-
 (define (mouse-handler w x y me)
   (cond
     [(string=? "button-down" me) w]
@@ -41,6 +39,7 @@
 (define (main w)
   (big-bang world1 (on-draw draw) (stop-when out?) (on-mouse mouse-handler)))
 
-(test)
+(check-equal? (mouse-handler 'w 100 100 "leave") (make-posn 250 250))
 
-(main 0)
+(testing
+  (main 0))
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/on-release-no-key.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/on-release-no-key.rkt
@@ -5,6 +5,7 @@
 
 (require 2htdp/image) 
 (require 2htdp/universe)
+(require "test-aux.rkt")
 
 (define large 50)
 
@@ -17,8 +18,9 @@
 
 (define (deflate b) (max (- b 1) 1))
 
-(big-bang 20
-          (on-release blow-up)
-          (on-tick deflate)
-          (to-draw balloon 200 200)
-          (stop-when (lambda (w) (>= w large))))
+(testing
+  (big-bang 20
+    (on-release blow-up)
+    (on-tick deflate)
+    (to-draw balloon 200 200)
+    (stop-when (lambda (w) (>= w large)))))
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/on-tick-with-limit.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/on-tick-with-limit.rkt
@@ -1,7 +1,8 @@
 #lang racket 
 
-(require 2htdp/universe 2htdp/image)
+(require 2htdp/universe 2htdp/image "test-aux.rkt")
 
-(big-bang 0 
-          (on-tick add1 1/28 3)
-          (to-draw (lambda (w) (circle (- 100 w) 'solid 'red))))
+(testing
+  (big-bang 0 
+    (on-tick add1 1/28 3)
+    (to-draw (lambda (w) (circle (- 100 w) 'solid 'red)))))
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/pad1-in-bsl.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/pad1-in-bsl.rkt
@@ -5,14 +5,16 @@
 
 (require 2htdp/universe)
 (require 2htdp/image)
+(require "test-aux.rkt")
 
 (define (render x)
   (place-image (circle 3 'solid 'red) (+ 150 (real-part x)) (+ 150 (imag-part x)) (empty-scene 300 300)))
 
 (define (sub1-i x) (- x 0+i))
 (define (add1-i x) (+ x 0+i))
 
-(big-bang 0+0i
-          (to-draw render)
-          (on-tick add1-i 1/28 50)
-          (on-pad (pad-handler (up sub1-i) (down add1-i) (left sub1) (right add1))))
+(testing
+  (big-bang 0+0i
+    (to-draw render)
+    (on-tick add1-i 1/28 50)
+    (on-pad (pad-handler (up sub1-i) (down add1-i) (left sub1) (right add1)))))
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/pad1.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/pad1.rkt
@@ -1,6 +1,6 @@
 #lang racket/gui
 
-(require 2htdp/image 2htdp/universe)
+(require 2htdp/image 2htdp/universe "test-aux.rkt")
 
 (pad=? "left" "left")
 
@@ -57,8 +57,9 @@
   (begin (set! label (string-append txt label))
          (big-bang x0 (to-draw render) (on-pad phandler) clause ... )))
 
-(= -10-10i (run ""))
-(= -10-10i (run "press l, " (on-key (key-handler 'key))))
-(= -10-10i (run "press l, " (on-key (key-handler 'key)) (on-release (key-handler 'release))))
-(= -10-10i (run "press l, " (on-release (key-handler 'release))))
+(testing
+  (= -10-10i (run ""))
+  (= -10-10i (run "press l, " (on-key (key-handler 'key))))
+  (= -10-10i (run "press l, " (on-key (key-handler 'key)) (on-release (key-handler 'release))))
+  (= -10-10i (run "press l, " (on-release (key-handler 'release)))))
 
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/perform-robby.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/perform-robby.rkt
@@ -1,5 +1,5 @@
 #lang scheme
-(require 2htdp/universe 2htdp/image)
+(require 2htdp/universe 2htdp/image "test-aux.rkt")
 
 (define (slow)
   (let sloop ([n (expt 2 22)])
@@ -13,9 +13,10 @@
 (define (render w)
   (circle 30 'solid (if (odd? w) 'red 'green)))
 
-(big-bang 10
-          (on-tick update-world)
-          (on-draw render)
-          (stop-when zero?))
+(testing 
+  (big-bang 10
+    (on-tick update-world)
+    (on-draw render)
+    (stop-when zero?))
 
-(printf "done\n")
+  (printf "done\n"))
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/random-seed-works.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/random-seed-works.rkt
@@ -1,6 +1,9 @@
 #lang racket
 
-(require 2htdp/universe 2htdp/image rackunit)
+;; testing the combination of random-seed and world programming 
+;; -----------------------------------------------------------------------------
+
+(require 2htdp/universe 2htdp/image)
 
 (define (main)
   (random-seed 1324)
@@ -11,12 +14,21 @@
    ;; it fails mostly with just time but not always, strange 
 
    (to-draw (λ (l) 
-              (text (if (> (length l) 3) "ok" (~a "press a again: " (- 2 (length l)))) 222 *color)))
+              (text (if (> (length l) 3)
+			"ok"
+			(~a "press a again: " (- 2 (length l))))
+		    222
+		    *color)))
+
    (on-key (λ (l ke) 
              (if (and (key=? "a" ke) (<= (length l) 3)) (cons (random 100) l) l)))
+
    (stop-when (λ (l) (>= (length l) 2)))))
+
 (define *color 'blue)
 
-(check-equal? (main) (begin (set! *color 'red) (main)))
+;; -----------------------------------------------------------------------------
+(require "test-aux.rkt")
 
-(module test racket/base)
+(testing
+  (check-equal? (main) (begin (set! *color 'red) (main))))