From aec84f4a943b87f412d89c28319a323105e16a70 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Fri, 4 Apr 2014 05:46:14 -0400 Subject: [PATCH] added David's check-random to test engine and teaching languages this is somewhat experimental, but it helps with testing random functions --- .../scribblings/htdp-langs/advanced.scrbl | 5 +- .../htdp-langs/beginner-abbr.scrbl | 5 +- .../scribblings/htdp-langs/beginner.scrbl | 5 +- .../htdp-langs/intermediate-lambda.scrbl | 5 +- .../scribblings/htdp-langs/intermediate.scrbl | 5 +- .../scribblings/htdp-langs/prim-ops.rkt | 51 ++++- .../scribblings/htdp-langs/std-grammar.rkt | 7 +- .../htdp-doc/test-engine/test-engine.scrbl | 48 ++++- .../htdp-pkgs/htdp-lib/lang/htdp-advanced.rkt | 1 + .../htdp-lib/lang/htdp-beginner-abbr.rkt | 1 + .../htdp-pkgs/htdp-lib/lang/htdp-beginner.rkt | 1 + .../lang/htdp-intermediate-lambda.rkt | 1 + .../htdp-lib/lang/htdp-intermediate.rkt | 1 + .../htdp-lib/test-engine/racket-tests.rkt | 202 ++++++++++-------- .../tests/test-engine/TestEngineTest.rkt | 32 ++- 15 files changed, 255 insertions(+), 115 deletions(-) diff --git a/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/advanced.scrbl b/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/advanced.scrbl index c5d85b1dc9..56b96e1c3c 100644 --- a/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/advanced.scrbl +++ b/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/advanced.scrbl @@ -11,8 +11,8 @@ local let let* letrec time begin begin0 set! delay shared recur when case match unless ; match _ cons list list* struct vector box - check-expect check-within check-member-of check-range check-error) -(check-expect check-within check-error check-member-of check-range require) + check-expect check-random check-within check-member-of check-range check-error) +(check-expect check-random check-within check-error check-member-of check-range require) [program (code:line def-or-expr ...)] [def-or-expr definition expr @@ -301,6 +301,7 @@ level as they did in the @secref["intermediate-lam"] level. and or check-expect + check-random check-within check-error check-member-of diff --git a/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/beginner-abbr.scrbl b/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/beginner-abbr.scrbl index 15e3a15d79..7ca5c23adc 100644 --- a/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/beginner-abbr.scrbl +++ b/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/beginner-abbr.scrbl @@ -8,8 +8,8 @@ @racketgrammar*+qq[ #:literals (define define-struct lambda cond else if and or require lib planet - check-expect check-within check-error) -(check-expect check-within check-member-of check-range check-error require) + check-expect check-random check-within check-error) +(check-expect check-random check-within check-member-of check-range check-error require) [program (code:line def-or-expr ...)] [def-or-expr definition expr @@ -68,6 +68,7 @@ Abbreviations} level as they did in the @secref["beginner"] level. and or check-expect + check-random check-within check-error check-member-of diff --git a/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/beginner.scrbl b/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/beginner.scrbl index 55ab2250e5..43e5521ab3 100644 --- a/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/beginner.scrbl +++ b/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/beginner.scrbl @@ -9,8 +9,8 @@ @racketgrammar*+library[ #:literals (define define-struct lambda cond else if and or require lib planet - check-expect check-within check-error) -(check-expect check-within check-member-of check-range check-error require) + check-expect check-random check-within check-error) +(check-expect check-random check-within check-member-of check-range check-error require) [program (code:line def-or-expr ...)] [def-or-expr definition expr @@ -64,6 +64,7 @@ A quoted @racket[name] is a symbol. A symbol is a value, just like and or check-expect + check-random check-within check-error check-member-of diff --git a/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/intermediate-lambda.scrbl b/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/intermediate-lambda.scrbl index 0e3d6ece4c..5716e06d88 100644 --- a/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/intermediate-lambda.scrbl +++ b/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/intermediate-lambda.scrbl @@ -8,8 +8,8 @@ @racketgrammar*+qq[ #:literals (define define-struct lambda λ cond else if and or require lib planet - local let let* letrec time check-expect check-within check-member-of check-range check-error) -(check-expect check-within check-member-of check-range check-error require) + local let let* letrec time check-expect check-random check-within check-member-of check-range check-error) +(check-expect check-random check-within check-member-of check-range check-error require) [program (code:line def-or-expr ...)] [def-or-expr definition expr @@ -109,6 +109,7 @@ level as they did in the @secref["intermediate"] level. and or check-expect + check-random check-within check-error check-member-of diff --git a/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/intermediate.scrbl b/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/intermediate.scrbl index b6a83020f6..4eefaf4fd9 100644 --- a/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/intermediate.scrbl +++ b/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/intermediate.scrbl @@ -9,8 +9,8 @@ @racketgrammar*+qq[ #:literals (define define-struct lambda cond else if and or require lib planet - local let let* letrec time check-expect check-within check-error) -(check-expect check-within check-member-of check-range check-error require) + local let let* letrec time check-expect check-random check-within check-error) +(check-expect check-random check-within check-member-of check-range check-error require) [program (code:line def-or-expr ...)] [def-or-expr definition expr @@ -84,6 +84,7 @@ did in the @secref["beginner-abbr"] level. and or check-expect + check-random check-within check-error check-member-of diff --git a/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/prim-ops.rkt b/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/prim-ops.rkt index 91b7df7154..5641844450 100644 --- a/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/prim-ops.rkt +++ b/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/prim-ops.rkt @@ -3,6 +3,8 @@ scribble/decode scribble/struct scribble/racket + scribble/eval + racket/sandbox racket/list racket/pretty syntax/docprovide @@ -18,6 +20,14 @@ prim-ops prim-op-defns) +(define-syntax-rule (mk-eval defs ...) + ;; ==> + (let ([me (make-base-eval)]) + (call-in-sandbox-context me (lambda () (error-print-source-location #f))) + (interaction-eval #:eval me defs) + ... + me)) + (define (maybe-make-table l t) (if (paragraph? t) (make-paragraph @@ -137,6 +147,7 @@ and or check-expect + check-random check-within check-error check-member-of @@ -152,6 +163,7 @@ #'or @racket[or] #'and @racket[and] #'check-expect @racket[check-expect] + #'check-random @racket[check-random] #'check-within @racket[check-within] #'check-error @racket[check-error] #'check-member-of @racket[check-member-of] @@ -167,6 +179,7 @@ or-id or-elem and-id and-elem check-expect-id check-expect-elem + check-random-id check-random-elem check-within-id check-within-elem check-error-id check-error-elem check-member-of-id check-member-of-elem @@ -297,13 +310,49 @@ @; ---------------------------------------------------------------------- - @defform*[#:id [check-expect check-expect-id] [(check-expect expression expected-expression)]]{ Checks that the first @racket[expression] evaluates to the same value as the @racket[expected-expression].} + @defform*[#:id [check-random check-random-id] + [(check-random expression expected-expression)]]{ + + Checks that the first @racket[expression] evaluates to the same value as the + @racket[expected-expression]. + +The form supplies the same random-number generator to both parts. If both +parts request @racket[random] numbers from the same interval in the same +order, they receive the same random numbers. + +@examples[#:eval (mk-eval (require test-engine/racket-tests)) + +(check-random (random 10) (random 10)) + +(check-random + (begin (random 100) (random 200)) + (begin (random 100) (random 200))) + +(test) +] + +If the two parts call @racket[random] for different intervals, they are +likely to fail: + +@examples[#:eval (mk-eval (require test-engine/racket-tests)) +(check-random + (begin (random 100) (random 200)) + (begin (random 200) (random 100))) + +(test) +] + +It is an error for @racket[expr] or @racket[expected-expr] to produce a function +value or an inexact number. + + } + @defform*[#:id [check-within check-within-id] [(check-within expression expected-expression delta)]]{ diff --git a/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/std-grammar.rkt b/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/std-grammar.rkt index f4e4fdf45e..7db9720817 100644 --- a/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/std-grammar.rkt +++ b/pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/std-grammar.rkt @@ -11,12 +11,13 @@ (define-syntax-rule (racketgrammar*+library #:literals lits - (check-expect check-within check-member-of check-range check-error require) + (check-expect check-random check-within check-member-of check-range check-error require) form ...) (racketgrammar* #:literals lits form ... [test-case @#,racket[(check-expect expr expr)] + @#,racket[(check-random expr expr)] @#,racket[(check-within expr expr expr)] @#,racket[(check-member-of expr expr (... ...))] @#,racket[(check-range expr expr expr)] @@ -31,11 +32,11 @@ (define-syntax-rule (racketgrammar*+qq #:literals lits - (check-expect check-within check-member-of check-range check-error require) + (check-expect check-random check-within check-member-of check-range check-error require) form ...) (racketgrammar*+library #:literals lits - (check-expect check-within check-member-of check-range check-error require) + (check-expect check-random check-within check-member-of check-range check-error require) form ... (... [quoted name diff --git a/pkgs/htdp-pkgs/htdp-doc/test-engine/test-engine.scrbl b/pkgs/htdp-pkgs/htdp-doc/test-engine/test-engine.scrbl index f0a9d86725..462b5bfa33 100644 --- a/pkgs/htdp-pkgs/htdp-doc/test-engine/test-engine.scrbl +++ b/pkgs/htdp-pkgs/htdp-doc/test-engine/test-engine.scrbl @@ -1,8 +1,15 @@ #lang scribble/doc -@(require scribble/manual - (for-label racket/base - test-engine/racket-tests - (prefix-in gui: test-engine/racket-gui))) + +@(require (for-label racket/base test-engine/racket-tests (prefix-in gui: test-engine/racket-gui))) + +@(require scribble/manual scribble/eval racket/sandbox) +@(define-syntax-rule (mk-eval defs ...) + ;; ==> + (let ([me (make-base-eval)]) + (call-in-sandbox-context me (lambda () (error-print-source-location #f))) + (interaction-eval #:eval me defs) + ... + me)) @title{Test Support} @@ -28,6 +35,39 @@ register checks to be performed. The checks are actually run by the Checks whether the value of the @racket[expr] expression is @racket[equal?] to the value produced by the @racket[expected-expr]. +It is an error for @racket[expr] or @racket[expected-expr] to produce a function +value or an inexact number.} + +@defform[(check-random expr expected-expr)]{ +Checks whether the value of the @racket[expr] expression is +@racket[equal?] to the value produced by the @racket[expected-expr]. + +The form supplies the same random-number generator to both parts. If both +parts request @racket[random] numbers from the same interval in the same +order, they receive the same random numbers. + +@examples[#:eval (mk-eval (require test-engine/racket-tests)) + +(check-random (random 10) (random 10)) + +(check-random + (begin (random 100) (random 200)) + (begin (random 100) (random 200))) + +(test) +] + +If the two parts call @racket[random] for different intervals, they are +likely to fail: + +@examples[#:eval (mk-eval (require test-engine/racket-tests)) +(check-random + (begin (random 100) (random 200)) + (begin (random 200) (random 100))) + +(test) +] + It is an error for @racket[expr] or @racket[expected-expr] to produce a function value or an inexact number.} diff --git a/pkgs/htdp-pkgs/htdp-lib/lang/htdp-advanced.rkt b/pkgs/htdp-pkgs/htdp-lib/lang/htdp-advanced.rkt index 359ab19091..6105848a46 100644 --- a/pkgs/htdp-pkgs/htdp-lib/lang/htdp-advanced.rkt +++ b/pkgs/htdp-pkgs/htdp-lib/lang/htdp-advanced.rkt @@ -56,6 +56,7 @@ [advanced-delay delay] [advanced-module-begin #%module-begin]) check-expect + check-random check-within check-error check-member-of diff --git a/pkgs/htdp-pkgs/htdp-lib/lang/htdp-beginner-abbr.rkt b/pkgs/htdp-pkgs/htdp-lib/lang/htdp-beginner-abbr.rkt index bb494b704b..9e85d33275 100644 --- a/pkgs/htdp-pkgs/htdp-lib/lang/htdp-beginner-abbr.rkt +++ b/pkgs/htdp-pkgs/htdp-lib/lang/htdp-beginner-abbr.rkt @@ -38,6 +38,7 @@ [beginner-true true] [beginner-false false]) check-expect + check-random check-within check-error check-member-of diff --git a/pkgs/htdp-pkgs/htdp-lib/lang/htdp-beginner.rkt b/pkgs/htdp-pkgs/htdp-lib/lang/htdp-beginner.rkt index 071b18d647..cf53269c90 100644 --- a/pkgs/htdp-pkgs/htdp-lib/lang/htdp-beginner.rkt +++ b/pkgs/htdp-pkgs/htdp-lib/lang/htdp-beginner.rkt @@ -42,6 +42,7 @@ [beginner-false false] ) check-expect + check-random check-within check-error check-member-of diff --git a/pkgs/htdp-pkgs/htdp-lib/lang/htdp-intermediate-lambda.rkt b/pkgs/htdp-pkgs/htdp-lib/lang/htdp-intermediate-lambda.rkt index 55298bca69..2a732f6562 100644 --- a/pkgs/htdp-pkgs/htdp-lib/lang/htdp-intermediate-lambda.rkt +++ b/pkgs/htdp-pkgs/htdp-lib/lang/htdp-intermediate-lambda.rkt @@ -43,6 +43,7 @@ [beginner-false false] ) check-expect + check-random check-within check-error check-member-of diff --git a/pkgs/htdp-pkgs/htdp-lib/lang/htdp-intermediate.rkt b/pkgs/htdp-pkgs/htdp-lib/lang/htdp-intermediate.rkt index 05f3359fc3..cd71b6153b 100644 --- a/pkgs/htdp-pkgs/htdp-lib/lang/htdp-intermediate.rkt +++ b/pkgs/htdp-pkgs/htdp-lib/lang/htdp-intermediate.rkt @@ -44,6 +44,7 @@ [beginner-false false] ) check-expect + check-random check-within check-error check-member-of 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 dfaf02c170..94b056d831 100644 --- a/pkgs/htdp-pkgs/htdp-lib/test-engine/racket-tests.rkt +++ b/pkgs/htdp-pkgs/htdp-lib/test-engine/racket-tests.rkt @@ -14,6 +14,7 @@ (provide check-expect ;; syntax : (check-expect ) + check-random ;; syntax : (check-random ) check-within ;; syntax : (check-within ) check-member-of ;; syntax : (check-member-of ) check-range ;; syntax : (check-range ) @@ -31,13 +32,13 @@ (define FUNCTION-FMT "check-expect cannot compare functions.") (define CHECK-ERROR-STR-FMT - "check-error expects a string for the second argument, representing the expected error message. Given ~s") + "check-error expects a string (the expected error message) for the second argument. Given ~s") (define CHECK-WITHIN-INEXACT-FMT "check-within expects an inexact number for the range. ~a is not inexact.") (define CHECK-WITHIN-FUNCTION-FMT "check-within cannot compare functions.") (define LIST-FMT - "check-member-of expects a list for the second argument, containing the possible outcomes. Given ~s") + "check-member-of expects a list for the second argument (the possible outcomes). Given ~s") (define CHECK-MEMBER-OF-FUNCTION-FMT "check-member-of cannot compare functions.") (define RANGE-MIN-FMT @@ -57,22 +58,21 @@ ;; check-expect-maker : syntax? syntax? (listof syntax?) symbol? -> syntax? ;; the common part of all three test forms. -(define-for-syntax (check-expect-maker - stx checker-proc-stx test-expr embedded-stxes hint-tag) +(define-for-syntax (check-expect-maker stx checker-proc-stx test-expr embedded-stxes hint-tag) (define bogus-name (stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t)) (define src-info (with-stepper-syntax-properties (['stepper-skip-completely #t]) - #`(list #,@(list #`(quote #,(syntax-source stx)) - (syntax-line stx) - (syntax-column stx) - (syntax-position stx) - (syntax-span stx))))) + #`(list #,@(list #`(quote #,(syntax-source stx)) + (syntax-line stx) + (syntax-column stx) + (syntax-position stx) + (syntax-span stx))))) (if (eq? 'module (syntax-local-context)) #`(define #,bogus-name #,(stepper-syntax-property - #`(let ([test-engine (namespace-variable-value - 'test~object #f builder (current-namespace))]) + #`(let* ([ns (current-namespace)] + [test-engine (namespace-variable-value 'test~object #f builder ns)]) (when test-engine (insert-test test-engine (lambda () @@ -109,31 +109,30 @@ skipto/cdr skipto/third ;; application of insert-test '(syntax-e cdr cdr syntax-e car) ;; lambda ))) - #`(let ([test-engine (namespace-variable-value - 'test~object #f builder (current-namespace))]) - (when test-engine - (insert-test test-engine - (lambda () - #,(with-stepper-syntax-properties - (['stepper-hint hint-tag] - ['stepper-hide-reduction #t] - ['stepper-use-val-as-final #t]) - (quasisyntax/loc stx - (#,checker-proc-stx - #,(with-stepper-syntax-properties - (['stepper-hide-reduction #t]) - #`(car - #,(with-stepper-syntax-properties - (['stepper-hide-reduction #t]) - #`(list - (lambda () #,test-expr) - #,(syntax/loc stx (void)))))) - #,@embedded-stxes - #,src-info - #,(with-stepper-syntax-properties - (['stepper-no-lifting-info #t] - ['stepper-hide-reduction #t]) - #'test-engine)))))))))) + #`(let ([test-engine (namespace-variable-value 'test~object #f builder (current-namespace))]) + (when test-engine + (insert-test test-engine + (lambda () + #,(with-stepper-syntax-properties + (['stepper-hint hint-tag] + ['stepper-hide-reduction #t] + ['stepper-use-val-as-final #t]) + (quasisyntax/loc stx + (#,checker-proc-stx + #,(with-stepper-syntax-properties + (['stepper-hide-reduction #t]) + #`(car + #,(with-stepper-syntax-properties + (['stepper-hide-reduction #t]) + #`(list + (lambda () #,test-expr) + #,(syntax/loc stx (void)))))) + #,@embedded-stxes + #,src-info + #,(with-stepper-syntax-properties + (['stepper-no-lifting-info #t] + ['stepper-hide-reduction #t]) + #'test-engine)))))))))) (define-for-syntax (check-context?) (let ([c (syntax-local-context)]) @@ -149,10 +148,23 @@ (raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx)) (syntax-case stx () [(_ test actual) - (check-expect-maker stx #'check-values-expected #`test (list #`actual) - 'comes-from-check-expect)] + (check-expect-maker stx #'check-values-expected #`test (list #`actual) 'comes-from-check-expect)] [_ (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)))) + ;; check-values-expected: (-> scheme-val) scheme-val src test-engine -> void (define (check-values-expected test actual src test-engine) (error-check (lambda (v) (if (number? v) (exact? v) #t)) @@ -169,7 +181,7 @@ (raise-syntax-error 'check-within CHECK-WITHIN-DEFN-STR stx)) (syntax-case stx () [(_ test actual within) - (check-expect-maker stx #'check-values-within #`test (list #`actual #`within) + (check-expect-maker stx #'check-values-within #`test (list #`actual #`within) 'comes-from-check-within)] [_ (raise-syntax-error 'check-within (argcount-error-message/stx 3 stx) stx)])) @@ -244,7 +256,10 @@ (raise-syntax-error 'check-member-of CHECK-EXPECT-DEFN-STR stx)) (syntax-case stx () [(_ test actual actuals ...) - (check-expect-maker stx #'check-member-of-values-expected #`test (list #`actual #`(list actuals ...)) + (check-expect-maker stx + #'check-member-of-values-expected + #`test + (list #`actual #`(list actuals ...)) 'comes-from-check-member-of)] [_ (raise-syntax-error 'check-member-of (argcount-error-message/stx 2 stx #t) stx)])) @@ -277,30 +292,27 @@ (lambda (src format v1 v2 v3) (make-not-range src format v1 v2 v3)) test min max src test-engine 'check-range)) - + ;; run-and-check: (scheme-val scheme-val scheme-val -> boolean) ;; (src format scheme-val scheme-val scheme-val -> check-fail) ;; ( -> scheme-val) scheme-val scheme-val test-engine symbol? -> void (define (run-and-check check maker test expect range src test-engine kind) - (match-let ([(list result result-val exn) - (with-handlers ([exn:fail:wish? - (lambda (e) - (let ([display (error-display-handler)]) - (list (unimplemented-wish src (test-format) (exn:fail:wish-name e) (exn:fail:wish-args e)) - 'error - #f)))] - [exn:fail? - (lambda (e) - (let ([display (error-display-handler)]) - (list (make-unexpected-error src (test-format) expect - (get-rewriten-error-message e) - e) - 'error - e)))]) - (let ([test-val (test)]) - (cond [(check expect test-val range) (list #t test-val #f)] - [else - (list (maker src (test-format) test-val expect range) test-val #f)])))]) + (match-let + ([(list result result-val exn) + (with-handlers ([exn:fail:wish? + (lambda (e) + (define display (error-display-handler)) + (define name (exn:fail:wish-name e)) + (define args (exn:fail:wish-args e)) + (list (unimplemented-wish src (test-format) name args) 'error #f))] + [exn:fail? + (lambda (e) + (define display (error-display-handler)) + (define msg (get-rewriten-error-message e)) + (list (make-unexpected-error src (test-format) expect msg e) 'error e))]) + (define test-val (test)) + (cond [(check expect test-val range) (list #t test-val #f)] + [else (list (maker src (test-format) test-val expect range) test-val #f)]))]) (cond [(check-fail? result) (send (send test-engine get-info) check-failed result (check-fail-src result) exn) (if exn (raise exn) #f)] @@ -311,7 +323,7 @@ (define (reset-tests) (let ([test-engine (namespace-variable-value - 'test~object #f builder (current-namespace))]) + 'test~object #f builder (current-namespace))]) (when test-engine (send test-engine reset-info)))) @@ -377,49 +389,49 @@ (define signature-test-info% (class* test-info-base% () - + (define signature-violations '()) - + (inherit report-failure) - + (define/pubment (signature-failed obj signature message blame) - + (let* ((cms - (continuation-mark-set->list (current-continuation-marks) - teaching-languages-continuation-mark-key)) - (srcloc - (cond - ((findf (lambda (mark) - (and mark - (or (path? (car mark)) - (symbol? (car mark))))) - cms) - => (lambda (mark) - (apply (lambda (source line col pos span) - (make-srcloc source line col pos span)) - mark))) - (else #f))) - (message - (or message - (make-signature-got obj (test-format))))) - - (set! signature-violations - (cons (make-signature-violation obj signature message srcloc blame) - signature-violations))) + (continuation-mark-set->list (current-continuation-marks) + teaching-languages-continuation-mark-key)) + (srcloc + (cond + ((findf (lambda (mark) + (and mark + (or (path? (car mark)) + (symbol? (car mark))))) + cms) + => (lambda (mark) + (apply (lambda (source line col pos span) + (make-srcloc source line col pos span)) + mark))) + (else #f))) + (message + (or message + (make-signature-got obj (test-format))))) + + (set! signature-violations + (cons (make-signature-violation obj signature message srcloc blame) + signature-violations))) (report-failure) (inner (void) signature-failed obj signature message)) - + (define/public (failed-signatures) (reverse signature-violations)) (inherit add-check-failure) (define/pubment (property-failed result src-info) (report-failure) (add-check-failure (make-property-fail src-info (test-format) result) #f)) - + (define/pubment (property-error exn src-info) (report-failure) (add-check-failure (make-property-error src-info (test-format) (exn-message exn) exn) exn)) - + (super-instantiate ()))) (define wish-test-info% @@ -433,12 +445,12 @@ (super-instantiate ()) (inherit-field test-info test-display) (inherit setup-info) - + (field [tests null] [test-objs null]) - + (define/override (info-class) signature-test-info%) - + (define/public (add-test tst) (set! tests (cons tst tests))) (define/public (get-info) @@ -447,14 +459,14 @@ (define/public (reset-info) (set! tests null) #;(send this setup-info 'check-require)) - + (define/augment (run) (inner (void) run) (for ([t (reverse tests)]) (run-test t))) - + (define/augment (run-test test) (test) (inner (void) run-test test)))) (provide scheme-test-data test-format test-execute test-silence error-handler - signature-test-info% build-test-engine) + signature-test-info% build-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 c9db8df40e..bb765399ce 100644 --- a/pkgs/htdp-pkgs/htdp-test/tests/test-engine/TestEngineTest.rkt +++ b/pkgs/htdp-pkgs/htdp-test/tests/test-engine/TestEngineTest.rkt @@ -1,6 +1,6 @@ -;; The first three lines of this file were inserted by DrScheme. They record metadata +;; 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-beginner-reader.ss" "lang")((modname TestEngineTest) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) +#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 (define (count f) @@ -55,3 +55,31 @@ (check-range 0.0 0 10.5) (check-range 10.5 0 10.5) (check-range 10.5001 0 10.5) ;fails + +;; --------------------------------------------------------------------------------------------------- +;; MF: from DVH + +(define (random-elt ls) (list-ref ls (random (length ls)))) + +(check-random (random-elt (build-list 100 identity)) + (list-ref (build-list 100 identity) (random 100))) + + +(define (f _x) + (list (random 10) (random 20))) + +(define (g _x) + (list (random 10) (random 20))) + +(check-random (f 0) (list (random 10) (random 20))) + +(check-random (g 0) + (let ((x2 (random 20)) + (x1 (random 10))) + (list x1 x2))) + +(define (h _x) (first (list (random 50) (random 20)))) + +(check-random (h) (begin (random 50) (random 20))) + +(check-random (h) (begin (random 20) (random 50))) ;; fails \ No newline at end of file