generalize the random contract generation APIs to allow
a more dynamic notion of failure use that to try harder with and/c contracts. In particular, the contract system now tries to generate the arguments on their own and then uses the other arguments to filter (when they are all flat contracts, of course) closes PR 14832
This commit is contained in:
Robby Findler
parent
43229abf05
commit
5495595535
|
|
@ -2357,12 +2357,13 @@ is expected to be the blame record for the contract on the value).
|
|||
#f]
|
||||
[#:generate
|
||||
generate
|
||||
(->i ([c contract?])
|
||||
([generator
|
||||
(c)
|
||||
(-> (and/c positive? real?)
|
||||
(or/c #f
|
||||
(-> c)))]))
|
||||
(or/c (->i ([c contract?])
|
||||
([generator
|
||||
(c)
|
||||
(-> (and/c positive? real?)
|
||||
(or/c (-> (or/c contract-random-generate-fail? c))
|
||||
#f))]))
|
||||
#f)
|
||||
#f]
|
||||
[#:exercise
|
||||
exercise
|
||||
|
|
@ -2405,12 +2406,13 @@ is expected to be the blame record for the contract on the value).
|
|||
#f]
|
||||
[#:generate
|
||||
generate
|
||||
(->i ([c contract?])
|
||||
([generator
|
||||
(c)
|
||||
(-> (and/c positive? real?)
|
||||
(or/c #f
|
||||
(-> c)))]))
|
||||
(or/c (->i ([c contract?])
|
||||
([generator
|
||||
(c)
|
||||
(-> (and/c positive? real?)
|
||||
(or/c (-> (or/c contract-random-generate-fail? c))
|
||||
#f))]))
|
||||
#f)
|
||||
#f]
|
||||
[#:exercise
|
||||
exercise
|
||||
|
|
@ -2453,12 +2455,13 @@ is expected to be the blame record for the contract on the value).
|
|||
#f]
|
||||
[#:generate
|
||||
generate
|
||||
(->i ([c contract?])
|
||||
([generator
|
||||
(c)
|
||||
(-> (and/c positive? real?)
|
||||
(or/c #f
|
||||
(-> c)))]))
|
||||
(or/c (->i ([c contract?])
|
||||
([generator
|
||||
(c)
|
||||
(-> (and/c positive? real?)
|
||||
(or/c (-> (or/c contract-random-generate-fail? c))
|
||||
#f))]))
|
||||
#f)
|
||||
#f]
|
||||
[#:exercise
|
||||
exercise
|
||||
|
|
@ -2491,7 +2494,8 @@ produces a blame-tracking projection defining the behavior of the contract;
|
|||
@racket[stronger], which is a predicate that determines whether this contract
|
||||
(passed in the first argument) is stronger than some other contract (passed
|
||||
in the second argument); @racket[generate], which returns a thunk
|
||||
that generates random values matching the contract or @racket[#f], indicating
|
||||
that generates random values matching the contract (using @racket[contract-random-generate-fail])
|
||||
to indicate failure) or @racket[#f] to indicate
|
||||
that random generation for this contract isn't supported; @racket[exercise],
|
||||
which returns a function that exercises values matching the contract (e.g.,
|
||||
if it is a function contract, it may call the function) and a list of contracts
|
||||
|
|
@ -2519,7 +2523,9 @@ projection accessor is expected not to wrap its argument in a higher-order
|
|||
fashion, analogous to the constraint on projections in
|
||||
@racket[make-flat-contract].
|
||||
|
||||
@history[#:changed "6.0.1.13" @list{Added the @racket[#:list-contract?] argument.}]
|
||||
@history[#:changed "6.0.1.13" @list{Added the @racket[#:list-contract?] argument.}
|
||||
#:changed "6.1.1.4"
|
||||
@list{Allow @racket[generate] to return @racket[contract-random-generate-fail]}]
|
||||
}
|
||||
|
||||
@deftogether[(
|
||||
|
|
@ -2919,7 +2925,7 @@ parts of the contract system.
|
|||
|
||||
@defproc[(contract-random-generate [ctc contract?]
|
||||
[fuel 5 exact-nonnegative-integer?]
|
||||
[fail (or/c #f (-> any)) #f])
|
||||
[fail (or/c #f (-> any) (-> boolean? any)) #f])
|
||||
any/c]{
|
||||
Attempts to randomly generate a value which will match the contract. The fuel
|
||||
argument limits how hard the generator tries to generate a value matching the
|
||||
|
|
@ -2928,7 +2934,13 @@ contract and is a rough limit of the size of the resulting value.
|
|||
The generator may fail to generate a value, either because some contracts
|
||||
do not have corresponding generators (for example, not all predicates have
|
||||
generators) or because there is not enough fuel. In either case, the
|
||||
thunk @racket[fail] is invoked.
|
||||
function @racket[fail] is invoked. If @racket[fail] accepts an argument,
|
||||
it is called with @racket[#t] when there is no generator for @racket[ctc]
|
||||
and called with @racket[#f] when there is a generator, but the generator
|
||||
ended up returning @racket[contract-random-generate-fail].
|
||||
|
||||
@history[#:changed "6.1.1.5" @list{Allow @racket[fail] to accept a boolean.}]
|
||||
|
||||
}
|
||||
|
||||
@defproc[(contract-exercise [val any/c] ...+) void?]{
|
||||
|
|
@ -2939,3 +2951,62 @@ thunk @racket[fail] is invoked.
|
|||
to poke and prod at the value. For example, if the value is function, it will
|
||||
use the contract to tell it what arguments to supply to the value.
|
||||
}
|
||||
|
||||
@defproc[(contract-random-generate/choose [c contract?] [fuel exact-nonnegative-integer?])
|
||||
(or/c #f (-> c))]{
|
||||
This function is like @racket[contract-random-generate], but it is intended to
|
||||
be used with combinators that generate values based on sub-contracts
|
||||
they have. It cannot be called, except during contract
|
||||
generation. It will never fail, but it might escape back to an enclosing
|
||||
call or to the original call to @racket[contract-random-generate].
|
||||
|
||||
It chooses one of several possible generation strategies, and thus it may not
|
||||
actually use the generator associated with @racket[c], but might instead
|
||||
use a stashed value that matches @racket[c] that it knows about via
|
||||
@racket[contract-random-generate-stash].
|
||||
|
||||
@history[#:added "6.1.1.5"]
|
||||
}
|
||||
|
||||
@defthing[contract-random-generate-fail contract-random-generate-fail?]{
|
||||
An atomic value that is used to indicate that a generator
|
||||
failed to generate a value.
|
||||
|
||||
@history[#:added "6.1.1.5"]
|
||||
}
|
||||
|
||||
@defproc[(contract-random-generate-fail? [v any/c]) boolean?]{
|
||||
A predicate to recognize @racket[contract-random-generate-fail].
|
||||
|
||||
@history[#:added "6.1.1.5"]
|
||||
}
|
||||
|
||||
@defproc[(contract-random-generate-env? [v any/c]) boolean?]{
|
||||
Recognizes contract generation environments.
|
||||
|
||||
@history[#:added "6.1.1.5"]
|
||||
}
|
||||
|
||||
@defproc[(contract-random-generate-stash [env contract-random-generate-env?]
|
||||
[c contract?]
|
||||
[v c]) void?]{
|
||||
This should be called with values that the program under
|
||||
test supplies during contract generation. For example, when
|
||||
@racket[(-> (-> integer? integer?) integer?)] is generated,
|
||||
it may call its argument function. That argument function may
|
||||
return an integer and, if so, that integer should be saved by
|
||||
calling @racket[contract-random-generate-stash], so it can
|
||||
be used by other integer generators.
|
||||
|
||||
@history[#:added "6.1.1.5"]
|
||||
}
|
||||
|
||||
@defproc[(contract-random-generate-get-current-environment) contract-random-generate-env?]{
|
||||
Returns the environment currently being for generation. This function
|
||||
can be called only during the dynamic extent of contract generation.
|
||||
It is intended to be grabbed during the construction of a contract
|
||||
generator and then used with @racket[contract-random-generate-stash]
|
||||
while generation is happening.
|
||||
|
||||
@history[#:added "6.1.1.5"]
|
||||
}
|
||||
|
|
@ -9,8 +9,16 @@
|
|||
(define (some-crazy-predicate? x) (and (number? x) (= x 11)))
|
||||
|
||||
(define (test-contract-generation ctc #:size [size 10])
|
||||
(define example-val (contract-random-generate ctc size))
|
||||
(contract ctc example-val 'pos 'neg))
|
||||
(let/ec k
|
||||
(define example-val (contract-random-generate
|
||||
ctc size
|
||||
(λ (no-generator?)
|
||||
(if no-generator?
|
||||
(error 'test-contract-generation
|
||||
"unable to construct any generator for contract: ~e"
|
||||
ctc)
|
||||
(k 'we-tried-but-could-not-generate-anything)))))
|
||||
(contract ctc example-val 'pos 'neg)))
|
||||
|
||||
(for ([(k v) (in-hash predicate-generator-table)])
|
||||
(check-not-exn (λ () (test-contract-generation k))))
|
||||
|
|
@ -38,12 +46,17 @@
|
|||
(check-not-exn (λ () (test-contract-generation (</c 0.0))))
|
||||
(check-not-exn (λ () (test-contract-generation (=/c 0))))
|
||||
(check-not-exn (λ () (test-contract-generation (=/c 0.0))))
|
||||
(check-not-exn (λ () (test-contract-generation (and/c real? (not/c negative?)))))
|
||||
(check-not-exn (λ () (test-contract-generation (and/c rational? (not/c negative?)))))
|
||||
(check-not-exn (λ () (test-contract-generation (or/c boolean? boolean?))))
|
||||
(check-not-exn (λ () (test-contract-generation (cons/c integer? boolean?))))
|
||||
(check-not-exn (λ () (test-contract-generation any/c)))
|
||||
|
||||
(check-not-exn (λ () (test-contract-generation (and/c real? (not/c negative?)))))
|
||||
(check-not-exn (λ () (test-contract-generation (and/c rational? (not/c negative?)))))
|
||||
(check-not-exn (λ () (test-contract-generation (and/c integer? even?))))
|
||||
(check-not-exn (λ () (test-contract-generation (and/c procedure? (-> integer? integer?)))))
|
||||
(check-not-exn (λ () (test-contract-generation (and/c integer? even?))))
|
||||
(check-not-exn (λ () (test-contract-generation (or/c (and/c real? positive? (</c 0)) boolean?))))
|
||||
|
||||
(check-not-exn (λ () (test-contract-generation (listof boolean?))))
|
||||
(check-not-exn (λ () (test-contract-generation (listof some-crazy-predicate?))))
|
||||
(check-not-exn (λ () (test-contract-generation (non-empty-listof boolean?))))
|
||||
|
|
@ -105,7 +118,7 @@
|
|||
|
||||
(define (cannot-generate-exn? x)
|
||||
(and (exn:fail? x)
|
||||
(regexp-match #rx"contract-random-generate: unable to construct"
|
||||
(regexp-match #rx"test-contract-generation: unable to construct"
|
||||
(exn-message x))))
|
||||
(check-exn cannot-generate-exn? (λ () (test-contract-generation some-crazy-predicate?)))
|
||||
(check-exn cannot-generate-exn? (λ () (test-contract-generation (list/c some-crazy-predicate?))))
|
||||
|
|
@ -127,6 +140,14 @@
|
|||
(or/c some-crazy-predicate?
|
||||
some-crazy-predicate?))))
|
||||
|
||||
;; testing a bunch of impossible and/c's inside some or/c doesn't crash
|
||||
(check-not-exn (λ () (test-contract-generation
|
||||
(or/c (or/c (and/c integer? boolean?)
|
||||
(and/c (listof integer?) string?))
|
||||
(and/c (-> number? number?)
|
||||
any/c
|
||||
number?)))))
|
||||
|
||||
(check-not-exn
|
||||
(λ ()
|
||||
(define eleven
|
||||
|
|
|
|||
|
|
@ -13,4 +13,9 @@
|
|||
"contract/private/legacy.rkt"
|
||||
"contract/private/ds.rkt")
|
||||
contract-random-generate
|
||||
contract-random-generate-stash
|
||||
contract-random-generate-get-current-environment
|
||||
contract-random-generate/choose
|
||||
contract-random-generate-fail
|
||||
contract-random-generate-fail?
|
||||
contract-exercise)
|
||||
|
|
|
|||
|
|
@ -118,18 +118,18 @@
|
|||
(define gens (for/list ([arg-ctc (in-list (->i-arg-ctcs ctc))]
|
||||
#:when (and (not (->i-arg-optional? arg-ctc))
|
||||
(not (->i-arg-kwd arg-ctc))))
|
||||
(generate/choose (->i-arg-contract arg-ctc) fuel)))
|
||||
(contract-random-generate/choose (->i-arg-contract arg-ctc) fuel)))
|
||||
(define kwd-gens (for/list ([arg-ctc (in-list (->i-arg-ctcs ctc))]
|
||||
#:when (and (not (->i-arg-optional? arg-ctc))
|
||||
(->i-arg-kwd arg-ctc)))
|
||||
(generate/choose (->i-arg-contract arg-ctc) fuel)))
|
||||
(contract-random-generate/choose (->i-arg-contract arg-ctc) fuel)))
|
||||
(define dom-kwds (for/list ([arg-ctc (in-list (->i-arg-ctcs ctc))]
|
||||
#:when (and (not (->i-arg-optional? arg-ctc))
|
||||
(->i-arg-kwd arg-ctc)))
|
||||
(->i-arg-kwd arg-ctc)))
|
||||
(cond
|
||||
[(andmap values gens)
|
||||
(define env (generate-env))
|
||||
(define env (contract-random-generate-get-current-environment))
|
||||
(values (λ (f)
|
||||
(call-with-values
|
||||
(λ ()
|
||||
|
|
@ -150,7 +150,7 @@
|
|||
;; better: if we did actually stash the results we knew about.
|
||||
'(for ([res-ctc (in-list rng-ctcs)]
|
||||
[result (in-list results)])
|
||||
(env-stash env res-ctc result)))))
|
||||
(contract-random-generate-stash env res-ctc result)))))
|
||||
;; better here: if we promised the results we knew we could deliver
|
||||
'())]
|
||||
[else
|
||||
|
|
|
|||
|
|
@ -728,19 +728,19 @@
|
|||
addl-available
|
||||
(λ ()
|
||||
(for/list ([c (in-list (base->-rngs ctc))])
|
||||
(generate/choose c fuel))))
|
||||
(contract-random-generate/choose c fuel))))
|
||||
'()))
|
||||
(cond
|
||||
[(for/and ([rng-gen (in-list rngs-gens)])
|
||||
rng-gen)
|
||||
(define env (generate-env))
|
||||
(define env (contract-random-generate-get-current-environment))
|
||||
(λ ()
|
||||
(procedure-reduce-arity
|
||||
(λ args
|
||||
; stash the arguments for use by other generators
|
||||
(for ([ctc (in-list dom-ctcs)]
|
||||
[arg (in-list args)])
|
||||
(env-stash env ctc arg))
|
||||
(contract-random-generate-stash env ctc arg))
|
||||
; exercise the arguments
|
||||
(for ([arg (in-list args)]
|
||||
[dom-exer (in-list dom-exers)])
|
||||
|
|
@ -769,11 +769,11 @@
|
|||
(λ (fuel)
|
||||
(define gens
|
||||
(for/list ([dom-ctc (in-list dom-ctcs)])
|
||||
(generate/choose dom-ctc fuel)))
|
||||
(contract-random-generate/choose dom-ctc fuel)))
|
||||
(define kwd-gens
|
||||
(for/list ([kwd-info (in-list dom-kwd-infos)])
|
||||
(generate/choose (kwd-info-ctc kwd-info) fuel)))
|
||||
(define env (generate-env))
|
||||
(contract-random-generate/choose (kwd-info-ctc kwd-info) fuel)))
|
||||
(define env (contract-random-generate-get-current-environment))
|
||||
(cond
|
||||
[(and (andmap values gens)
|
||||
(andmap values kwd-gens))
|
||||
|
|
@ -792,7 +792,7 @@
|
|||
(when rng-ctcs
|
||||
(for ([res-ctc (in-list rng-ctcs)]
|
||||
[result (in-list results)])
|
||||
(env-stash env res-ctc result))))))
|
||||
(contract-random-generate-stash env res-ctc result))))))
|
||||
(or rng-ctcs '()))]
|
||||
[else
|
||||
(values void '())]))]
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@
|
|||
(cond
|
||||
[(∀∃/c-neg? ctc)
|
||||
(λ (fuel)
|
||||
(define env (generate-env))
|
||||
(define env (contract-random-generate-get-current-environment))
|
||||
(λ () (random-any/c env fuel)))]
|
||||
[else
|
||||
(λ (fuel) #f)]))))
|
||||
|
|
|
|||
|
|
@ -2,8 +2,9 @@
|
|||
(require "rand.rkt")
|
||||
|
||||
(provide
|
||||
(rename-out [sngleton-maker make-generate-ctc-fail])
|
||||
generate-ctc-fail?
|
||||
contract-random-generate-fail
|
||||
contract-random-generate-fail?
|
||||
fail-escape
|
||||
find-generate
|
||||
|
||||
get-arg-names-space
|
||||
|
|
@ -19,13 +20,11 @@
|
|||
;; generate
|
||||
(define-struct env-item (ctc name))
|
||||
|
||||
;; generate failure type
|
||||
(define-struct generate-ctc-fail ())
|
||||
(define a-generate-ctc-fail (make-generate-ctc-fail))
|
||||
(define sngleton-maker
|
||||
(let ([make-generate-contract-fail
|
||||
(λ () a-generate-ctc-fail)])
|
||||
make-generate-contract-fail))
|
||||
(define fail-escape (make-parameter 'fail-escape-not-set))
|
||||
(define-values (contract-random-generate-fail contract-random-generate-fail?)
|
||||
(let ()
|
||||
(struct contract-random-generate-fail ())
|
||||
(values (contract-random-generate-fail) contract-random-generate-fail?)))
|
||||
|
||||
(define (gen-char fuel)
|
||||
(let* ([gen (oneof (list (rand-range 0 55295)
|
||||
|
|
@ -133,7 +132,7 @@
|
|||
;; thread-cell
|
||||
(define arg-names-count (make-thread-cell 0))
|
||||
|
||||
;; given a predicate returns a generate for this predicate or generate-ctc-fail
|
||||
;; given a predicate returns a generate for this predicate or contract-random-generate-fail
|
||||
(define (find-generate func [name "internal"])
|
||||
(hash-ref predicate-generator-table func #f))
|
||||
|
||||
|
|
|
|||
|
|
@ -6,18 +6,21 @@
|
|||
"prop.rkt"
|
||||
racket/list)
|
||||
|
||||
(provide generate-env
|
||||
env-stash
|
||||
contract-random-generate
|
||||
(provide contract-random-generate
|
||||
contract-random-generate-stash
|
||||
contract-random-generate-get-current-environment
|
||||
contract-random-generate/choose
|
||||
contract-random-generate-env-hash
|
||||
contract-random-generate-env?
|
||||
contract-exercise
|
||||
generate/direct
|
||||
generate/choose
|
||||
make-generate-ctc-fail
|
||||
generate-ctc-fail?
|
||||
contract-random-generate-fail
|
||||
contract-random-generate-fail?
|
||||
with-definitely-available-contracts
|
||||
can-generate/env?
|
||||
try/env
|
||||
multi-exercise)
|
||||
multi-exercise
|
||||
fail-escape)
|
||||
|
||||
(define (contract-exercise #:fuel [fuel 10] v1 . vs)
|
||||
(define vals
|
||||
|
|
@ -26,11 +29,18 @@
|
|||
val))
|
||||
(define ctcs (map value-contract vals))
|
||||
(define-values (go _)
|
||||
(parameterize ([generate-env (make-hash)])
|
||||
(parameterize ([generate-env (contract-random-generate-env (make-hash))])
|
||||
((multi-exercise ctcs) fuel)))
|
||||
(for ([x (in-range fuel)])
|
||||
(go vals)))
|
||||
|
||||
(define (contract-random-generate-get-current-environment)
|
||||
(define env (generate-env))
|
||||
(unless (contract-random-generate-env? env)
|
||||
(error 'get-current-contract-generation-environment
|
||||
"expected to be called only during generation"))
|
||||
env)
|
||||
|
||||
;; multi-exercise : (listof contract?) -> fuel -> (values (listof ctc) (-> (listof val[ctcs]) void)
|
||||
(define (multi-exercise orig-ctcs)
|
||||
(λ (fuel)
|
||||
|
|
@ -88,8 +98,9 @@
|
|||
|
||||
;; a stash of values and the contracts that they correspond to
|
||||
;; that generation has produced earlier in the process
|
||||
(define generate-env (make-parameter 'generate-env-not-currently-set))
|
||||
|
||||
(define generate-env (make-parameter #f))
|
||||
(struct contract-random-generate-env (hash))
|
||||
|
||||
;; (parameter/c (listof contract?))
|
||||
;; contracts in this will definitely have values available
|
||||
;; by the time generation happens; those values will be
|
||||
|
|
@ -98,9 +109,20 @@
|
|||
|
||||
; Adds a new contract and value to the environment if
|
||||
; they don't already exist
|
||||
(define (env-stash env ctc val)
|
||||
(define curvals (hash-ref env ctc '()))
|
||||
(hash-set! env ctc (cons val curvals)))
|
||||
(define (contract-random-generate-stash env ctc val)
|
||||
(unless (contract-random-generate-env? env)
|
||||
(raise-argument-error 'contract-random-generate-stash
|
||||
"contract-random-generate-env?"
|
||||
0
|
||||
env ctc val))
|
||||
(unless (contract-struct? ctc)
|
||||
(raise-argument-error 'contract-random-generate-stash
|
||||
"contract?"
|
||||
1
|
||||
env ctc val))
|
||||
(define env-hash (contract-random-generate-env-hash env))
|
||||
(define curvals (hash-ref env-hash ctc '()))
|
||||
(hash-set! env-hash ctc (cons val curvals)))
|
||||
|
||||
(define (with-definitely-available-contracts ctcs thunk)
|
||||
(parameterize ([definitely-available-contracts
|
||||
|
|
@ -113,36 +135,66 @@
|
|||
(raise-argument-error 'contract-random-generate
|
||||
"exact-nonnegative-integer?"
|
||||
fuel))
|
||||
(unless (or (not _fail) (and (procedure? _fail) (procedure-arity-includes? _fail 0)))
|
||||
(unless (or (not _fail)
|
||||
(and (procedure? _fail)
|
||||
(or (procedure-arity-includes? _fail 0)
|
||||
(procedure-arity-includes? _fail 1))))
|
||||
(raise-argument-error 'contract-random-generate
|
||||
(format "~s" '(or/c #f (-> any)))
|
||||
(format "~s" '(or/c #f (-> any) (-> boolean? any)))
|
||||
3
|
||||
ctc fuel _fail))
|
||||
(define fail
|
||||
(cond
|
||||
[(not _fail) #f]
|
||||
[(procedure-arity-includes? _fail 1) _fail]
|
||||
[else (λ (x) (_fail))]))
|
||||
|
||||
(define proc
|
||||
(parameterize ([generate-env (make-hash)])
|
||||
(generate/choose def-ctc fuel)))
|
||||
(parameterize ([generate-env (contract-random-generate-env (make-hash))])
|
||||
(contract-random-generate/choose def-ctc fuel)))
|
||||
(define-values (success? value)
|
||||
(cond
|
||||
[proc
|
||||
(let/ec k
|
||||
(parameterize ([fail-escape (λ () (k #f #f))])
|
||||
(values #t (proc))))]
|
||||
[else (values #f #f)]))
|
||||
(cond
|
||||
[proc (proc)]
|
||||
[_fail (_fail)]
|
||||
[(and success?
|
||||
(not (contract-random-generate-fail? value)))
|
||||
value]
|
||||
[fail (fail (not success?))]
|
||||
[else
|
||||
(error 'contract-random-generate
|
||||
"unable to construct any generator for contract: ~e"
|
||||
def-ctc)]))
|
||||
(if success?
|
||||
(error 'contract-random-generate
|
||||
"unable generate a value satisfying: ~e"
|
||||
def-ctc)
|
||||
(error 'contract-random-generate
|
||||
"unable to construct any generator for contract: ~e"
|
||||
def-ctc))]))
|
||||
|
||||
;; generate/choose : contract? nonnegative-int -> (or/c #f (-> any/c))
|
||||
; Iterates through generation methods until failure. Returns
|
||||
; #f if no value could be generated
|
||||
(define (generate/choose ctc fuel)
|
||||
;; if it returns a thunk, the thunk will not return contract-random-generate-fail?
|
||||
(define (contract-random-generate/choose ctc fuel)
|
||||
(define direct (generate/direct ctc fuel))
|
||||
(define env-can? (can-generate/env? ctc))
|
||||
(define env (generate-env))
|
||||
(unless (contract-random-generate-env? env)
|
||||
(error 'contract-random-generate/choose
|
||||
"expected to be called only during generation"))
|
||||
(cond
|
||||
[direct
|
||||
(λ ()
|
||||
(define use-direct? (zero? (rand 2)))
|
||||
(if use-direct?
|
||||
(direct)
|
||||
(try/env ctc env direct)))]
|
||||
(cond
|
||||
[use-direct?
|
||||
(define candidate (direct))
|
||||
(if (contract-random-generate-fail? candidate)
|
||||
(try/env ctc env direct)
|
||||
candidate)]
|
||||
[else (try/env ctc env direct)]))]
|
||||
[env-can?
|
||||
(λ ()
|
||||
(try/env
|
||||
|
|
@ -150,19 +202,27 @@
|
|||
(λ () (error 'generate/choose "internal generation failure"))))]
|
||||
[else #f]))
|
||||
|
||||
; generate/direct :: contract nonnegative-int -> (or/c #f (-> val))
|
||||
;; generate/direct :: contract nonnegative-int -> (or/c #f (-> val))
|
||||
;; generate directly via the contract's built-in generator, if possible
|
||||
(define (generate/direct ctc fuel) ((contract-struct-generate ctc) fuel))
|
||||
;; if it returns a thunk, the thunk will not return contract-random-generate-fail?
|
||||
(define (generate/direct ctc fuel)
|
||||
(define candidate ((contract-struct-generate ctc) fuel))
|
||||
(cond
|
||||
[(contract-random-generate-fail? candidate) ((fail-escape))]
|
||||
[else candidate]))
|
||||
|
||||
(define (try/env ctc env fail)
|
||||
(define env-hash (contract-random-generate-env-hash env))
|
||||
(define available
|
||||
(for/list ([(avail-ctc vs) (in-hash env)]
|
||||
(for/list ([(avail-ctc vs) (in-hash env-hash)]
|
||||
#:when (contract-stronger? avail-ctc ctc)
|
||||
[v (in-list vs)])
|
||||
v))
|
||||
(cond
|
||||
[(null? available) (fail)]
|
||||
[else (oneof available)]))
|
||||
[else
|
||||
(oneof available)]))
|
||||
|
||||
|
||||
(define (can-generate/env? ctc)
|
||||
(for/or ([avail-ctc (in-list (definitely-available-contracts))])
|
||||
|
|
|
|||
|
|
@ -179,7 +179,65 @@
|
|||
(cond
|
||||
[(and/c-check-nonneg ctc real?) => values]
|
||||
[(and/c-check-nonneg ctc rational?) => values]
|
||||
[else (λ (fuel) #f)]))
|
||||
[(null? (base-and/c-ctcs ctc)) => (λ (fuel) #f)]
|
||||
[else
|
||||
(define flat (filter flat-contract? (base-and/c-ctcs ctc)))
|
||||
(define ho (filter (λ (x) (not (flat-contract? x))) (base-and/c-ctcs ctc)))
|
||||
(cond
|
||||
[(null? ho)
|
||||
(λ (fuel)
|
||||
(define candidates
|
||||
(let loop ([sub-contracts-after (cdr (base-and/c-ctcs ctc))]
|
||||
[sub-contract (car (base-and/c-ctcs ctc))]
|
||||
[sub-contracts-before '()]
|
||||
[candidates '()])
|
||||
(define sub-gen (contract-random-generate/choose sub-contract fuel))
|
||||
(define new-candidates
|
||||
(cond
|
||||
[sub-gen
|
||||
(cons (cons sub-gen (append (reverse sub-contracts-before) sub-contracts-after))
|
||||
candidates)]
|
||||
[else candidates]))
|
||||
(cond
|
||||
[(null? sub-contracts-after) new-candidates]
|
||||
[else (loop (cdr sub-contracts-after)
|
||||
(car sub-contracts-after)
|
||||
(cons sub-contract sub-contracts-before)
|
||||
new-candidates)])))
|
||||
(cond
|
||||
[(null? candidates) #f]
|
||||
[else
|
||||
(λ ()
|
||||
(let loop ([attempts 10])
|
||||
(cond
|
||||
[(zero? attempts) contract-random-generate-fail]
|
||||
[else
|
||||
(define which (oneof candidates))
|
||||
(define val ((car which)))
|
||||
(cond
|
||||
[(andmap (λ (p?) (p? val)) (cdr which))
|
||||
val]
|
||||
[else
|
||||
(loop (- attempts 1))])])))]))]
|
||||
[(null? (cdr ho))
|
||||
(λ (fuel)
|
||||
(define ho-gen (contract-random-generate/choose (car ho) fuel))
|
||||
(cond
|
||||
[ho-gen
|
||||
(λ ()
|
||||
(let loop ([attempts 10])
|
||||
(cond
|
||||
[(zero? attempts) contract-random-generate-fail]
|
||||
[else
|
||||
(define val (ho-gen))
|
||||
(cond
|
||||
[(andmap (λ (p?) (p? val)) flat)
|
||||
val]
|
||||
[else
|
||||
(loop (- attempts 1))])])))]
|
||||
[else #f]))]
|
||||
[else
|
||||
(λ (fuel) #f)])]))
|
||||
|
||||
(define (and/c-check-nonneg ctc pred)
|
||||
(define sub-contracts (base-and/c-ctcs ctc))
|
||||
|
|
@ -476,7 +534,7 @@
|
|||
|
||||
(define (listof-generate ctc)
|
||||
(λ (fuel)
|
||||
(define eg (generate/choose (listof-ctc-elem-c ctc) fuel))
|
||||
(define eg (contract-random-generate/choose (listof-ctc-elem-c ctc) fuel))
|
||||
(if eg
|
||||
(λ ()
|
||||
(let loop ([so-far (cond
|
||||
|
|
@ -501,14 +559,15 @@
|
|||
[else
|
||||
(define elem-ctc (listof-ctc-elem-c ctc))
|
||||
(λ (fuel)
|
||||
(define env (generate-env))
|
||||
(define env (contract-random-generate-get-current-environment))
|
||||
(values
|
||||
(λ (lst)
|
||||
(env-stash env elem-ctc
|
||||
(oneof
|
||||
(if (im-listof-ctc? ctc)
|
||||
(improper-list->list lst)
|
||||
lst))))
|
||||
(contract-random-generate-stash
|
||||
env elem-ctc
|
||||
(oneof
|
||||
(if (im-listof-ctc? ctc)
|
||||
(improper-list->list lst)
|
||||
lst))))
|
||||
(list elem-ctc)))]))
|
||||
|
||||
(define (improper-list->list l)
|
||||
|
|
@ -853,8 +912,8 @@
|
|||
(define ctc-car (the-cons/c-hd-ctc ctc))
|
||||
(define ctc-cdr (the-cons/c-tl-ctc ctc))
|
||||
(λ (fuel)
|
||||
(define car-gen (generate/choose ctc-car fuel))
|
||||
(define cdr-gen (generate/choose ctc-cdr fuel))
|
||||
(define car-gen (contract-random-generate/choose ctc-car fuel))
|
||||
(define cdr-gen (contract-random-generate/choose ctc-cdr fuel))
|
||||
(and car-gen
|
||||
cdr-gen
|
||||
(λ () (cons (car-gen) (cdr-gen))))))
|
||||
|
|
@ -940,7 +999,7 @@
|
|||
(define elem-ctcs (generic-list/c-args ctc))
|
||||
(λ (fuel)
|
||||
(define gens (for/list ([elem-ctc (in-list elem-ctcs)])
|
||||
(generate/choose elem-ctc fuel)))
|
||||
(contract-random-generate/choose elem-ctc fuel)))
|
||||
(cond
|
||||
[(andmap values gens)
|
||||
(λ ()
|
||||
|
|
@ -1327,18 +1386,19 @@
|
|||
(define any/c-neg-party-fn (λ (val) (λ (neg-party) val)))
|
||||
|
||||
(define (random-any/c env fuel)
|
||||
(define env-hash (contract-random-generate-env-hash env))
|
||||
(cond
|
||||
[(zero? (hash-count env))
|
||||
[(zero? (hash-count env-hash))
|
||||
(rand-choice
|
||||
[1/3 (any/c-simple-value)]
|
||||
[1/3 (any/c-procedure env fuel)]
|
||||
[else (any/c-from-predicate-generator env fuel)])]
|
||||
[1/3 (any/c-procedure env-hash fuel)]
|
||||
[else (any/c-from-predicate-generator env-hash fuel)])]
|
||||
[else
|
||||
(rand-choice
|
||||
[1/4 (oneof (hash-ref env (oneof (hash-keys env))))]
|
||||
[1/4 (oneof (hash-ref env-hash (oneof (hash-keys env-hash))))]
|
||||
[1/4 (any/c-simple-value)]
|
||||
[1/4 (any/c-procedure env fuel)]
|
||||
[else (any/c-from-predicate-generator env fuel)])]))
|
||||
[1/4 (any/c-procedure env-hash fuel)]
|
||||
[else (any/c-from-predicate-generator env-hash fuel)])]))
|
||||
|
||||
(define (any/c-simple-value)
|
||||
(oneof '(0 #f "" () #() -1 1 #t elephant)))
|
||||
|
|
@ -1368,7 +1428,7 @@
|
|||
#:name (λ (ctc) 'any/c)
|
||||
#:generate (λ (ctc)
|
||||
(λ (fuel)
|
||||
(define env (generate-env))
|
||||
(define env (contract-random-generate-get-current-environment))
|
||||
(λ () (random-any/c env fuel))))
|
||||
#:first-order get-any?))
|
||||
|
||||
|
|
|
|||
|
|
@ -121,7 +121,7 @@
|
|||
|
||||
(define (or/c-exercise ho-contracts)
|
||||
(λ (fuel)
|
||||
(define env (generate-env))
|
||||
(define env (contract-random-generate-get-current-environment))
|
||||
(values (λ (val)
|
||||
(let loop ([ho-contracts ho-contracts])
|
||||
(unless (null? ho-contracts)
|
||||
|
|
@ -130,7 +130,7 @@
|
|||
[((contract-first-order ctc) val)
|
||||
(define-values (exercise ctcs) ((contract-struct-exercise ctc) fuel))
|
||||
(exercise val)
|
||||
(env-stash env ctc val)]
|
||||
(contract-random-generate-stash env ctc val)]
|
||||
[else
|
||||
(loop (cdr ho-contracts))]))))
|
||||
'())))
|
||||
|
|
@ -149,11 +149,11 @@
|
|||
[can-generate?
|
||||
;; #f => try to use me in the env.
|
||||
(define options (cons #f (append directs ctcs)))
|
||||
(define env (generate-env))
|
||||
(define env (contract-random-generate-get-current-environment))
|
||||
(λ ()
|
||||
(let loop ([options (permute options)])
|
||||
(cond
|
||||
[(null? options) (error 'or/c-generate "shouldn't fail!")]
|
||||
[(null? options) contract-random-generate-fail]
|
||||
[else
|
||||
(define option (car options))
|
||||
(cond
|
||||
|
|
@ -165,7 +165,14 @@
|
|||
(try/env
|
||||
option env
|
||||
(λ () (loop (cdr options))))]
|
||||
[else (option)])])))]
|
||||
[else
|
||||
(define-values (succ? val)
|
||||
(let/ec k
|
||||
(parameterize ([fail-escape (λ () (k #f #f))])
|
||||
(k #t (option)))))
|
||||
(if succ?
|
||||
val
|
||||
(loop (cdr options)))])])))]
|
||||
[else #f]))
|
||||
|
||||
(define (single-or/c-list-contract? c)
|
||||
|
|
@ -482,7 +489,7 @@
|
|||
(λ (fuel)
|
||||
(if (zero? fuel)
|
||||
#f
|
||||
(generate/choose (get-flat-rec-me ctc) (- fuel 1)))))))
|
||||
(contract-random-generate/choose (get-flat-rec-me ctc) (- fuel 1)))))))
|
||||
|
||||
(define-syntax (_flat-rec-contract stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -214,7 +214,7 @@
|
|||
(cond
|
||||
[(invariant? subc) #f]
|
||||
[(indep? subc)
|
||||
(define sgen (generate/choose (indep-ctc subc) fuel))
|
||||
(define sgen (contract-random-generate/choose (indep-ctc subc) fuel))
|
||||
(cond
|
||||
[sgen (loop (cdr subcs) (cons sgen gens))]
|
||||
[else #f])]
|
||||
|
|
@ -671,7 +671,7 @@
|
|||
|
||||
(define (struct/dc-exercise stct)
|
||||
(λ (fuel)
|
||||
(define env (generate-env))
|
||||
(define env (contract-random-generate-get-current-environment))
|
||||
(values
|
||||
(λ (val)
|
||||
;; need to extract the fields and do it in
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user