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

added David's check-random to test engine and teaching languages

Browse Source 
this is somewhat experimental, but it helps with testing random functions
This commit is contained in:
Matthias Felleisen 2014-04-04 05:46:14 -04:00
parent 8c1206c063
commit aec84f4a94
15 changed files with 255 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/advanced.scrbl
View File

@ -11,8 +11,8 @@
local let let* letrec time begin begin0 set! delay shared recur when case match unless local let let* letrec time begin begin0 set! delay shared recur when case match unless
; match ; match
_ cons list list* struct vector box _ cons list list* struct vector box
check-expect check-within check-member-of check-range check-error) check-expect check-random 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-error check-member-of check-range require)
[program (code:line def-or-expr ...)] [program (code:line def-or-expr ...)]
[def-or-expr definition [def-or-expr definition
expr expr
@ -301,6 +301,7 @@ level as they did in the @secref["intermediate-lam"] level.
and and
or or
check-expect check-expect
check-random
check-within check-within
check-error check-error
check-member-of check-member-of

5
pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/beginner-abbr.scrbl
View File

@ -8,8 +8,8 @@
@racketgrammar*+qq[ @racketgrammar*+qq[
#:literals (define define-struct lambda cond else if and or require lib planet #:literals (define define-struct lambda cond else if and or require lib planet
check-expect check-within check-error) check-expect check-random check-within check-error)
(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)
[program (code:line def-or-expr ...)] [program (code:line def-or-expr ...)]
[def-or-expr definition [def-or-expr definition
expr expr
@ -68,6 +68,7 @@ Abbreviations} level as they did in the @secref["beginner"] level.
and and
or or
check-expect check-expect
check-random
check-within check-within
check-error check-error
check-member-of check-member-of

5
pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/beginner.scrbl
View File

@ -9,8 +9,8 @@
@racketgrammar*+library[ @racketgrammar*+library[
#:literals (define define-struct lambda cond else if and or require lib planet #:literals (define define-struct lambda cond else if and or require lib planet
check-expect check-within check-error) check-expect check-random check-within check-error)
(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)
[program (code:line def-or-expr ...)] [program (code:line def-or-expr ...)]
[def-or-expr definition [def-or-expr definition
expr expr
@ -64,6 +64,7 @@ A quoted @racket[name] is a symbol. A symbol is a value, just like
and and
or or
check-expect check-expect
check-random
check-within check-within
check-error check-error
check-member-of check-member-of

5
pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/intermediate-lambda.scrbl
View File

@ -8,8 +8,8 @@
@racketgrammar*+qq[ @racketgrammar*+qq[
#:literals (define define-struct lambda λ cond else if and or require lib planet #: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) local let let* letrec time check-expect check-random check-within check-member-of check-range check-error)
(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)
[program (code:line def-or-expr ...)] [program (code:line def-or-expr ...)]
[def-or-expr definition [def-or-expr definition
expr expr
@ -109,6 +109,7 @@ level as they did in the @secref["intermediate"] level.
and and
or or
check-expect check-expect
check-random
check-within check-within
check-error check-error
check-member-of check-member-of

5
pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/intermediate.scrbl
View File

@ -9,8 +9,8 @@
@racketgrammar*+qq[ @racketgrammar*+qq[
#:literals (define define-struct lambda cond else if and or require lib planet #:literals (define define-struct lambda cond else if and or require lib planet
local let let* letrec time check-expect check-within check-error) local let let* letrec time check-expect check-random check-within check-error)
(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)
[program (code:line def-or-expr ...)] [program (code:line def-or-expr ...)]
[def-or-expr definition [def-or-expr definition
expr expr
@ -84,6 +84,7 @@ did in the @secref["beginner-abbr"] level.
and and
or or
check-expect check-expect
check-random
check-within check-within
check-error check-error
check-member-of check-member-of

51
pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/prim-ops.rkt
View File

@ -3,6 +3,8 @@
scribble/decode scribble/decode
scribble/struct scribble/struct
scribble/racket scribble/racket
scribble/eval
racket/sandbox
racket/list racket/list
racket/pretty racket/pretty
syntax/docprovide syntax/docprovide
@ -18,6 +20,14 @@
prim-ops prim-ops
prim-op-defns) 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) (define (maybe-make-table l t)
(if (paragraph? t) (if (paragraph? t)
(make-paragraph (make-paragraph
@ -137,6 +147,7 @@
and and
or or
check-expect check-expect
check-random
check-within check-within
check-error check-error
check-member-of check-member-of
@ -152,6 +163,7 @@
#'or @racket[or] #'or @racket[or]
#'and @racket[and] #'and @racket[and]
#'check-expect @racket[check-expect] #'check-expect @racket[check-expect]
#'check-random @racket[check-random]
#'check-within @racket[check-within] #'check-within @racket[check-within]
#'check-error @racket[check-error] #'check-error @racket[check-error]
#'check-member-of @racket[check-member-of] #'check-member-of @racket[check-member-of]
@ -167,6 +179,7 @@
or-id or-elem or-id or-elem
and-id and-elem and-id and-elem
check-expect-id check-expect-elem check-expect-id check-expect-elem
check-random-id check-random-elem
check-within-id check-within-elem check-within-id check-within-elem
check-error-id check-error-elem check-error-id check-error-elem
check-member-of-id check-member-of-elem check-member-of-id check-member-of-elem
@ -297,13 +310,49 @@
@; ---------------------------------------------------------------------- @; ----------------------------------------------------------------------
@defform*[#:id [check-expect check-expect-id] @defform*[#:id [check-expect check-expect-id]
[(check-expect expression expected-expression)]]{ [(check-expect expression expected-expression)]]{
Checks that the first @racket[expression] evaluates to the same value as the Checks that the first @racket[expression] evaluates to the same value as the
@racket[expected-expression].} @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] @defform*[#:id [check-within check-within-id]
[(check-within expression expected-expression delta)]]{ [(check-within expression expected-expression delta)]]{

7
pkgs/htdp-pkgs/htdp-doc/scribblings/htdp-langs/std-grammar.rkt
View File

@ -11,12 +11,13 @@
(define-syntax-rule (racketgrammar*+library (define-syntax-rule (racketgrammar*+library
#:literals lits #: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 ...) form ...)
(racketgrammar* (racketgrammar*
#:literals lits #:literals lits
form ... form ...
[test-case @#,racket[(check-expect expr expr)] [test-case @#,racket[(check-expect expr expr)]
@#,racket[(check-random expr expr)]
@#,racket[(check-within expr expr expr)] @#,racket[(check-within expr expr expr)]
@#,racket[(check-member-of expr expr (... ...))] @#,racket[(check-member-of expr expr (... ...))]
@#,racket[(check-range expr expr expr)] @#,racket[(check-range expr expr expr)]
@ -31,11 +32,11 @@
(define-syntax-rule (racketgrammar*+qq (define-syntax-rule (racketgrammar*+qq
#:literals lits #: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 ...) form ...)
(racketgrammar*+library (racketgrammar*+library
#:literals lits #: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 ... form ...
(... (...
[quoted name [quoted name

48
pkgs/htdp-pkgs/htdp-doc/test-engine/test-engine.scrbl
View File

@ -1,8 +1,15 @@
#lang scribble/doc #lang scribble/doc
@(require scribble/manual
(for-label racket/base @(require (for-label racket/base test-engine/racket-tests (prefix-in gui: test-engine/racket-gui)))
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} @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 Checks whether the value of the @racket[expr] expression is
@racket[equal?] to the value produced by the @racket[expected-expr]. @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 It is an error for @racket[expr] or @racket[expected-expr] to produce a function
value or an inexact number.} value or an inexact number.}

1
pkgs/htdp-pkgs/htdp-lib/lang/htdp-advanced.rkt
View File

@ -56,6 +56,7 @@
[advanced-delay delay] [advanced-delay delay]
[advanced-module-begin #%module-begin]) [advanced-module-begin #%module-begin])
check-expect check-expect
check-random
check-within check-within
check-error check-error
check-member-of check-member-of

1
pkgs/htdp-pkgs/htdp-lib/lang/htdp-beginner-abbr.rkt
View File

@ -38,6 +38,7 @@
[beginner-true true] [beginner-true true]
[beginner-false false]) [beginner-false false])
check-expect check-expect
check-random
check-within check-within
check-error check-error
check-member-of check-member-of

1
pkgs/htdp-pkgs/htdp-lib/lang/htdp-beginner.rkt
View File

@ -42,6 +42,7 @@
[beginner-false false] [beginner-false false]
) )
check-expect check-expect
check-random
check-within check-within
check-error check-error
check-member-of check-member-of

1
pkgs/htdp-pkgs/htdp-lib/lang/htdp-intermediate-lambda.rkt
View File

@ -43,6 +43,7 @@
[beginner-false false] [beginner-false false]
) )
check-expect check-expect
check-random
check-within check-within
check-error check-error
check-member-of check-member-of

1
pkgs/htdp-pkgs/htdp-lib/lang/htdp-intermediate.rkt
View File

@ -44,6 +44,7 @@
[beginner-false false] [beginner-false false]
) )
check-expect check-expect
check-random
check-within check-within
check-error check-error
check-member-of check-member-of

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

@ -14,6 +14,7 @@
(provide (provide
check-expect ;; syntax : (check-expect <expression> <expression>) check-expect ;; syntax : (check-expect <expression> <expression>)
check-random ;; syntax : (check-random <expression> <expression>)
check-within ;; syntax : (check-within <expression> <expression> <expression>) check-within ;; syntax : (check-within <expression> <expression> <expression>)
check-member-of ;; syntax : (check-member-of <expression> <expression>) check-member-of ;; syntax : (check-member-of <expression> <expression>)
check-range ;; syntax : (check-range <expression> <expression> <expression>) check-range ;; syntax : (check-range <expression> <expression> <expression>)
@ -31,13 +32,13 @@
(define FUNCTION-FMT (define FUNCTION-FMT
"check-expect cannot compare functions.") "check-expect cannot compare functions.")
(define CHECK-ERROR-STR-FMT (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 (define CHECK-WITHIN-INEXACT-FMT
"check-within expects an inexact number for the range. ~a is not inexact.") "check-within expects an inexact number for the range. ~a is not inexact.")
(define CHECK-WITHIN-FUNCTION-FMT (define CHECK-WITHIN-FUNCTION-FMT
"check-within cannot compare functions.") "check-within cannot compare functions.")
(define LIST-FMT (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 (define CHECK-MEMBER-OF-FUNCTION-FMT
"check-member-of cannot compare functions.") "check-member-of cannot compare functions.")
(define RANGE-MIN-FMT (define RANGE-MIN-FMT
@ -57,22 +58,21 @@
;; check-expect-maker : syntax? syntax? (listof syntax?) symbol? -> syntax? ;; check-expect-maker : syntax? syntax? (listof syntax?) symbol? -> syntax?
;; the common part of all three test forms. ;; the common part of all three test forms.
(define-for-syntax (check-expect-maker (define-for-syntax (check-expect-maker stx checker-proc-stx test-expr embedded-stxes hint-tag)
stx checker-proc-stx test-expr embedded-stxes hint-tag)
(define bogus-name (define bogus-name
(stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t)) (stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t))
(define src-info (define src-info
(with-stepper-syntax-properties (['stepper-skip-completely #t]) (with-stepper-syntax-properties (['stepper-skip-completely #t])
#`(list #,@(list #`(quote #,(syntax-source stx)) #`(list #,@(list #`(quote #,(syntax-source stx))
(syntax-line stx) (syntax-line stx)
(syntax-column stx) (syntax-column stx)
(syntax-position stx) (syntax-position stx)
(syntax-span stx))))) (syntax-span stx)))))
(if (eq? 'module (syntax-local-context)) (if (eq? 'module (syntax-local-context))
#`(define #,bogus-name #`(define #,bogus-name
#,(stepper-syntax-property #,(stepper-syntax-property
#`(let ([test-engine (namespace-variable-value #`(let* ([ns (current-namespace)]
'test~object #f builder (current-namespace))]) [test-engine (namespace-variable-value 'test~object #f builder ns)])
(when test-engine (when test-engine
(insert-test test-engine (insert-test test-engine
(lambda () (lambda ()
@ -109,31 +109,30 @@
skipto/cdr skipto/third ;; application of insert-test skipto/cdr skipto/third ;; application of insert-test
'(syntax-e cdr cdr syntax-e car) ;; lambda '(syntax-e cdr cdr syntax-e car) ;; lambda
))) )))
#`(let ([test-engine (namespace-variable-value #`(let ([test-engine (namespace-variable-value 'test~object #f builder (current-namespace))])
'test~object #f builder (current-namespace))]) (when test-engine
(when test-engine (insert-test test-engine
(insert-test test-engine (lambda ()
(lambda () #,(with-stepper-syntax-properties
#,(with-stepper-syntax-properties (['stepper-hint hint-tag]
(['stepper-hint hint-tag] ['stepper-hide-reduction #t]
['stepper-hide-reduction #t] ['stepper-use-val-as-final #t])
['stepper-use-val-as-final #t]) (quasisyntax/loc stx
(quasisyntax/loc stx (#,checker-proc-stx
(#,checker-proc-stx #,(with-stepper-syntax-properties
#,(with-stepper-syntax-properties (['stepper-hide-reduction #t])
(['stepper-hide-reduction #t]) #`(car
#`(car #,(with-stepper-syntax-properties
#,(with-stepper-syntax-properties (['stepper-hide-reduction #t])
(['stepper-hide-reduction #t]) #`(list
#`(list (lambda () #,test-expr)
(lambda () #,test-expr) #,(syntax/loc stx (void))))))
#,(syntax/loc stx (void)))))) #,@embedded-stxes
#,@embedded-stxes #,src-info
#,src-info #,(with-stepper-syntax-properties
#,(with-stepper-syntax-properties (['stepper-no-lifting-info #t]
(['stepper-no-lifting-info #t] ['stepper-hide-reduction #t])
['stepper-hide-reduction #t]) #'test-engine))))))))))
#'test-engine))))))))))
(define-for-syntax (check-context?) (define-for-syntax (check-context?)
(let ([c (syntax-local-context)]) (let ([c (syntax-local-context)])
@ -149,10 +148,23 @@
(raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx)) (raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx))
(syntax-case stx () (syntax-case stx ()
[(_ test actual) [(_ test actual)
(check-expect-maker stx #'check-values-expected #`test (list #`actual) (check-expect-maker stx #'check-values-expected #`test (list #`actual) 'comes-from-check-expect)]
'comes-from-check-expect)]
[_ (raise-syntax-error 'check-expect (argcount-error-message/stx 2 stx) stx)])) [_ (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 ;; check-values-expected: (-> scheme-val) scheme-val src test-engine -> void
(define (check-values-expected test actual src test-engine) (define (check-values-expected test actual src test-engine)
(error-check (lambda (v) (if (number? v) (exact? v) #t)) (error-check (lambda (v) (if (number? v) (exact? v) #t))
@ -169,7 +181,7 @@
(raise-syntax-error 'check-within CHECK-WITHIN-DEFN-STR stx)) (raise-syntax-error 'check-within CHECK-WITHIN-DEFN-STR stx))
(syntax-case stx () (syntax-case stx ()
[(_ test actual within) [(_ 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)] 'comes-from-check-within)]
[_ (raise-syntax-error 'check-within (argcount-error-message/stx 3 stx) stx)])) [_ (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)) (raise-syntax-error 'check-member-of CHECK-EXPECT-DEFN-STR stx))
(syntax-case stx () (syntax-case stx ()
[(_ test actual actuals ...) [(_ 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)] 'comes-from-check-member-of)]
[_ (raise-syntax-error 'check-member-of (argcount-error-message/stx 2 stx #t) stx)])) [_ (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)) (lambda (src format v1 v2 v3) (make-not-range src format v1 v2 v3))
test min max src test-engine 'check-range)) test min max src test-engine 'check-range))
;; run-and-check: (scheme-val scheme-val scheme-val -> boolean) ;; run-and-check: (scheme-val scheme-val scheme-val -> boolean)
;; (src format scheme-val scheme-val scheme-val -> check-fail) ;; (src format scheme-val scheme-val scheme-val -> check-fail)
;; ( -> scheme-val) scheme-val scheme-val test-engine symbol? -> void ;; ( -> scheme-val) scheme-val scheme-val test-engine symbol? -> void
(define (run-and-check check maker test expect range src test-engine kind) (define (run-and-check check maker test expect range src test-engine kind)
(match-let ([(list result result-val exn) (match-let
(with-handlers ([exn:fail:wish? ([(list result result-val exn)
(lambda (e) (with-handlers ([exn:fail:wish?
(let ([display (error-display-handler)]) (lambda (e)
(list (unimplemented-wish src (test-format) (exn:fail:wish-name e) (exn:fail:wish-args e)) (define display (error-display-handler))
'error (define name (exn:fail:wish-name e))
#f)))] (define args (exn:fail:wish-args e))
[exn:fail? (list (unimplemented-wish src (test-format) name args) 'error #f))]
(lambda (e) [exn:fail?
(let ([display (error-display-handler)]) (lambda (e)
(list (make-unexpected-error src (test-format) expect (define display (error-display-handler))
(get-rewriten-error-message e) (define msg (get-rewriten-error-message e))
e) (list (make-unexpected-error src (test-format) expect msg e) 'error e))])
'error (define test-val (test))
e)))]) (cond [(check expect test-val range) (list #t test-val #f)]
(let ([test-val (test)]) [else (list (maker src (test-format) test-val expect range) test-val #f)]))])
(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) (cond [(check-fail? result)
(send (send test-engine get-info) check-failed result (check-fail-src result) exn) (send (send test-engine get-info) check-failed result (check-fail-src result) exn)
(if exn (raise exn) #f)] (if exn (raise exn) #f)]
@ -311,7 +323,7 @@
(define (reset-tests) (define (reset-tests)
(let ([test-engine (namespace-variable-value (let ([test-engine (namespace-variable-value
'test~object #f builder (current-namespace))]) 'test~object #f builder (current-namespace))])
(when test-engine (when test-engine
(send test-engine reset-info)))) (send test-engine reset-info))))
@ -377,49 +389,49 @@
(define signature-test-info% (define signature-test-info%
(class* test-info-base% () (class* test-info-base% ()
(define signature-violations '()) (define signature-violations '())
(inherit report-failure) (inherit report-failure)
(define/pubment (signature-failed obj signature message blame) (define/pubment (signature-failed obj signature message blame)
(let* ((cms (let* ((cms
(continuation-mark-set->list (current-continuation-marks) (continuation-mark-set->list (current-continuation-marks)
teaching-languages-continuation-mark-key)) teaching-languages-continuation-mark-key))
(srcloc (srcloc
(cond (cond
((findf (lambda (mark) ((findf (lambda (mark)
(and mark (and mark
(or (path? (car mark)) (or (path? (car mark))
(symbol? (car mark))))) (symbol? (car mark)))))
cms) cms)
=> (lambda (mark) => (lambda (mark)
(apply (lambda (source line col pos span) (apply (lambda (source line col pos span)
(make-srcloc source line col pos span)) (make-srcloc source line col pos span))
mark))) mark)))
(else #f))) (else #f)))
(message (message
(or message (or message
(make-signature-got obj (test-format))))) (make-signature-got obj (test-format)))))
(set! signature-violations (set! signature-violations
(cons (make-signature-violation obj signature message srcloc blame) (cons (make-signature-violation obj signature message srcloc blame)
signature-violations))) signature-violations)))
(report-failure) (report-failure)
(inner (void) signature-failed obj signature message)) (inner (void) signature-failed obj signature message))
(define/public (failed-signatures) (reverse signature-violations)) (define/public (failed-signatures) (reverse signature-violations))
(inherit add-check-failure) (inherit add-check-failure)
(define/pubment (property-failed result src-info) (define/pubment (property-failed result src-info)
(report-failure) (report-failure)
(add-check-failure (make-property-fail src-info (test-format) result) #f)) (add-check-failure (make-property-fail src-info (test-format) result) #f))
(define/pubment (property-error exn src-info) (define/pubment (property-error exn src-info)
(report-failure) (report-failure)
(add-check-failure (make-property-error src-info (test-format) (exn-message exn) exn) exn)) (add-check-failure (make-property-error src-info (test-format) (exn-message exn) exn) exn))
(super-instantiate ()))) (super-instantiate ())))
(define wish-test-info% (define wish-test-info%
@ -433,12 +445,12 @@
(super-instantiate ()) (super-instantiate ())
(inherit-field test-info test-display) (inherit-field test-info test-display)
(inherit setup-info) (inherit setup-info)
(field [tests null] (field [tests null]
[test-objs null]) [test-objs null])
(define/override (info-class) signature-test-info%) (define/override (info-class) signature-test-info%)
(define/public (add-test tst) (define/public (add-test tst)
(set! tests (cons tst tests))) (set! tests (cons tst tests)))
(define/public (get-info) (define/public (get-info)
@ -447,14 +459,14 @@
(define/public (reset-info) (define/public (reset-info)
(set! tests null) (set! tests null)
#;(send this setup-info 'check-require)) #;(send this setup-info 'check-require))
(define/augment (run) (define/augment (run)
(inner (void) run) (inner (void) run)
(for ([t (reverse tests)]) (run-test t))) (for ([t (reverse tests)]) (run-test t)))
(define/augment (run-test test) (define/augment (run-test test)
(test) (test)
(inner (void) run-test test)))) (inner (void) run-test test))))
(provide scheme-test-data test-format test-execute test-silence error-handler (provide scheme-test-data test-format test-execute test-silence error-handler
signature-test-info% build-test-engine) signature-test-info% build-test-engine)

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

@ -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. ;; 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 ;;Expect 37 checks, 17 failures
(define (count f) (define (count f)
@ -55,3 +55,31 @@
(check-range 0.0 0 10.5) (check-range 0.0 0 10.5)
(check-range 10.5 0 10.5) (check-range 10.5 0 10.5)
(check-range 10.5001 0 10.5) ;fails (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