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
; 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

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

@ -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

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

@ -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

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

@ -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

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

@ -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

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

@ -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)]]{

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

@ -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

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

@ -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.}

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

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

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

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

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

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

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

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

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

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

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

@ -14,6 +14,7 @@
(provide
check-expect ;; syntax : (check-expect <expression> <expression>)
check-random ;; syntax : (check-random <expression> <expression>)
check-within ;; syntax : (check-within <expression> <expression> <expression>)
check-member-of ;; syntax : (check-member-of <expression> <expression>)
check-range ;; syntax : (check-range <expression> <expression> <expression>)
@ -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)

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.
#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