suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed source location reporting, test annotation; Rackety tests

Browse Source
This commit is contained in:
Matthias Felleisen 2014-04-12 09:31:26 -04:00
parent f3a75d1ab0
commit c8df1184fd
2 changed files with 41 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
pkgs/htdp-pkgs/htdp-lib/test-engine/racket-tests.rkt
View File

@ -153,18 +153,33 @@
[_ (raise-syntax-error 'check-expect (argcount-error-message/stx 2 stx) stx)]))
;; checking random values
(define-syntax-rule
(check-random e1 e2)
(begin
(define rng (make-pseudo-random-generator))
(define k (modulo (current-milliseconds) (sub1 (expt 2 31))))
(check-expect
(parameterize ((current-pseudo-random-generator rng))
(random-seed k)
e1)
(parameterize ((current-pseudo-random-generator rng))
(random-seed k)
e2))))
(define-syntax (check-random stx)
(syntax-case stx ()
[(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))))
(define actual (actual-maker rng k))
(error-check (lambda (v) (if (number? v) (exact? v) #t))
actual INEXACT-NUMBERS-FMT #t)
(error-check (lambda (v) (not (procedure? v))) actual FUNCTION-FMT #f)
(send (send test-engine get-info) add-check)
(run-and-check (lambda (v1 v2 _) (teach-equal? v1 v2))
(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)

24
pkgs/htdp-pkgs/htdp-test/tests/test-engine/TestEngineTest.rkt
View File

@ -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 (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") .1)
(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))
(x1 (random 10)))
(list x1 x2)))
(let* ((x2 (random 20))
(x1 (random 10)))
(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