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

Adds #:prepare keyword to random testing forms

Browse Source
This commit is contained in:
Casey Klein 2010-07-21 08:22:43 -05:00
parent 392d22ff3c
commit 541a0c4ecb
3 changed files with 299 additions and 130 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

165
collects/redex/private/rg.rkt
View File

@ -102,29 +102,27 @@
;; E = 0 => p = 1, which breaks random-natural ;; E = 0 => p = 1, which breaks random-natural
(/ 1 (+ (max 1 E) 1))) (/ 1 (+ (max 1 E) 1)))
; Determines a size measure for numbers, sequences, etc., using the (define-for-syntax (apply-contract ctc expr desc redex-form)
; attempt count. #`(contract #,ctc #,expr
(define attempt->size #,(let ([m (syntax-source-module expr)])
(make-parameter (λ (n) (inexact->exact (floor (/ (log (add1 n)) (log 5)))))))
(define-for-syntax (with-attempt->size arg-stx redex-form body)
(if arg-stx
#`(parameterize ([attempt->size
(contract (-> natural-number/c natural-number/c) #,arg-stx
#,(let ([m (syntax-source-module arg-stx)])
(cond [(module-path-index? m) (cond [(module-path-index? m)
(format "~a" (module-path-index-resolve m))] (format "~a" (module-path-index-resolve m))]
[(or (symbol? m) (path? m)) [(or (symbol? m) (path? m))
(format "~a" m)] (format "~a" m)]
[else (format "~s client" redex-form)])) [else (format "~s client" redex-form)]))
'#,redex-form '#,redex-form #,desc
"#:attempt-size argument" #(#,(syntax-source expr)
#(#,(syntax-source arg-stx) #,(syntax-line expr)
#,(syntax-line arg-stx) #,(syntax-column expr)
#,(syntax-column arg-stx) #,(syntax-position expr)
#,(syntax-position arg-stx) #,(syntax-span expr))))
#,(syntax-span arg-stx)))])
#,body) ; Determines a size measure for numbers, sequences, etc., using the
body)) ; attempt count.
(define default-attempt->size
(λ (n) (inexact->exact (floor (/ (log (add1 n)) (log 5))))))
(define attempt->size
(make-parameter default-attempt->size))
(define (pick-number attempt #:top-threshold [top-threshold complex-threshold] [random random]) (define (pick-number attempt #:top-threshold [top-threshold complex-threshold] [random random])
(let loop ([threshold 0] (let loop ([threshold 0]
@ -722,35 +720,45 @@
"~a: ~a~a" "~a: ~a~a"
'what (if loc (string-append loc "\n") "") msg)))])) 'what (if loc (string-append loc "\n") "") msg)))]))
(define-for-syntax (contracted-fix stx form [ctc #'(-> any/c any/c)])
(and stx (apply-contract ctc stx "#:attempt-size argument" form)))
(define-for-syntax (contracted-attempt-size stx form)
(apply-contract #'(-> natural-number/c natural-number/c) stx "#:prepare argument" form))
(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)
(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 print?-stx size-stx) [(attempts-stx source-stx retries-stx print?-stx size-stx fix-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) (#:print? . #t)
(#:attempt-size . #f)) (#:attempt-size . ,#'default-attempt->size)
(#:prepare . #f))
(syntax kw-args) (syntax kw-args)
stx))]) stx))])
(with-syntax ([(name ...) names] (with-syntax ([(name ...) names]
[(name/ellipses ...) names/ellipses] [(name/ellipses ...) names/ellipses]
[show (show-message stx)]) [show (show-message stx)])
(with-syntax ([property (syntax (with-syntax ([property (syntax
(λ (_ bindings) (bind-prop
(λ (bindings)
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...) (term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
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]) [print? #,print?-stx]
#,(with-attempt->size [fix #,(contracted-fix fix-stx 'redex-check)]
size-stx 'redex-check [term-match (λ (generated)
(if source-stx (cond [(test-match lang pat generated) => values]
[else (redex-error 'redex-check "~s does not match ~s" generated 'pat)]))])
(parameterize ([attempt->size #,(contracted-attempt-size size-stx 'redex-check)])
#,(if source-stx
#`(let-values ([(metafunc/red-rel num-cases) #`(let-values ([(metafunc/red-rel num-cases)
#,(cond [(and (identifier? source-stx) (metafunc source-stx)) #,(cond [(and (identifier? source-stx) (metafunc source-stx))
=> (λ (x) #`(values #,x (length (metafunc-proc-cases #,x))))] => (λ (x) #`(values #,x (length (metafunc-proc-cases #,x))))]
@ -765,17 +773,19 @@
ret ret
'redex-check 'redex-check
(and print? show) (and print? show)
(test-match lang pat) fix
(λ (generated) (redex-error 'redex-check "~s does not match ~s" generated 'pat)))) #:term-match term-match))
#`(check-prop #`(check-prop
#,(term-generator #'lang #'pat 'redex-check) #,(term-generator #'lang #'pat 'redex-check)
property att ret (and print? show)))))))))])) property att ret (and print? show) fix (and fix term-match)))))))))]))
(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 term-fix term-match)
(let ([c (check generator property attempts retries show)]) (let ([c (check generator property attempts retries show
#:term-fix term-fix
#:term-match term-match)])
(if (counterexample? c) (if (counterexample? c)
(unless show c) ; check printed it (unless show c) ; check printed it
(if show (if show
@ -786,34 +796,45 @@
(define-struct (exn:fail:redex:test exn:fail:redex) (source term)) (define-struct (exn:fail:redex:test exn:fail:redex) (source term))
(define-struct counterexample (term) #:transparent) (define-struct counterexample (term) #:transparent)
(define-struct term-prop (pred))
(define-struct bind-prop (pred))
(define (check generator property attempts retries show (define (check generator property attempts retries show
#:source [source #f] #:source [source #f]
#:match [match #f] #:term-fix [term-fix #f]
#:match-fail [match-fail #f]) #:term-match [term-match #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 ([(term bindings) (generator ((attempt->size) attempt) attempt retries)]) (let-values ([(term bindings) (generator ((attempt->size) attempt) attempt retries)]
(if (andmap (λ (bindings) [(handler)
(with-handlers (λ (action term)
([exn:fail?
(λ (exn) (λ (exn)
(when show (let ([msg (format "~a ~s raises an exception" action term)])
(show (format "checking ~s raises an exception\n" term))) (when show (show (format "~a\n" msg)))
(raise (raise
(if show (if show
exn exn
(make-exn:fail:redex:test (make-exn:fail:redex:test
(format "checking ~s raises an exception:\n~a" term (exn-message exn)) (format "~a:\n~a" msg (exn-message exn))
(current-continuation-marks) (current-continuation-marks)
exn exn
term))))]) term))))))])
(property term bindings))) (let ([term (with-handlers ([exn:fail? (handler "fixing" term)])
(cond [(and match match-fail (match term)) (if term-fix (term-fix term) term))])
=> (curry map (compose make-bindings match-bindings))] (if (if term-match
[match (match-fail term)] (let ([bindings (make-bindings
[else (list bindings)])) (match-bindings
(pick-from-list (term-match term))))])
(with-handlers ([exn:fail? (handler "checking" term)])
(match property
[(term-prop pred) (pred term)]
[(bind-prop pred) (pred bindings)])))
(with-handlers ([exn:fail? (handler "checking" term)])
(match (cons property term-fix)
[(cons (term-prop pred) _) (pred term)]
[(cons (bind-prop pred) #f) (pred bindings)])))
(loop (sub1 remaining)) (loop (sub1 remaining))
(begin (begin
(when show (when show
@ -822,7 +843,7 @@
(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)))
(make-counterexample term)))))))) (make-counterexample term)))))))))
(define-syntax (check-metafunction-contract stx) (define-syntax (check-metafunction-contract stx)
(syntax-case stx () (syntax-case stx ()
@ -842,16 +863,18 @@
(check-prop (check-prop
((compile lang 'check-metafunction-contract) ((compile lang 'check-metafunction-contract)
(if dom dom '(any (... ...)))) (if dom dom '(any (... ...))))
(λ (t _) (term-prop
(λ (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
retries retries
show))))])) show
#f
#f))))]))
(define (check-lhs-pats lang mf/rr prop attempts retries what show (define (check-lhs-pats lang mf/rr prop attempts retries what show term-fix
[match #f] #:term-match [term-match #f])
[match-fail #f])
(let ([lang-gen (compile lang what)]) (let ([lang-gen (compile lang what)])
(let-values ([(pats srcs) (let-values ([(pats srcs)
(cond [(metafunc-proc? mf/rr) (cond [(metafunc-proc? mf/rr)
@ -878,8 +901,8 @@
retries retries
show show
#:source (car srcs) #:source (car srcs)
#:match match #:term-match term-match
#:match-fail match-fail))]) #:term-fix term-fix))])
(if (counterexample? c) (if (counterexample? c)
(unless show c) (unless show c)
(loop (cdr pats) (cdr srcs))))))))) (loop (cdr pats) (cdr srcs)))))))))
@ -887,28 +910,30 @@
(define-syntax (check-metafunction stx) (define-syntax (check-metafunction stx)
(syntax-case stx () (syntax-case stx ()
[(_ name property . kw-args) [(_ name property . kw-args)
(let-values ([(attempts retries print? size) (let-values ([(attempts retries print? size fix)
(apply values (apply values
(parse-kw-args `((#:attempts . , #'default-check-attempts) (parse-kw-args `((#:attempts . , #'default-check-attempts)
(#:retries . ,#'default-retries) (#:retries . ,#'default-retries)
(#:print? . #t) (#:print? . #t)
(#:attempt-size . #f)) (#:attempt-size . ,#'default-attempt->size)
(#:prepare . #f))
(syntax kw-args) (syntax kw-args)
stx))] stx))]
[(m) (metafunc/err #'name stx)]) [(m) (metafunc/err #'name stx)])
(with-attempt->size
size 'check-metafunction
(quasisyntax/loc stx (quasisyntax/loc stx
(parameterize ([attempt->size #,(contracted-attempt-size size 'check-metafunction)])
(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)]
[fix #,(contracted-fix fix 'check-metafunction #'(-> (listof any/c) (listof any/c)))])
(check-lhs-pats (check-lhs-pats
(metafunc-proc-lang #,m) (metafunc-proc-lang #,m)
#,m #,m
(λ (term _) (property term)) (term-prop property)
att att
ret ret
'check-metafunction 'check-metafunction
(and #,print? #,(show-message stx)))))))])) (and #,print? #,(show-message stx))
fix)))))]))
(define (reduction-relation-srcs r) (define (reduction-relation-srcs r)
(map (λ (proc) (or (rewrite-proc-name proc) (map (λ (proc) (or (rewrite-proc-name proc)
@ -922,28 +947,30 @@
(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)
(let-values ([(attempts retries print? size) (let-values ([(attempts retries print? size fix)
(apply values (apply values
(parse-kw-args `((#:attempts . , #'default-check-attempts) (parse-kw-args `((#:attempts . , #'default-check-attempts)
(#:retries . ,#'default-retries) (#:retries . ,#'default-retries)
(#:print? . #t) (#:print? . #t)
(#:attempt-size . #f)) (#:attempt-size . ,#'default-attempt->size)
(#:prepare . #f))
(syntax kw-args) (syntax kw-args)
stx))]) stx))])
(with-attempt->size
size 'check-reduction-relation
(quasisyntax/loc stx (quasisyntax/loc stx
(parameterize ([attempt->size #,(contracted-attempt-size size 'check-reduction-relation)])
(let ([att (assert-nat 'check-reduction-relation #,attempts)] (let ([att (assert-nat 'check-reduction-relation #,attempts)]
[ret (assert-nat 'check-reduction-relation #,retries)] [ret (assert-nat 'check-reduction-relation #,retries)]
[rel (assert-rel 'check-reduction-relation relation)]) [rel (assert-rel 'check-reduction-relation relation)]
[fix #,(contracted-fix fix 'check-reduction-relation)])
(check-lhs-pats (check-lhs-pats
(reduction-relation-lang rel) (reduction-relation-lang rel)
rel rel
(λ (term _) (property term)) (term-prop property)
att att
ret ret
'check-reduction-relation 'check-reduction-relation
(and #,print? #,(show-message stx)))))))])) (and #,print? #,(show-message stx))
fix)))))]))
(define-signature decisions^ (define-signature decisions^
(next-variable-decision (next-variable-decision

42
collects/redex/redex.scrbl
View File

@ -1210,13 +1210,15 @@ repeating as necessary. The optional keyword argument @racket[retries-expr]
(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) (code:line #:print? print?-expr)
(code:line #:attempt-size attempt-size-expr)]) (code:line #:attempt-size attempt-size-expr)
(code:line #:prepare prepare-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] [print?-expr any/c]
[attempt-size-expr (-> natural-number/c natural-number/c)])]{ [attempt-size-expr (-> natural-number/c natural-number/c)]
[prepare-expr (-> any/c any/c)])]{
Searches for a counterexample to @racket[property-expr], interpreted Searches for a counterexample to @racket[property-expr], interpreted
as a predicate universally quantified over the pattern variables as a predicate universally quantified over the pattern variables
bound by @racket[pattern]. @racket[redex-check] constructs and tests bound by @racket[pattern]. @racket[redex-check] constructs and tests
@ -1242,6 +1244,14 @@ nothing, instead
@item{raising a @racket[exn:fail:redex:test] when checking the property raises an exception.} @item{raising a @racket[exn:fail:redex:test] when checking the property raises an exception.}
] ]
The optional @racket[#:prepare] keyword supplies a function that transforms each
generated example before @racket[redex-check] checks @racket[property-expr].
This keyword may be useful when @racket[property-expr] takes the form
of a conditional, and a term chosen freely from the grammar is unlikely to
satisfy the conditional's hypothesis. In some such cases, the @racket[prepare]
keyword can be used to increase the probability that an example satifies the
hypothesis.
When passed a metafunction or reduction relation via the optional @racket[#:source] When passed a metafunction or reduction relation via the optional @racket[#:source]
argument, @racket[redex-check] distributes its attempts across the left-hand sides argument, @racket[redex-check] distributes its attempts across the left-hand sides
of that metafunction/relation by using those patterns, rather than @racket[pattern], of that metafunction/relation by using those patterns, rather than @racket[pattern],
@ -1285,7 +1295,18 @@ term that does not match @racket[pattern].}
(Σ number ...) (Σ number ...)
(printf "~s\n" (term (number ...))) (printf "~s\n" (term (number ...)))
#:attempts 3 #:attempts 3
#:source R))] #:source R))
(redex-check
empty-lang
number
(begin
(printf "checking ~s\n" (term number))
(positive? (term number)))
#:prepare (λ (n)
(printf "preparing ~s; " n)
(add1 (abs n)))
#:attempts 3)]
@defstruct[counterexample ([term any/c]) #:inspector #f]{ @defstruct[counterexample ([term any/c]) #:inspector #f]{
Produced by @racket[redex-check], @racket[check-reduction-relation], and Produced by @racket[redex-check], @racket[check-reduction-relation], and
@ -1301,12 +1322,14 @@ and the @racket[exn:fail:redex:test-term] component contains the term that induc
([kw-arg (code:line #:attempts attempts-expr) ([kw-arg (code:line #:attempts attempts-expr)
(code:line #:retries retries-expr) (code:line #:retries retries-expr)
(code:line #:print? print?-expr) (code:line #:print? print?-expr)
(code:line #:attempt-size attempt-size-expr)]) (code:line #:attempt-size attempt-size-expr)
(code:line #:prepare prepare-expr)])
#:contracts ([property (-> any/c any/c)] #:contracts ([property (-> any/c any/c)]
[attempts-expr natural-number/c] [attempts-expr natural-number/c]
[retries-expr natural-number/c] [retries-expr natural-number/c]
[print?-expr any/c] [print?-expr any/c]
[attempt-size-expr (-> natural-number/c natural-number/c)])]{ [attempt-size-expr (-> natural-number/c natural-number/c)]
[prepare-expr (-> any/c any/c)])]{
Tests @racket[relation] as follows: for each case of @racket[relation], Tests @racket[relation] as follows: for each case of @racket[relation],
@racket[check-reduction-relation] generates @racket[attempts] random @racket[check-reduction-relation] generates @racket[attempts] random
terms that match that case's left-hand side and applies @racket[property] terms that match that case's left-hand side and applies @racket[property]
@ -1322,15 +1345,18 @@ when @racket[relation] is a relation on @racket[L] with @racket[n] rules.}
([kw-arg (code:line #:attempts attempts-expr) ([kw-arg (code:line #:attempts attempts-expr)
(code:line #:retries retries-expr) (code:line #:retries retries-expr)
(code:line #:print? print?-expr) (code:line #:print? print?-expr)
(code:line #:attempt-size attempt-size-expr)]) (code:line #:attempt-size attempt-size-expr)
(code:line #:prepare prepare-expr)])
#:contracts ([property (-> (listof any/c) any/c)] #:contracts ([property (-> (listof any/c) any/c)]
[attempts-expr natural-number/c] [attempts-expr natural-number/c]
[retries-expr natural-number/c] [retries-expr natural-number/c]
[print?-expr any/c] [print?-expr any/c]
[attempt-size-expr (-> natural-number/c natural-number/c)])]{ [attempt-size-expr (-> natural-number/c natural-number/c)]
[prepare-expr (-> (listof any/c) (listof any/c))])]{
Like @racket[check-reduction-relation] but for metafunctions. Like @racket[check-reduction-relation] but for metafunctions.
@racket[check-metafunction] calls @racket[property] with lists @racket[check-metafunction] calls @racket[property] with lists
containing arguments to the metafunction.} containing arguments to the metafunction. Similarly, @racket[prepare-expr]
produces and consumes argument lists.}
@examples[ @examples[
#:eval redex-eval #:eval redex-eval

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

@ -671,6 +671,46 @@
#f)) #f))
#t) #t)
(let ([generated '()]
[fixed '()]
[fix add1])
(redex-check lang number (set! fixed (cons (term number) fixed))
#:prepare (λ (n)
(set! generated (cons n generated))
(fix n))
#:attempts 10
#:print? #f)
(test fixed (map fix generated)))
(test (parameterize ([generation-decisions
(decisions #:num (list (λ _ 0)))])
(redex-check lang number (= 0 (term number))
#:prepare add1
#:print? #f))
(counterexample 1))
(test (raised-exn-msg
exn:fail?
(redex-check lang 0 #t #:prepare (λ (_) (error 'fixer)) #:print? #f))
#rx"fixing 0")
(test (raised-exn-msg
exn:fail:redex?
(redex-check lang natural #t #:prepare (compose - add1)))
#rx"does not match natural")
(test (raised-exn-msg
exn:fail:redex?
(redex-check lang natural #t
#:prepare -
#:source (reduction-relation lang (--> 47 1))))
#rx"-47 does not match natural")
(test (redex-check lang number (= 0 (term number))
#:prepare add1
#:source (reduction-relation lang (--> 0 1))
#:print? #f)
(counterexample 1))
(test (raised-exn-msg
exn:fail:contract:blame?
(redex-check lang natural #t #:prepare (λ () 0)))
#rx"rg-test broke the contract")
(test (raised-exn-msg (test (raised-exn-msg
exn:fail:redex? exn:fail:redex?
(redex-check lang n #t #:source (reduction-relation lang (--> x 1)))) (redex-check lang n #t #:source (reduction-relation lang (--> x 1))))
@ -813,6 +853,42 @@
generated) generated)
'((4 4) (4 3) (3 4))) '((4 4) (4 3) (3 4)))
(let ([generated '()]
[fixed '()]
[fix add1])
(check-reduction-relation
(reduction-relation L (--> number number))
(λ (n) (set! fixed (cons n fixed)))
#:prepare (λ (n)
(set! generated (cons n generated))
(fix n))
#:attempts 10
#:print? #f)
(test fixed (map fix generated)))
(test (parameterize ([generation-decisions
(decisions #:num (list (λ _ 0)))])
(check-reduction-relation
(reduction-relation L (--> number number))
(curry = 0)
#:prepare add1
#:print? #f))
(counterexample 1))
(test (raised-exn-msg
exn:fail?
(check-reduction-relation
(reduction-relation L (--> 0 0))
(λ (_) #t)
#:prepare (λ (_) (error 'fixer))
#:print? #f))
#rx"fixing 0")
(test (raised-exn-msg
exn:fail:contract:blame?
(check-reduction-relation
(reduction-relation L (--> 0 0))
void
#:prepare (λ () 0)))
#rx"rg-test broke the contract")
(let ([S (reduction-relation L (--> 1 2 name) (--> 3 4))]) (let ([S (reduction-relation L (--> 1 2 name) (--> 3 4))])
(test (output (λ () (check-reduction-relation S (λ (x) #t) #:attempts 1))) (test (output (λ () (check-reduction-relation S (λ (x) #t) #:attempts 1)))
#rx"check-reduction-relation:.*no counterexamples") #rx"check-reduction-relation:.*no counterexamples")
@ -937,6 +1013,46 @@
#f)) #f))
#t) #t)
(let ([generated '()]
[fixed '()]
[fix add1])
(define-metafunction empty
[(f number) number])
(check-metafunction
f (λ (n) (set! fixed (cons (car n) fixed)))
#:prepare (λ (n)
(set! generated (cons (car n) generated))
(list (fix (car n))))
#:attempts 10
#:print? #f)
(test fixed (map fix generated)))
(test (parameterize ([generation-decisions
(decisions #:num (list (λ _ 0)))])
(define-metafunction empty
[(f number) number])
(check-metafunction
f (compose (curry = 0) car)
#:prepare (compose list add1 car)
#:print? #f))
(counterexample '(1)))
(test (let ()
(define-metafunction empty
[(f 0) 0])
(raised-exn-msg
exn:fail?
(check-metafunction
f (λ (_) #t)
#:prepare (λ (_) (error 'fixer))
#:print? #f)))
#rx"fixing \\(0\\)")
(test (raised-exn-msg
exn:fail?
(let ()
(define-metafunction empty
[(f 0) 0])
(check-metafunction f void #:prepare car #:print? #f)))
#rx"rg-test broke the contract")
(test (output (λ () (check-metafunction m (λ (_) #t)))) #rx"no counterexamples") (test (output (λ () (check-metafunction m (λ (_) #t)))) #rx"no counterexamples")
(test (output (λ () (check-metafunction m (curry eq? 1)))) (test (output (λ () (check-metafunction m (curry eq? 1))))
#px"check-metafunction:.*counterexample found after 1 attempt with clause at .*:\\d+:\\d+") #px"check-metafunction:.*counterexample found after 1 attempt with clause at .*:\\d+:\\d+")