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

Changed redex-check's #:source keyword to always generate from the

Browse Source 
LHSs of the metafunction/relation.

svn: r13310
This commit is contained in:
Casey Klein 2009-01-29 00:41:30 +00:00
parent 46300fd96e
commit b86e4473f0
3 changed files with 127 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

79
collects/redex/private/rg-test.ss
View File

@ -574,55 +574,58 @@
(test m "error: pred-raised") (test m "error: pred-raised")
(test (get-output-string p) #rx"checking 5 raises.*\n$") (test (get-output-string p) #rx"checking 5 raises.*\n$")
(close-output-port p)) (close-output-port p))
(test (parameterize ([check-randomness (make-random 0 0)])
(output
(λ ()
(redex-check lang n (eq? 42 (term n))
#:attempts 1
#:source (reduction-relation lang (--> 42 x))))))
"")
(test (output (test (output
(λ () (λ ()
(parameterize ([check-randomness (make-random 0 0)]) (redex-check lang n (eq? 42 (term n))
(redex-check lang n (eq? 42 (term n)) #:attempts 1
#:attempts 1 #:source (reduction-relation
#:source (reduction-relation lang (--> 0 x z)))))) lang
"counterexample found (z) after 1 attempts:\n0\n") (--> 42 dontcare)
(test (output (--> 0 dontcare z)))))
(λ () "counterexample found after 1 attempts with z:\n0\n")
(parameterize ([check-randomness (make-random 1)])
(redex-check lang d (eq? 42 (term n)) (let ([generated null])
#:attempts 1 (test (output
#:source (reduction-relation lang (--> 0 x z))))))
"counterexample found after 1 attempts:\n5\n")
(test (let ([r (reduction-relation lang (--> 0 x z))])
(output
(λ () (λ ()
(redex-check lang n (number? (term n)) (redex-check lang n (set! generated (cons (term n) generated))
#:attempts 10 #:attempts 5
#:source r)))) #:source (reduction-relation
"") lang
(--> 1 dontcare)
(--> 2 dontcare)))))
"")
(test generated '(2 2 1 1)))
(let () (let ()
(define-metafunction lang (define-metafunction lang
[(mf 0) 0] [(mf 42) dontcare]
[(mf 42) 0]) [(mf 0) dontcare])
(test (parameterize ([check-randomness (make-random 0 1)]) (test (output
(output (λ ()
(λ () (redex-check lang (n) (eq? 42 (term n))
(redex-check lang (n) (eq? 42 (term n)) #:attempts 1
#:attempts 1 #:source mf)))
#:source mf)))) "counterexample found after 1 attempts with clause #2:\n(0)\n"))
""))
(let () (let ()
(define-language L) (define-metafunction lang
(test (with-handlers ([exn:fail? exn-message]) [(mf d e) dontcare])
(redex-check lang any #t #:source (reduction-relation L (--> 1 1)))) (test (output
#rx"language for secondary source")) (λ ()
(redex-check lang (number_1 number_2)
(and (= (term number_1) 5)
(= (term number_2) 4))
#:attempts 1
#:source mf)))
""))
(let () (let ()
(test (with-handlers ([exn:fail? exn-message]) (test (with-handlers ([exn:fail? exn-message])
(redex-check lang n #t #:source (reduction-relation lang (--> x 1)))) (redex-check lang n #t #:source (reduction-relation lang (--> x 1))))
#rx"x does not match n")) #rx"x does not match n"))
(let ([stx-err (λ (stx) (let ([stx-err (λ (stx)
(with-handlers ([exn:fail:syntax? exn-message]) (with-handlers ([exn:fail:syntax? exn-message])
(expand stx) (expand stx)

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

@ -669,8 +669,6 @@ To do a better job of not generating programs with free variables,
[(_ lang pat size) [(_ lang pat size)
(syntax/loc stx (generate-term lang pat size #:attempt 1))])) (syntax/loc stx (generate-term lang pat size #:attempt 1))]))
(define check-randomness (make-parameter random))
(define-syntax (redex-check stx) (define-syntax (redex-check stx)
(syntax-case stx () (syntax-case stx ()
[(_ lang pat property . kw-args) [(_ lang pat property . kw-args)
@ -693,57 +691,48 @@ To do a better job of not generating programs with free variables,
(with-syntax ([(name ...) names] (with-syntax ([(name ...) names]
[(name/ellipses ...) names/ellipses] [(name/ellipses ...) names/ellipses]
[attempts (or attempts-stx #'default-check-attempts)]) [attempts (or attempts-stx #'default-check-attempts)])
(quasisyntax/loc stx (with-syntax ([property (syntax
(let ([att attempts]) (λ (_ bindings)
(assert-nat 'redex-check att) (term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
(check-property property)))])
(cons (list #,(term-generator #'lang #'pat #'random-decisions@ 'redex-check) #f) (quasisyntax/loc stx
(let ([lang-gen (generate lang random-decisions@)]) (let ([att attempts])
#,(if (not source-stx) (assert-nat 'redex-check att)
#'null (unsyntax
#`(let-values (if source-stx
([(pats srcs src-lang) #`(let-values
#,(cond [(and (identifier? source-stx) (metafunc source-stx)) ([(pats srcs src-lang)
=> #,(cond [(and (identifier? source-stx) (metafunc source-stx))
(λ (m) #`(values (metafunc-proc-lhs-pats #,m) =>
(metafunc-srcs #,m) (λ (m) #`(values (metafunc-proc-lhs-pats #,m)
(metafunc-proc-lang #,m)))] (metafunc-srcs #,m)
[else (metafunc-proc-lang #,m)))]
#`(let ([r #,source-stx]) [else
(unless (reduction-relation? r) #`(let ([r #,source-stx])
(raise-type-error 'redex-check "reduction-relation" r)) (unless (reduction-relation? r)
(values (raise-type-error 'redex-check "reduction-relation" r))
(map rewrite-proc-lhs (reduction-relation-make-procs r)) (values
(reduction-relation-srcs r) (map rewrite-proc-lhs (reduction-relation-make-procs r))
(reduction-relation-lang r)))])]) (reduction-relation-srcs r)
(unless (eq? src-lang lang) (reduction-relation-lang r)))])])
(error 'redex-check "language for secondary source must match primary pattern's language")) (check-property-many
(zip (map lang-gen pats) srcs))))) lang pats srcs property random-decisions@ (max 1 (floor (/ att (length pats))))
#,(and source-stx #'(test-match lang pat)) (test-match lang pat)
(λ (generated) (error 'redex-check "~s does not match ~s" generated 'pat)) (λ (generated) (error 'redex-check "~s does not match ~s" generated 'pat))))
(λ (_ bindings) #`(check-property
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...) #,(term-generator #'lang #'pat #'random-decisions@ 'redex-check)
property)) property att)))
att (void))))))]))
(λ (term attempt source port)
(fprintf port "counterexample found~aafter ~a attempts:\n"
(if source (format " (~a) " source) " ") attempt)
(pretty-print term port))
(check-randomness))
(void)))))]))
(define (check-property gens-srcs match match-fail property attempts display [random random]) (define (check-property generator property attempts
#:source [source #f]
#:match [match #f]
#:match-fail [match-fail #f])
(let loop ([remaining attempts]) (let loop ([remaining attempts])
(if (zero? remaining) (if (zero? remaining)
#t #t
(let ([attempt (add1 (- attempts remaining))]) (let ([attempt (add1 (- attempts remaining))])
(let*-values ([(generator source) (let-values ([(term bindings) (generator (attempt->size attempt) attempt)])
(apply values
(if (and (not (null? (cdr gens-srcs))) (zero? (random 10)))
(pick-from-list (cdr gens-srcs) random)
(car gens-srcs)))]
[(term bindings)
(generator (attempt->size attempt) attempt)])
(if (andmap (λ (bindings) (if (andmap (λ (bindings)
(with-handlers ([exn:fail? (λ (exn) (with-handlers ([exn:fail? (λ (exn)
(fprintf (current-error-port) (fprintf (current-error-port)
@ -757,7 +746,11 @@ To do a better job of not generating programs with free variables,
[else (list bindings)])) [else (list bindings)]))
(loop (sub1 remaining)) (loop (sub1 remaining))
(begin (begin
(display term attempt source (current-output-port)) (fprintf (current-output-port)
"counterexample found after ~a attempts~a:\n"
attempt
(if source (format " with ~a" source) ""))
(pretty-print term (current-output-port))
#f))))))) #f)))))))
(define-syntax (check-metafunction-contract stx) (define-syntax (check-metafunction-contract stx)
@ -775,32 +768,23 @@ To do a better job of not generating programs with free variables,
[att attempts]) [att attempts])
(assert-nat 'check-metafunction-contract att) (assert-nat 'check-metafunction-contract att)
(check-property (check-property
(list (list ((generate lang decisions@) (if dom dom '(any (... ...)))) #f)) ((generate lang decisions@) (if dom dom '(any (... ...))))
#f
#f
(λ (t _) (λ (t _)
(with-handlers ([exn:fail:redex? (λ (_) #f)]) (with-handlers ([exn:fail:redex? (λ (_) #f)])
(begin (term (name ,@t)) #t))) (begin (term (name ,@t)) #t)))
att att)
(λ (term attempt _ port)
(fprintf port "counterexample found after ~a attempts:\n" attempt)
(pretty-print term port)))
(void))))])) (void))))]))
(define (check-property-many lang pats srcs prop decisions@ attempts) (define (check-property-many lang pats srcs prop decisions@ attempts [match #f] [match-fail #f])
(let ([lang-gen (generate lang decisions@)]) (let ([lang-gen (generate lang decisions@)])
(for/and ([pat pats] [src srcs]) (for/and ([pat pats] [src srcs])
(check-property (check-property
(let ([gen (lang-gen pat)]) (lang-gen pat)
(list (list (λ (size attempt) (gen size attempt)) src))) prop
#f
#f
(λ (term _) (prop term))
attempts attempts
(λ (term attempt source port) #:source src
(fprintf port "counterexample found after ~a attempts with ~a:\n" #:match match
attempt source) #:match-fail match-fail))
(pretty-print term port))))
(void))) (void)))
(define (metafunc-srcs m) (define (metafunc-srcs m)
@ -820,7 +804,7 @@ To do a better job of not generating programs with free variables,
(metafunc-proc-lang m) (metafunc-proc-lang m)
(metafunc-proc-lhs-pats m) (metafunc-proc-lhs-pats m)
(metafunc-srcs m) (metafunc-srcs m)
property (λ (term _) (property term))
(generation-decisions) (generation-decisions)
att))))])) att))))]))
@ -836,7 +820,7 @@ To do a better job of not generating programs with free variables,
(reduction-relation-lang relation) (reduction-relation-lang relation)
(map rewrite-proc-lhs (reduction-relation-make-procs relation)) (map rewrite-proc-lhs (reduction-relation-make-procs relation))
(reduction-relation-srcs relation) (reduction-relation-srcs relation)
property (λ (term _) (property term))
decisions@ decisions@
attempts)) attempts))
@ -868,7 +852,7 @@ To do a better job of not generating programs with free variables,
(struct-out ellipsis) (struct-out mismatch) (struct-out class) (struct-out ellipsis) (struct-out mismatch) (struct-out class)
(struct-out binder) check-metafunction-contract prepare-lang (struct-out binder) check-metafunction-contract prepare-lang
pick-number parse-language check-reduction-relation pick-number parse-language check-reduction-relation
preferred-production-threshold check-metafunction check-randomness preferred-production-threshold check-metafunction
generation-decisions pick-preferred-productions) generation-decisions pick-preferred-productions)
(provide/contract (provide/contract

44
collects/redex/redex.scrbl
View File

@ -1058,6 +1058,16 @@ these free @pattech[term]-variables by generating random terms matching
@scheme[pattern] and extracting the sub-terms bound by the @scheme[pattern] and extracting the sub-terms bound by the
@pattech[names] and non-terminals in @scheme[pattern]. @pattech[names] and non-terminals in @scheme[pattern].
@scheme[redex-check] generates at most @scheme[attempts-expr] (default @scheme[100])
random terms in its search. The size and complexity of terms it generates
gradually increases with each failed attempt.
When passed a metafunction or reduction relation via the optional @scheme[#:source]
argument, @scheme[redex-check] distributes its attempts across the left-hand sides
of that metafunction/relation by using those patterns, rather than @scheme[pattern],
as the basis of its generation. It is an error if any left-hand side generates a
term that does not match @scheme[pattern].}
@examples[ @examples[
#:eval redex-eval #:eval redex-eval
(define-language empty-lang) (define-language empty-lang)
@ -1081,27 +1091,37 @@ these free @pattech[term]-variables by generating random terms matching
(term (number_2 ...)))) (term (number_2 ...))))
(append (reverse (term (number_2 ...))) (append (reverse (term (number_2 ...)))
(reverse (term (number_1 ...))))) (reverse (term (number_1 ...)))))
#:attempts 200)] #:attempts 200)
@scheme[redex-check] generates at most @scheme[attempts-expr] (default @scheme[100]) (let ([R (reduction-relation
random terms in its search. The size and complexity of terms it generates empty-lang
gradually increases with each failed attempt. (--> (Σ) 0)
(--> (Σ number) number)
When the optional @scheme[#:source] argument is present, @scheme[redex-check] (--> (Σ number_1 number_2 number_3 ...)
generates @math{10%} of its terms by randomly choosing a pattern from the (Σ ,(+ (term number_1) (term number_2))
left-hand sides the definition of the supplied metafunction or relation. number_3 ...)))])
@scheme[redex-check] raises an exception if a term generated from an alternate (redex-check
pattern does not match the @scheme[pattern].} empty-lang
(Σ number ...)
(printf "~s\n" (term (number ...)))
#:attempts 3
#:source R))]
@defproc[(check-reduction-relation @defproc[(check-reduction-relation
[relation reduction-relation?] [relation reduction-relation?]
[property (-> any/c any/c)] [property (-> any/c any/c)]
[#:attempts attempts natural-number/c 100]) [#:attempts attempts natural-number/c 100])
void?]{ void?]{
Tests a @scheme[relation] as follows: for each case of @scheme[relation], Tests @scheme[relation] as follows: for each case of @scheme[relation],
@scheme[check-reduction-relation] generates @scheme[attempts] random @scheme[check-reduction-relation] generates @scheme[attempts] random
terms that match that case's left-hand side and applies @scheme[property] terms that match that case's left-hand side and applies @scheme[property]
to each random term.} to each random term.
This function provides a more convenient notation for
@schemeblock[(redex-check L any (property (term any))
#:attempts (* n attempts)
#:source relation)]
when @scheme[relation] is a relation on @scheme[L] and has @scheme[n] rules.}
@defform*[[(check-metafunction metafunction property) @defform*[[(check-metafunction metafunction property)
(check-metafunction metafunction property #:attempts attempts)] (check-metafunction metafunction property #:attempts attempts)]