From c8df1184fd2e81ec6dcc5cb7b83ca21c5400402e Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Sat, 12 Apr 2014 09:31:26 -0400 Subject: [PATCH] fixed source location reporting, test annotation; Rackety tests --- .../htdp-lib/test-engine/racket-tests.rkt | 39 +++++++++++++------ .../tests/test-engine/TestEngineTest.rkt | 24 +++++++----- 2 files changed, 41 insertions(+), 22 deletions(-) diff --git a/pkgs/htdp-pkgs/htdp-lib/test-engine/racket-tests.rkt b/pkgs/htdp-pkgs/htdp-lib/test-engine/racket-tests.rkt index d50372aa4b..e3bb776337 100644 --- a/pkgs/htdp-pkgs/htdp-lib/test-engine/racket-tests.rkt +++ b/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 - (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) diff --git a/pkgs/htdp-pkgs/htdp-test/tests/test-engine/TestEngineTest.rkt b/pkgs/htdp-pkgs/htdp-test/tests/test-engine/TestEngineTest.rkt index bb765399ce..767fb01c7c 100644 --- a/pkgs/htdp-pkgs/htdp-test/tests/test-engine/TestEngineTest.rkt +++ b/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 (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 \ No newline at end of file +(check-random (h 0) (begin (random 20) (random 50))) ;; fails \ No newline at end of file