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

A flag to make the random testing forms return results instead of

Browse Source 
printing on stdout.

svn: r17858
This commit is contained in:
Casey Klein 2010-01-28 01:12:54 +00:00
parent 8733e7f233
commit 1b22ce82cd
4 changed files with 165 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
collects/redex/private/rg.ss
View File

@ -695,11 +695,12 @@
(let-values ([(names names/ellipses) (let-values ([(names names/ellipses)
(extract-names (language-id-nts #'lang 'redex-check) (extract-names (language-id-nts #'lang 'redex-check)
'redex-check #t #'pat)] 'redex-check #t #'pat)]
[(attempts-stx source-stx retries-stx) [(attempts-stx source-stx retries-stx print?-stx)
(apply values (apply values
(parse-kw-args `((#:attempts . ,#'default-check-attempts) (parse-kw-args `((#:attempts . ,#'default-check-attempts)
(#:source . #f) (#:source . #f)
(#:retries . ,#'default-retries)) (#:retries . ,#'default-retries)
(#:print? . #t))
(syntax kw-args) (syntax kw-args)
stx))]) stx))])
(with-syntax ([(name ...) names] (with-syntax ([(name ...) names]
@ -711,7 +712,8 @@
property)))]) property)))])
(quasisyntax/loc stx (quasisyntax/loc stx
(let ([att (assert-nat 'redex-check #,attempts-stx)] (let ([att (assert-nat 'redex-check #,attempts-stx)]
[ret (assert-nat 'redex-check #,retries-stx)]) [ret (assert-nat 'redex-check #,retries-stx)]
[print? #,print?-stx])
(unsyntax (unsyntax
(if source-stx (if source-stx
#`(let-values ([(metafunc/red-rel num-cases) #`(let-values ([(metafunc/red-rel num-cases)
@ -728,21 +730,27 @@
(max 1 (floor (/ att num-cases))) (max 1 (floor (/ att num-cases)))
ret ret
'redex-check 'redex-check
show (and print? show)
(test-match lang pat) (test-match lang pat)
(λ (generated) (redex-error 'redex-check "~s does not match ~s" generated 'pat)))) (λ (generated) (redex-error 'redex-check "~s does not match ~s" generated 'pat))))
#`(check-prop #`(check-prop
#,(term-generator #'lang #'pat #'random-decisions@ 'redex-check) #,(term-generator #'lang #'pat #'random-decisions@ 'redex-check)
property att ret show))) property att ret (and print? show)))))))))]))
(void))))))]))
(define (format-attempts a) (define (format-attempts a)
(format "~a attempt~a" a (if (= 1 a) "" "s"))) (format "~a attempt~a" a (if (= 1 a) "" "s")))
(define (check-prop generator property attempts retries show) (define (check-prop generator property attempts retries show)
(when (check generator property attempts retries show) (let ([c (check generator property attempts retries show)])
(if (counterexample? c)
(unless show c) ; check printed it
(if show
(show (format "no counterexamples in ~a\n" (show (format "no counterexamples in ~a\n"
(format-attempts attempts))))) (format-attempts attempts)))
#t))))
(define-struct (exn:fail:redex:test exn:fail:redex) (source term))
(define-struct counterexample (term))
(define (check generator property attempts retries show (define (check generator property attempts retries show
#:source [source #f] #:source [source #f]
@ -757,9 +765,16 @@
(with-handlers (with-handlers
([exn:fail? ([exn:fail?
(λ (exn) (λ (exn)
(show (when show
(format "checking ~s raises an exception\n" term)) (show (format "checking ~s raises an exception\n" term)))
(raise exn))]) (raise
(if show
exn
(make-exn:fail:redex:test
(format "checking ~s raises an exception:\n~a" term (exn-message exn))
(current-continuation-marks)
exn
term))))])
(property term bindings))) (property term bindings)))
(cond [(and match match-fail (match term)) (cond [(and match match-fail (match term))
=> (curry map (compose make-bindings match-bindings))] => (curry map (compose make-bindings match-bindings))]
@ -767,12 +782,13 @@
[else (list bindings)])) [else (list bindings)]))
(loop (sub1 remaining)) (loop (sub1 remaining))
(begin (begin
(when show
(show (show
(format "counterexample found after ~a~a:\n" (format "counterexample found after ~a~a:\n"
(format-attempts attempt) (format-attempts attempt)
(if source (format " with ~a" source) ""))) (if source (format " with ~a" source) "")))
(pretty-print term (current-output-port)) (pretty-print term (current-output-port)))
#f))))))) (make-counterexample term))))))))
(define-syntax (check-metafunction-contract stx) (define-syntax (check-metafunction-contract stx)
(syntax-case stx () (syntax-case stx ()
@ -811,34 +827,41 @@
[(reduction-relation? mf/rr) [(reduction-relation? mf/rr)
(values (map (λ (rwp) ((rewrite-proc-lhs rwp) lang)) (reduction-relation-make-procs mf/rr)) (values (map (λ (rwp) ((rewrite-proc-lhs rwp) lang)) (reduction-relation-make-procs mf/rr))
(reduction-relation-srcs mf/rr))])]) (reduction-relation-srcs mf/rr))])])
(when (for/and ([pat pats] [src srcs]) (let loop ([pats pats] [srcs srcs])
(with-handlers ([exn:fail:redex:generation-failure? (if (and (null? pats) (null? srcs))
(if show
(show
(format "no counterexamples in ~a (with each clause)\n"
(format-attempts attempts)))
#t)
(let ([c (with-handlers ([exn:fail:redex:generation-failure?
; Produce an error message that blames the LHS as a whole. ; Produce an error message that blames the LHS as a whole.
(λ (_) (λ (_)
(raise-gen-fail what (format "LHS of ~a" src) retries))]) (raise-gen-fail what (format "LHS of ~a" (car srcs)) retries))])
(check (check
(lang-gen pat) (lang-gen (car pats))
prop prop
attempts attempts
retries retries
show show
#:source src #:source (car srcs)
#:match match #:match match
#:match-fail match-fail))) #:match-fail match-fail))])
(show (if (counterexample? c)
(format "no counterexamples in ~a (with each clause)\n" (unless show c)
(format-attempts attempts))))))) (loop (cdr pats) (cdr srcs)))))))))
(define-syntax (check-metafunction stx) (define-syntax (check-metafunction stx)
(syntax-case stx () (syntax-case stx ()
[(_ name property . kw-args) [(_ name property . kw-args)
(with-syntax ([m (metafunc/err #'name stx)] (with-syntax ([m (metafunc/err #'name stx)]
[(attempts retries) [(attempts retries print?)
(parse-kw-args `((#:attempts . , #'default-check-attempts) (parse-kw-args `((#:attempts . , #'default-check-attempts)
(#:retries . ,#'default-retries)) (#:retries . ,#'default-retries)
(#:print? . #t))
(syntax kw-args) (syntax kw-args)
stx)] stx)])
[show (show-message stx)]) (with-syntax ([show (show-message stx)])
(syntax/loc stx (syntax/loc stx
(let ([att (assert-nat 'check-metafunction attempts)] (let ([att (assert-nat 'check-metafunction attempts)]
[ret (assert-nat 'check-metafunction retries)]) [ret (assert-nat 'check-metafunction retries)])
@ -850,7 +873,7 @@
att att
ret ret
'check-metafunction 'check-metafunction
show))))])) (and print? show))))))]))
(define (reduction-relation-srcs r) (define (reduction-relation-srcs r)
(map (λ (proc) (or (rewrite-proc-name proc) (map (λ (proc) (or (rewrite-proc-name proc)
@ -864,10 +887,11 @@
(define-syntax (check-reduction-relation stx) (define-syntax (check-reduction-relation stx)
(syntax-case stx () (syntax-case stx ()
[(_ relation property . kw-args) [(_ relation property . kw-args)
(with-syntax ([(attempts retries decisions@) (with-syntax ([(attempts retries decisions@ print?)
(parse-kw-args `((#:attempts . , #'default-check-attempts) (parse-kw-args `((#:attempts . , #'default-check-attempts)
(#:retries . ,#'default-retries) (#:retries . ,#'default-retries)
(#:decisions . ,#'random-decisions@)) (#:decisions . ,#'random-decisions@)
(#:print? . #t))
(syntax kw-args) (syntax kw-args)
stx)] stx)]
[show (show-message stx)]) [show (show-message stx)])
@ -883,7 +907,7 @@
attempts attempts
retries retries
'check-reduction-relation 'check-reduction-relation
show))))])) (and print? show)))))]))
(define-signature decisions^ (define-signature decisions^
(next-variable-decision (next-variable-decision
@ -921,7 +945,9 @@
(struct-out mismatch) (struct-out mismatch)
(struct-out class) (struct-out class)
(struct-out binder) (struct-out binder)
(struct-out base-cases)) (struct-out base-cases)
(struct-out counterexample)
(struct-out exn:fail:redex:test))
(provide pick-from-list pick-sequence-length pick-nts (provide pick-from-list pick-sequence-length pick-nts
pick-char pick-var pick-string pick-any pick-char pick-var pick-string pick-any

30
collects/redex/redex.scrbl
View File

@ -1166,11 +1166,13 @@ repeating as necessary. The optional keyword argument @scheme[retries-expr]
([kw-arg (code:line #:attempts attempts-expr) ([kw-arg (code:line #:attempts attempts-expr)
(code:line #:source metafunction) (code:line #:source metafunction)
(code:line #:source relation-expr) (code:line #:source relation-expr)
(code:line #:retries retries-expr)]) (code:line #:retries retries-expr)
(code:line #:print? print?-expr)])
#:contracts ([property-expr any/c] #:contracts ([property-expr any/c]
[attempts-expr natural-number/c] [attempts-expr natural-number/c]
[relation-expr reduction-relation?] [relation-expr reduction-relation?]
[retries-expr natural-number/c])]{ [retries-expr natural-number/c]
[print?-expr any/c])]{
Searches for a counterexample to @scheme[property-expr], interpreted Searches for a counterexample to @scheme[property-expr], interpreted
as a predicate universally quantified over the pattern variables as a predicate universally quantified over the pattern variables
bound by @scheme[pattern]. @scheme[redex-check] constructs and tests bound by @scheme[pattern]. @scheme[redex-check] constructs and tests
@ -1180,8 +1182,18 @@ using the @scheme[match-bindings] produced by @scheme[match]ing
@math{t} against @scheme[pattern]. @math{t} against @scheme[pattern].
@scheme[redex-check] generates at most @scheme[attempts-expr] (default @scheme[1000]) @scheme[redex-check] generates at most @scheme[attempts-expr] (default @scheme[1000])
random terms in its search. The size and complexity of terms it generates random terms in its search. The size and complexity of these terms increase with
gradually increases with each failed attempt. each failed attempt.
When @scheme[print?-expr] produces any non-@scheme[#f] value (the default),
@scheme[redex-check] prints the test outcome on @scheme[current-output-port].
When @scheme[print?-expr] produces @scheme[#f], @scheme[redex-check] prints
nothing, instead
@itemlist[
@item{returning a @scheme[counterexample] structure when the test reveals a counterexample,}
@item{returning @scheme[#t] when all tests pass, or}
@item{raising a @scheme[exn:fail:redex:test] when checking the property raises an exception.}
]
When passed a metafunction or reduction relation via the optional @scheme[#:source] When passed a metafunction or reduction relation via the optional @scheme[#:source]
argument, @scheme[redex-check] distributes its attempts across the left-hand sides argument, @scheme[redex-check] distributes its attempts across the left-hand sides
@ -1228,6 +1240,16 @@ term that does not match @scheme[pattern].}
#:attempts 3 #:attempts 3
#:source R))] #:source R))]
@defstruct[counterexample ([term any/c])]{
Produced by @scheme[redex-check], @scheme[check-reduction-relation], and
@scheme[check-metafunction] when testing falsifies a property.}
@defstruct[(exn:fail:redex:test exn:fail:redex) ([source exn:fail?] [term any/c])]{
Raised by @scheme[redex-check], @scheme[check-reduction-relation], and
@scheme[check-metafunction] when testing a property raises an exception.
The @scheme[exn:fail:redex:test-source] component contains the exception raised by the property,
and the @scheme[exn:fail:redex:test-term] component contains the term that induced the exception.}
@defform/subs[(check-reduction-relation relation property kw-args ...) @defform/subs[(check-reduction-relation relation property kw-args ...)
([kw-arg (code:line #:attempts attempts-expr) ([kw-arg (code:line #:attempts attempts-expr)
(code:line #:retries retries-expr)]) (code:line #:retries retries-expr)])

4
collects/redex/reduction-semantics.ss
View File

@ -50,7 +50,9 @@
check-metafunction check-metafunction
check-metafunction-contract check-metafunction-contract
check-reduction-relation check-reduction-relation
exn:fail:redex:generation-failure?) exn:fail:redex:generation-failure?
(struct-out exn:fail:redex:test)
(struct-out counterexample))
(provide/contract (provide/contract
[current-traced-metafunctions (parameter/c (or/c 'all (listof symbol?)))] [current-traced-metafunctions (parameter/c (or/c 'all (listof symbol?)))]

59
collects/redex/tests/rg-test.ss
View File

@ -540,6 +540,16 @@
(d 5) (d 5)
(e e 4) (e e 4)
(n number)) (n number))
(test (redex-check lang d #t #:attempts 1 #:print? (not #t)) #t)
(test (counterexample-term (redex-check lang d #f #:print? #f)) 5)
(let ([exn (with-handlers ([exn:fail:redex:test? values])
(redex-check lang d (error 'boom ":(") #:print? #f)
'not-an-exn)])
(test (exn-message exn) "checking 5 raises an exception:\nboom: :(")
(test (exn-message (exn:fail:redex:test-source exn)) "boom: :(")
(test (exn:fail:redex:test-term exn) 5))
(test (output (λ () (redex-check lang d #f))) (test (output (λ () (redex-check lang d #f)))
#rx"redex-check: .*:.*\ncounterexample found after 1 attempt:\n5\n") #rx"redex-check: .*:.*\ncounterexample found after 1 attempt:\n5\n")
(test (output (λ () (redex-check lang d #t))) (test (output (λ () (redex-check lang d #t)))
@ -574,17 +584,29 @@
(--> 0 dontcare z))))) (--> 0 dontcare z)))))
#rx"counterexample found after 1 attempt with z:\n0\n") #rx"counterexample found after 1 attempt with z:\n0\n")
(let ([generated null]) (let ([generated null]
[R (reduction-relation
lang
(--> 1 dontcare)
(--> 2 dontcare))])
(test (output (test (output
(λ () (λ ()
(redex-check lang n (set! generated (cons (term n) generated)) (redex-check lang n (set! generated (cons (term n) generated))
#:attempts 5 #:attempts 5
#:source (reduction-relation #:source R)))
lang
(--> 1 dontcare)
(--> 2 dontcare)))))
#rx"no counterexamples.*with each clause") #rx"no counterexamples.*with each clause")
(test generated '(2 2 1 1))) (test generated '(2 2 1 1))
(test (redex-check lang any #t
#:attempts 1
#:source R
#:print? (not #t))
#t)
(test (counterexample-term
(redex-check lang any (= (term any) 1)
#:source R
#:print? #f))
2))
(let () (let ()
(define-metafunction lang (define-metafunction lang
@ -595,7 +617,17 @@
(redex-check lang (n) (eq? 42 (term n)) (redex-check lang (n) (eq? 42 (term n))
#:attempts 1 #:attempts 1
#:source mf))) #:source mf)))
#px"counterexample found after 1 attempt with clause at .*:\\d+:\\d+:\n\\(0\\)\n")) #px"counterexample found after 1 attempt with clause at .*:\\d+:\\d+:\n\\(0\\)\n")
(test (redex-check lang any #t
#:attempts 1
#:source mf
#:print? (not #t))
#t)
(test (counterexample-term
(redex-check lang any (= (car (term any)) 42)
#:source mf
#:print? #f))
'(0)))
(let () (let ()
(define-metafunction lang (define-metafunction lang
@ -720,6 +752,14 @@
(E* hole E*) (E* hole E*)
(n 4)) (n 4))
(let ([R (reduction-relation
L
(--> 1 2)
(--> 2 3))])
(test (check-reduction-relation R (λ (_) #t) #:print? #f) #t)
(test (counterexample-term (check-reduction-relation R (curry = 1) #:print? #f))
2))
(let ([generated null] (let ([generated null]
[R (reduction-relation [R (reduction-relation
L L
@ -787,6 +827,11 @@
(define-metafunction empty (define-metafunction empty
[(n (side-condition any #f)) any]) [(n (side-condition any #f)) any])
(test (check-metafunction m (λ (_) #t) #:print? #f) #t)
(test (counterexample-term
(check-metafunction m (compose (curry = 1) car) #:print? #f))
'(2))
(let ([generated null]) (let ([generated null])
(test (begin (test (begin
(output (output