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

generalize the random contract generation so that it can exercise

Browse Source 
a function to get more interesting values and then use those values
to guarantee it can generate things it couldn't before

For example, it can now generate a function with this contract:

  (-> (-> is-eleven?) is-eleven?)

without knowing what the is-eleven? predicate does -- instead it can
figure out to call the argument thunk and then pipe that result around
This commit is contained in:
Robby Findler 2014-04-28 12:19:14 -05:00
parent 6343159701
commit d4c60e8608
7 changed files with 211 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl
View File

@ -2238,14 +2238,23 @@ is expected to be the contract on the value).
(or/c (-> contract? contract? boolean?) #f) (or/c (-> contract? contract? boolean?) #f)
#f] #f]
[#:generate [#:generate
generator generate
(->i ([c contract?]) (->i ([c contract?])
([generator ([generator
(c) (c)
(-> (and/c positive? real?) (-> (and/c positive? real?)
(or/c #f (or/c #f
(-> c)))])) (-> c)))]))
#f]) #f]
[#:exercise
exercise
(->i ([c contract?])
([result
(c)
(-> (and/c positive? real?)
(values
(-> c void?)
(listof contract?)))]))])
flat-contract-property?] flat-contract-property?]
@defproc[(build-chaperone-contract-property @defproc[(build-chaperone-contract-property
[#:name [#:name
@ -2276,14 +2285,23 @@ is expected to be the contract on the value).
(or/c (-> contract? contract? boolean?) #f) (or/c (-> contract? contract? boolean?) #f)
#f] #f]
[#:generate [#:generate
generator generate
(->i ([c contract?]) (->i ([c contract?])
([generator ([generator
(c) (c)
(-> (and/c positive? real?) (-> (and/c positive? real?)
(or/c #f (or/c #f
(-> c)))])) (-> c)))]))
#f]) #f]
[#:exercise
exercise
(->i ([c contract?])
([result
(c)
(-> (and/c positive? real?)
(values
(-> c void?)
(listof contract?)))]))])
chaperone-contract-property?] chaperone-contract-property?]
@defproc[(build-contract-property @defproc[(build-contract-property
[#:name [#:name
@ -2314,14 +2332,23 @@ is expected to be the contract on the value).
(or/c (-> contract? contract? boolean?) #f) (or/c (-> contract? contract? boolean?) #f)
#f] #f]
[#:generate [#:generate
generator generate
(->i ([c contract?]) (->i ([c contract?])
([generator ([generator
(c) (c)
(-> (and/c positive? real?) (-> (and/c positive? real?)
(or/c #f (or/c #f
(-> c)))])) (-> c)))]))
#f]) #f]
[#:exercise
exercise
(->i ([c contract?])
([result
(c)
(-> (and/c positive? real?)
(values
(-> c void?)
(listof contract?)))]))])
contract-property?])]{ contract-property?])]{
@italic{The precise details of the @italic{The precise details of the
@ -2342,9 +2369,12 @@ which produces a description to @racket[write] as part of a contract violation;
produces a blame-tracking projection defining the behavior of the contract; produces a blame-tracking projection defining the behavior of the contract;
@racket[stronger], which is a predicate that determines whether this contract @racket[stronger], which is a predicate that determines whether this contract
(passed in the first argument) is stronger than some other contract (passed (passed in the first argument) is stronger than some other contract (passed
in the second argument); and @racket[generate], which returns a thunk 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 or @racket[#f], indicating
that random generation for this contract isn't supported. that random generation for this contract isn't supported; and @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
whose values will be generated by this process.
These accessors are passed as (optional) keyword arguments to These accessors are passed as (optional) keyword arguments to
@racket[build-contract-property], and are applied to instances of the @racket[build-contract-property], and are applied to instances of the

30
pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt
View File

@ -72,3 +72,33 @@
(check-exn cannot-generate-exn? (λ () (test-contract-generation (check-exn cannot-generate-exn? (λ () (test-contract-generation
(or/c some-crazy-predicate? (or/c some-crazy-predicate?
some-crazy-predicate?)))) some-crazy-predicate?))))
(check-not-exn
(λ ()
(define eleven
((test-contract-generation (-> (-> some-crazy-predicate?) some-crazy-predicate?))
(λ () 11)))
(unless (= eleven 11)
(error 'contract-rand-test.rkt "expected 11 got ~s" eleven))))
(check-not-exn
(λ ()
(define eleven
((test-contract-generation (-> (-> number? boolean? some-crazy-predicate?)
some-crazy-predicate?))
(λ (n b) 11)))
(unless (= eleven 11)
(error 'contract-rand-test.rkt "expected 11 got ~s" eleven))))
(check-not-exn
(λ ()
(define eleven
((test-contract-generation (-> (non-empty-listof some-crazy-predicate?)
some-crazy-predicate?))
(list 11)))
(unless (= eleven 11)
(error 'contract-rand-test.rkt "expected 11 got ~s" eleven))))
(check-exn cannot-generate-exn? (λ () (test-contract-generation
(-> (listof some-crazy-predicate?)
some-crazy-predicate?))))

103
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -716,9 +716,15 @@
(define dom-ctcs (base->-doms ctc)) (define dom-ctcs (base->-doms ctc))
(define doms-l (length dom-ctcs)) (define doms-l (length dom-ctcs))
(λ (fuel) (λ (fuel)
(define dom-exers '())
(define addl-available dom-ctcs)
(for ([c (in-list (base->-doms ctc))])
(define-values (exer ctcs) ((contract-struct-exercise c) fuel))
(set! dom-exers (cons exer dom-exers))
(set! addl-available (append ctcs addl-available)))
(define rngs-gens (define rngs-gens
(with-definitely-available-contracts (with-definitely-available-contracts
dom-ctcs addl-available
(λ () (λ ()
(for/list ([c (in-list (base->-rngs ctc))]) (for/list ([c (in-list (base->-rngs ctc))])
(generate/choose c fuel))))) (generate/choose c fuel)))))
@ -729,41 +735,76 @@
(define env (generate-env)) (define env (generate-env))
(procedure-reduce-arity (procedure-reduce-arity
(λ args (λ args
; Make sure that the args match the contract ; stash the arguments for use by other generators
(unless ((contract-struct-exercise ctc) args (/ fuel 2)) (for ([ctc (in-list dom-ctcs)]
(error '->-generate "Arg(s) ~a do(es) not match contract ~a\n" ctc)) [arg (in-list args)])
; Stash the valid value (env-stash env ctc arg))
(parameterize ([generate-env env]) ; exercise the arguments
(for ([ctc (in-list dom-ctcs)] (for ([arg (in-list args)]
[arg (in-list args)]) [dom-exer (in-list dom-exers)])
(env-stash ctc arg)) (dom-exer arg))
(define results ; compute the results
(for/list ([rng-gen (in-list rngs-gens)]) (define results
(rng-gen))) (for/list ([rng-gen (in-list rngs-gens)])
(apply values results))) (rng-gen)))
; return the results
(apply values results))
doms-l))] doms-l))]
[else #f]))] [else #f]))]
[else (λ (fuel) #f)])) [else (λ (fuel) #f)]))
(define (->-exercise ctc) (define (->-exercise ctc)
(λ (args fuel) (define dom-ctcs (base->-doms ctc))
(let* ([new-fuel (/ fuel 2)] (define rng-ctcs (base->-rngs ctc))
[gen-if-fun (λ (c v) (cond
; If v is a function we need to gen the domain and call [(and (equal? (length dom-ctcs) (base->-min-arity ctc))
(if (procedure? v) (not (base->-rest ctc)))
(let ([newargs (map (λ (c) (contract-random-generate c new-fuel)) (λ (fuel)
(base->-doms c))]) (define gens
(let* ([result (call-with-values (for/list ([dom-ctc (in-list dom-ctcs)])
(λ () (apply v newargs)) ((contract-struct-generate dom-ctc) fuel)))
list)] (define env (generate-env))
[rngs (base->-rngs c)]) (cond
(andmap (λ (c v) [(andmap values gens)
((contract-struct-exercise c) v new-fuel)) (values
rngs (λ (f)
result))) (call-with-values
; Delegate to check-ctc-val (λ ()
((contract-struct-exercise c) v new-fuel)))]) (apply
(andmap gen-if-fun (base->-doms ctc) args)))) f
(for/list ([gen (in-list gens)])
(gen))))
(λ results
(for ([res-ctc (in-list rng-ctcs)]
[result (in-list results)])
(env-stash env res-ctc result)))))
(base->-rngs ctc))]
[else
(values void '())]))]
[else
(λ (fuel) (values void '()))]))
#|
(λ (v)
(let* ([new-fuel (/ fuel 2)]
[gen-if-fun (λ (c v)
; If v is a function we need to gen the domain and call
(if (procedure? v)
(let ([newargs (map (λ (c) (contract-random-generate c new-fuel))
(base->-doms c))])
(let* ([result (call-with-values
(λ () (apply v newargs))
list)]
[rngs (base->-rngs c)])
(andmap (λ (c v)
((contract-struct-exercise c) v new-fuel))
rngs
result)))
; Delegate to check-ctc-val
((contract-struct-exercise c) v new-fuel)))])
(andmap gen-if-fun (base->-doms ctc) args)))))]
|#
(define (base->-name ctc) (define (base->-name ctc)
(define rngs (base->-rngs ctc)) (define rngs (base->-rngs ctc))

8
racket/collects/racket/contract/private/generate.rkt
View File

@ -17,7 +17,7 @@
;; a stash of values and the contracts that they correspond to ;; a stash of values and the contracts that they correspond to
;; that generation has produced earlier in the process ;; that generation has produced earlier in the process
(define generate-env (make-parameter #f)) (define generate-env (make-parameter 'generate-env-not-currently-set))
;; (parameter/c (listof contract?)) ;; (parameter/c (listof contract?))
;; contracts in this will definitely have values available ;; contracts in this will definitely have values available
@ -27,8 +27,7 @@
; Adds a new contract and value to the environment if ; Adds a new contract and value to the environment if
; they don't already exist ; they don't already exist
(define (env-stash ctc val) (define (env-stash env ctc val)
(define env (generate-env))
(define curvals (hash-ref env ctc '())) (define curvals (hash-ref env ctc '()))
(hash-set! env ctc (cons val curvals))) (hash-set! env ctc (cons val curvals)))
@ -71,11 +70,12 @@
; Attemps to find a value with the given contract in the environment. ; Attemps to find a value with the given contract in the environment.
;; NB: this doesn't yet try to call things in the environment to generate ;; NB: this doesn't yet try to call things in the environment to generate
(define (generate/env ctc fuel) (define (generate/env ctc fuel)
(define env (generate-env))
(for/or ([avail-ctc (in-list (definitely-available-contracts))]) (for/or ([avail-ctc (in-list (definitely-available-contracts))])
(and (contract-stronger? avail-ctc ctc) (and (contract-stronger? avail-ctc ctc)
(λ () (λ ()
(define available (define available
(for/list ([(avail-ctc vs) (in-hash (generate-env))] (for/list ([(avail-ctc vs) (in-hash env)]
#:when (contract-stronger? avail-ctc ctc) #:when (contract-stronger? avail-ctc ctc)
[v (in-list vs)]) [v (in-list vs)])
v)) v))

5
racket/collects/racket/contract/private/guts.rkt
View File

@ -386,10 +386,7 @@
(predicate-contract-name ctc))) (predicate-contract-name ctc)))
(λ (fuel) (λ (fuel)
(and built-in-generator (and built-in-generator
(λ () (built-in-generator fuel))))]))) (λ () (built-in-generator fuel))))])))))
#:exercise (λ (ctc)
(λ (val fuel)
((predicate-contract-pred ctc) val)))))
(define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate)) (define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate))
(define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) (define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))

93
racket/collects/racket/contract/private/misc.rkt
View File

@ -751,10 +751,6 @@
[else (loop (cons (eg) so-far))]))) [else (loop (cons (eg) so-far))])))
(λ () '())))) (λ () '()))))
(define (listof-exercise el-ctc)
(λ (f n-tests size env)
#t))
(define (non-empty-listof-generate elem-ctc) (define (non-empty-listof-generate elem-ctc)
(λ (fuel) (λ (fuel)
(define eg (generate/choose elem-ctc fuel)) (define eg (generate/choose elem-ctc fuel))
@ -766,43 +762,54 @@
[else (loop (cons (eg) so-far))]))) [else (loop (cons (eg) so-far))])))
#f))) #f)))
(define (*-listof predicate? name generate) (define (non-empty-listof-exercise elem-ctc)
(λ (input) (λ (fuel)
(let* ([ctc (coerce-contract name input)] (define env (generate-env))
[ctc-name (build-compound-type-name name ctc)] (values
[proj (contract-projection ctc)]) (λ (lst)
(define ((listof-*-ho-check check-all) blame) (env-stash env elem-ctc (oneof lst)))
(let ([p-app (proj (blame-add-listof-*-context blame))]) (list elem-ctc))))
(λ (val)
(unless (predicate? val)
((listof-*/fail blame val predicate?) #f))
(check-all p-app val))))
(define (fo-check x) (define (*-listof predicate? name generate exercise)
(and (predicate? x) (λ (input)
(for/and ([v (in-list x)]) (define ctc (coerce-contract name input))
(contract-first-order-passes? ctc v)))) (define ctc-name (build-compound-type-name name ctc))
(cond (define proj (contract-projection ctc))
[(flat-contract? ctc) (define ((listof-*-ho-check check-all) blame)
(make-flat-contract (let ([p-app (proj (blame-add-listof-*-context blame))])
#:name ctc-name (λ (val)
#:first-order fo-check (unless (predicate? val)
#:projection (listof-*-ho-check (λ (p v) (for-each p v) v)) ((listof-*/fail blame val predicate?) #f))
#:val-first-projection (listof-*-val-first-flat-proj predicate? ctc) (check-all p-app val))))
#:generate (generate ctc))]
[(chaperone-contract? ctc) (define (fo-check x)
(make-chaperone-contract (and (predicate? x)
#:name ctc-name (for/and ([v (in-list x)])
#:first-order fo-check (contract-first-order-passes? ctc v))))
#:projection (listof-*-ho-check (λ (p v) (map p v))) (cond
#:val-first-projection (listof-*-val-first-ho-proj predicate? ctc) [(flat-contract? ctc)
#:generate (generate ctc))] (make-flat-contract
[else #:name ctc-name
(make-contract #:first-order fo-check
#:name ctc-name #:projection (listof-*-ho-check (λ (p v) (for-each p v) v))
#:first-order fo-check #:val-first-projection (listof-*-val-first-flat-proj predicate? ctc)
#:val-first-projection (listof-*-val-first-ho-proj predicate? ctc) #:generate (generate ctc)
#:projection (listof-*-ho-check (λ (p v) (map p v))))])))) #:exercise (exercise ctc))]
[(chaperone-contract? ctc)
(make-chaperone-contract
#:name ctc-name
#:first-order fo-check
#:projection (listof-*-ho-check (λ (p v) (map p v)))
#:val-first-projection (listof-*-val-first-ho-proj predicate? ctc)
#:generate (generate ctc)
#:exercise (exercise ctc))]
[else
(make-contract
#:name ctc-name
#:first-order fo-check
#:val-first-projection (listof-*-val-first-ho-proj predicate? ctc)
#:projection (listof-*-ho-check (λ (p v) (map p v)))
#:exercise (exercise ctc))])))
(define (listof-*-val-first-flat-proj predicate? ctc) (define (listof-*-val-first-flat-proj predicate? ctc)
(define vf-proj (get/build-val-first-projection ctc)) (define vf-proj (get/build-val-first-projection ctc))
@ -841,12 +848,14 @@
(define (blame-add-listof-*-context blame) (blame-add-context blame "an element of")) (define (blame-add-listof-*-context blame) (blame-add-context blame "an element of"))
(define (non-empty-list? x) (and (pair? x) (list? x))) (define (non-empty-list? x) (and (pair? x) (list? x)))
(define listof-func (*-listof list? 'listof listof-generate)) (define (no-exercise ctc) (λ (size) (values void '())))
(define listof-func (*-listof list? 'listof listof-generate no-exercise))
(define/subexpression-pos-prop (listof x) (listof-func x)) (define/subexpression-pos-prop (listof x) (listof-func x))
(define non-empty-listof-func (*-listof non-empty-list? (define non-empty-listof-func (*-listof non-empty-list?
'non-empty-listof 'non-empty-listof
non-empty-listof-generate)) non-empty-listof-generate
non-empty-listof-exercise))
(define/subexpression-pos-prop (non-empty-listof a) (non-empty-listof-func a)) (define/subexpression-pos-prop (non-empty-listof a) (non-empty-listof-func a))
(define (blame-add-car-context blame) (blame-add-context blame "the car of")) (define (blame-add-car-context blame) (blame-add-context blame "the car of"))

25
racket/collects/racket/contract/private/prop.rkt
View File

@ -104,11 +104,11 @@
#f)) #f))
(define (contract-struct-exercise c) (define (contract-struct-exercise c)
(let* ([prop (contract-struct-property c)] (define prop (contract-struct-property c))
[exercise (contract-property-exercise prop)]) (define exercise (contract-property-exercise prop))
(if (procedure? exercise) (if (procedure? exercise)
(exercise c) (exercise c)
(make-generate-ctc-fail)))) (λ (fuel) (values void '()))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
@ -203,8 +203,8 @@
#:projection [get-projection #f] #:projection [get-projection #f]
#:val-first-projection [get-val-first-projection #f] #:val-first-projection [get-val-first-projection #f]
#:stronger [stronger #f] #:stronger [stronger #f]
#:generate [generate (make-generate-ctc-fail)] #:generate [generate (λ (ctc) (λ (fuel) #f))]
#:exercise [exercise (make-generate-ctc-fail)]) #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))])
;; this code is here to help me find the combinators that ;; this code is here to help me find the combinators that
;; are still using only #:projection and not #:val-first-projection ;; are still using only #:projection and not #:val-first-projection
@ -312,8 +312,8 @@
#:projection (lambda (c) (make-contract-projection c)) #:projection (lambda (c) (make-contract-projection c))
#:val-first-projection (lambda (c) (make-contract-val-first-projection c)) #:val-first-projection (lambda (c) (make-contract-val-first-projection c))
#:stronger (lambda (a b) ((make-contract-stronger a) a b)) #:stronger (lambda (a b) ((make-contract-stronger a) a b))
#:generate (lambda (c) ((make-contract-generate c))) #:generate (lambda (c) (make-contract-generate c))
#:exercise (lambda (c) ((make-contract-exercise c))))) #:exercise (lambda (c) (make-contract-exercise c))))
(define-struct make-chaperone-contract [ name first-order projection val-first-projection (define-struct make-chaperone-contract [ name first-order projection val-first-projection
stronger generate exercise ] stronger generate exercise ]
@ -357,8 +357,8 @@
#:projection [projection #f] #:projection [projection #f]
#:val-first-projection [val-first-projection #f] #:val-first-projection [val-first-projection #f]
#:stronger [stronger #f] #:stronger [stronger #f]
#:generate [generate (make-generate-ctc-fail)] #:generate [generate (λ (ctc) (λ (fuel) #f))]
#:exercise [exercise (make-generate-ctc-fail)] ) #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))])
(let* ([name (or name default-name)] (let* ([name (or name default-name)]
[first-order (or first-order any?)] [first-order (or first-order any?)]
@ -397,5 +397,4 @@
(define make-chaperone-contract (define make-chaperone-contract
(build-contract make-make-chaperone-contract 'anonymous-chaperone-contract)) (build-contract make-make-chaperone-contract 'anonymous-chaperone-contract))
(define make-flat-contract (define make-flat-contract (build-contract make-make-flat-contract 'anonymous-flat-contract))
(build-contract make-make-flat-contract 'anonymous-flat-contract))