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

make check-metafunction and check-reduction-relation

Browse Source 
pay attention to the contract/#:domain spec

closes PR 13616
This commit is contained in:
Robby Findler 2013-03-17 20:35:48 -05:00
parent b63aa6bbac
commit 1e910fcfbc
3 changed files with 97 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

119
collects/redex/private/generate-term.rkt
View File

@ -159,7 +159,8 @@
(define (check generator property attempts retries show (define (check generator property attempts retries show
#:source [source #f] #:source [source #f]
#:term-fix [term-fix #f] #:term-fix [term-fix #f]
#:term-match [term-match #f]) #:term-match [term-match #f]
#:skip-term? [skip-term? (λ (x) #f)])
(let loop ([remaining attempts]) (let loop ([remaining attempts])
(if (zero? remaining) (if (zero? remaining)
#t #t
@ -180,62 +181,72 @@
term))))))]) term))))))])
(let ([term (with-handlers ([exn:fail? (handler "fixing" term)]) (let ([term (with-handlers ([exn:fail? (handler "fixing" term)])
(if term-fix (term-fix term) term))]) (if term-fix (term-fix term) term))])
(if (if term-match (cond
(let ([bindings (make-bindings [(skip-term? term) (loop (- remaining 1))]
(match-bindings [else
(pick-from-list (term-match term))))]) (if (if term-match
(with-handlers ([exn:fail? (handler "checking" term)]) (let ([bindings (make-bindings
(match property (match-bindings
[(term-prop pred) (pred term)] (pick-from-list (term-match term))))])
[(bind-prop pred) (pred bindings)]))) (with-handlers ([exn:fail? (handler "checking" term)])
(with-handlers ([exn:fail? (handler "checking" term)]) (match property
(match (cons property term-fix) [(term-prop pred) (pred term)]
[(cons (term-prop pred) _) (pred term)] [(bind-prop pred) (pred bindings)])))
[(cons (bind-prop pred) #f) (pred bindings)]))) (with-handlers ([exn:fail? (handler "checking" term)])
(loop (sub1 remaining)) (match (cons property term-fix)
(begin [(cons (term-prop pred) _) (pred term)]
(when show [(cons (bind-prop pred) #f) (pred bindings)])))
(show (loop (sub1 remaining))
(format "counterexample found after ~a~a:\n" (begin
(format-attempts attempt) (when show
(if source (format " with ~a" source) ""))) (show
(pretty-write term (current-output-port))) (format "counterexample found after ~a~a:\n"
(make-counterexample term))))))))) (format-attempts attempt)
(if source (format " with ~a" source) "")))
(pretty-write term (current-output-port)))
(make-counterexample term)))])))))))
(define (check-lhs-pats lang mf/rr prop attempts retries what show term-fix (define (check-lhs-pats lang mf/rr prop attempts retries what show term-fix
#:term-match [term-match #f]) #:term-match [term-match #f])
(let ([lang-gen (compile lang what)]) (define lang-gen (compile lang what))
(let-values ([(pats srcs) (define-values (pats srcs skip-term?)
(cond [(metafunc-proc? mf/rr) (cond [(metafunc-proc? mf/rr)
(values (map (λ (case) ((metafunc-case-lhs+ case) lang)) (values (map (λ (case) ((metafunc-case-lhs+ case) lang))
(metafunc-proc-cases mf/rr)) (metafunc-proc-cases mf/rr))
(metafunction-srcs mf/rr))] (metafunction-srcs mf/rr)
[(reduction-relation? mf/rr) (compose not (metafunc-proc-in-dom? mf/rr)))]
(values (map (λ (rwp) ((rewrite-proc-lhs rwp) lang)) (reduction-relation-make-procs mf/rr)) [(reduction-relation? mf/rr)
(reduction-relation-srcs mf/rr))])]) (values (map (λ (rwp) ((rewrite-proc-lhs rwp) lang)) (reduction-relation-make-procs mf/rr))
(let loop ([pats pats] [srcs srcs]) (reduction-relation-srcs mf/rr)
(if (and (null? pats) (null? srcs)) (let ([pat (compile-pattern (reduction-relation-lang mf/rr)
(if show (reduction-relation-domain-pat mf/rr)
(show #f)])
(format "no counterexamples in ~a (with each clause)\n" (λ (x) (not (match-pattern? pat x)))))]))
(format-attempts attempts)))
#t) (let loop ([pats pats] [srcs srcs])
(let ([c (with-handlers ([exn:fail:redex:generation-failure? (if (and (null? pats) (null? srcs))
; Produce an error message that blames the LHS as a whole. (if show
(λ (_) (show
(raise-gen-fail what (format "LHS of ~a" (car srcs)) retries))]) (format "no counterexamples in ~a (with each clause)\n"
(check (format-attempts attempts)))
(lang-gen (car pats)) #t)
prop (let ([c (with-handlers ([exn:fail:redex:generation-failure?
attempts ; Produce an error message that blames the LHS as a whole.
retries (λ (_)
show (raise-gen-fail what (format "LHS of ~a" (car srcs)) retries))])
#:source (car srcs) (check
#:term-match term-match (lang-gen (car pats))
#:term-fix term-fix))]) prop
(if (counterexample? c) attempts
(unless show c) retries
(loop (cdr pats) (cdr srcs))))))))) show
#:skip-term? skip-term?
#:source (car srcs)
#:term-match term-match
#:term-fix term-fix))])
(if (counterexample? c)
(unless show c)
(loop (cdr pats) (cdr srcs)))))))
(define-syntax (check-metafunction stx) (define-syntax (check-metafunction stx)
(syntax-case stx () (syntax-case stx ()

25
collects/redex/tests/rg-test.rkt
View File

@ -1048,6 +1048,17 @@
#:attempts 1)))) #:attempts 1))))
#rx"no counterexamples")) #rx"no counterexamples"))
;; just check that this doesn't raise an errors.
(let ()
(define-language empty)
(define red (reduction-relation
empty
#:domain 1
(--> any any)))
(check-reduction-relation
red
(λ (x) (apply-reduction-relation red x))))
(let ([U (reduction-relation L (--> (side-condition any #f) any))]) (let ([U (reduction-relation L (--> (side-condition any #f) any))])
(test (raised-exn-msg (test (raised-exn-msg
exn:fail:redex:generation-failure? exn:fail:redex:generation-failure?
@ -1229,6 +1240,20 @@
(check-metafunction n (λ (_) #t) #:retries 42)) (check-metafunction n (λ (_) #t) #:retries 42))
#rx"check-metafunction: unable .* in 42") #rx"check-metafunction: unable .* in 42")
(let ()
(define-metafunction empty
mf : 1 -> 1
[(mf any) any])
;; just make sure no errors
(test (begin
(check-metafunction
mf
(λ (args) (term (mf ,@args))))
42)
42))
(let () (let ()
(define-metafunction empty bogo : any -> any) (define-metafunction empty bogo : any -> any)

7
doc/release-notes/redex/HISTORY.txt
View File

@ -4,6 +4,13 @@ v5.3.4
have overlapping non-terminals; in that case the productions are have overlapping non-terminals; in that case the productions are
combined combined
* Adjust check-metafunction and check-reduction-relation so that
they skip over randomly generated terms that don't match the
contract spec (or #:domain spec). This means that when there is a
case in the metafunction (or reduction-relation) whose nominal
pattern is more general than the contract would allow, that those
terms are discarded instead of used as inputs to the predicate.
v5.3.3 v5.3.3
No changes No changes