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

improve random contract generation

Browse Source 
notably enable the generator to actually use things from the
environment but currently only when they are directly in the
environment so, eg:

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

can't be generated (since the contract system doesn't know
about is-eleven? and also doesn't yet know that it can call
the argument thunk)
This commit is contained in:
Robby Findler 2014-04-26 08:12:54 -05:00
parent cdd6bf438a
commit 76c6a1b7b0
9 changed files with 249 additions and 182 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2237,10 +2237,14 @@ is expected to be the contract on the value).
stronger
(or/c (-> contract? contract? boolean?) #f)
#f]
[#:generator
[#:generate
generator
(or/c (-> number? (listof (list any/c contract?)) any/c)
#f)
(->i ([c contract?])
([generator
(c)
(-> (and/c positive? real?)
(or/c #f
(-> c)))]))
#f])
flat-contract-property?]
@defproc[(build-chaperone-contract-property
@ -2271,10 +2275,14 @@ is expected to be the contract on the value).
stronger
(or/c (-> contract? contract? boolean?) #f)
#f]
[#:generator
[#:generate
generator
(or/c (-> number? (listof (list any/c contract?)) any/c)
#f)
(->i ([c contract?])
([generator
(c)
(-> (and/c positive? real?)
(or/c #f
(-> c)))]))
#f])
chaperone-contract-property?]
@defproc[(build-contract-property
@ -2305,10 +2313,14 @@ is expected to be the contract on the value).
stronger
(or/c (-> contract? contract? boolean?) #f)
#f]
[#:generator
[#:generate
generator
(or/c (-> number? (listof (list any/c contract?)) any/c)
#f)
(->i ([c contract?])
([generator
(c)
(-> (and/c positive? real?)
(or/c #f
(-> c)))]))
#f])
contract-property?])]{
@ -2316,7 +2328,7 @@ is expected to be the contract on the value).
@racket[val-first-projection] argument
are subject to change. (Probably
also the default values of the @racket[project]
arguments will change.}
arguments will change.)}
These functions build the arguments for @racket[prop:contract],
@ -2330,9 +2342,9 @@ which produces a description to @racket[write] as part of a contract violation;
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); and @racket[generator], which makes a random value
that matches the contract, given a size bound and an environment from which
to draw interesting values.
in the second argument); and @racket[generate], which returns a thunk
that generates random values matching the contract or @racket[#f], indicating
that random generation for this contract isn't supported.
These accessors are passed as (optional) keyword arguments to
@racket[build-contract-property], and are applied to instances of the

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

@ -2,20 +2,23 @@
(require racket/contract
racket/contract/private/generate-base
rackunit
rackunit/text-ui
net/url)
rackunit)
;; this is expected to never have a generator.
(define (some-crazy-predicate? x) (and (number? x) (= x 11)))
(define (test-contract-generation ctc #:size [size 10])
(define example-vals (contract-random-generate ctc size))
(contract ctc example-vals 'pos 'neg))
(define example-val (contract-random-generate ctc size))
(contract ctc example-val 'pos 'neg))
(for ([(k v) (in-hash predicate-generator-table)])
(check-not-exn (λ () (test-contract-generation k))))
;; test =, eq?, and equal? contract random generators
(check-not-exn (λ () (test-contract-generation 0)))
(check-not-exn (λ () (test-contract-generation 'x)))
(check-not-exn (λ () (test-contract-generation "x")))
(check-not-exn (λ () (test-contract-generation (listof boolean?))))
(check-not-exn (λ () (test-contract-generation (listof number?))))
@ -30,16 +33,21 @@
(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 (=/c 0))))
(check-not-exn (λ () (test-contract-generation (=/c 0.0))))
(check-not-exn (λ () (test-contract-generation (or/c boolean? 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?))))
(check-not-exn (λ () (test-contract-generation (list/c boolean? number?))))
(check-not-exn (λ () ((car (test-contract-generation (list/c (-> number? number?)))) 0)))
(check-exn exn:fail? (λ () ((test-contract-generation (-> char? integer?)) 0)))
(check-not-exn (λ () ((test-contract-generation (-> integer? integer?)) 1)))
(check-not-exn (λ () ((test-contract-generation (-> (-> integer? integer?) boolean?)) +)))
(check-not-exn
(λ () ((test-contract-generation (-> some-crazy-predicate? some-crazy-predicate?)) 11)))
(define (cannot-generate-exn? x)
(and (exn:fail? x)

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

@ -713,25 +713,37 @@
(base->-min-arity ctc))
(not (base->-rest ctc)))
;; only handle the case with no optional args and no rest args
(define doms-l (length (base->-doms ctc)))
(define dom-ctcs (base->-doms ctc))
(define doms-l (length dom-ctcs))
(λ (fuel)
(define rngs-gens (map (λ (c) (generate/choose c (/ fuel 2)))
(base->-rngs ctc)))
(define rngs-gens
(with-definitely-available-contracts
dom-ctcs
(λ ()
(for/list ([c (in-list (base->-rngs ctc))])
(generate/choose c fuel)))))
(cond
[(for/or ([rng-gen (in-list rngs-gens)])
(generate-ctc-fail? rng-gen))
(make-generate-ctc-fail)]
[else
(procedure-reduce-arity
(λ args
; Make sure that the args match the contract
(begin (unless ((contract-struct-exercise ctc) args (/ fuel 2))
(error '->-generate "Arg(s) ~a do(es) not match contract ~a\n" ctc))
; Stash the valid value
;(env-stash (generate-env) ctc args)
(apply values rngs-gens)))
doms-l)]))]
[else (λ (fuel) (make-generate-ctc-fail))]))
[(for/and ([rng-gen (in-list rngs-gens)])
rng-gen)
(λ ()
(define env (generate-env))
(procedure-reduce-arity
(λ args
; Make sure that the args match the contract
(unless ((contract-struct-exercise ctc) args (/ fuel 2))
(error '->-generate "Arg(s) ~a do(es) not match contract ~a\n" ctc))
; Stash the valid value
(parameterize ([generate-env env])
(for ([ctc (in-list dom-ctcs)]
[arg (in-list args)])
(env-stash ctc arg))
(define results
(for/list ([rng-gen (in-list rngs-gens)])
(rng-gen)))
(apply values results)))
doms-l))]
[else #f]))]
[else (λ (fuel) #f)]))
(define (->-exercise ctc)
(λ (args fuel)

2
racket/collects/racket/contract/private/generate-base.rkt
View File

@ -125,7 +125,7 @@
;; given a predicate returns a generate for this predicate or generate-ctc-fail
(define (find-generate func [name "internal"])
(hash-ref predicate-generator-table func make-generate-ctc-fail))
(hash-ref predicate-generator-table func #f))
(define (get-arg-names-space space-needed)
(let ([rv (thread-cell-ref arg-names-count)])

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

@ -8,90 +8,77 @@
(provide generate-env
env-stash
contract-random-generate
generate/direct
generate/choose
make-generate-ctc-fail
generate-ctc-fail?)
generate-ctc-fail?
with-definitely-available-contracts)
; env parameter
;; a stash of values and the contracts that they correspond to
;; that generation has produced earlier in the process
(define generate-env (make-parameter #f))
;; (parameter/c (listof contract?))
;; contracts in this will definitely have values available
;; by the time generation happens; those values will be
;; in the env-stash.
(define definitely-available-contracts (make-parameter '()))
; Adds a new contract and value to the environment if
; they don't already exist
(define (env-stash env ctc val)
(let* ([curvals (hash-ref env ctc (list))])
(hash-set! env ctc (cons val curvals))))
(define (gen-pred/direct pred fuel)
(let ([ctc (coerce-contract 'contract-direct-gen pred)])
(generate/direct ctc fuel)))
(define (env-stash ctc val)
(define env (generate-env))
(define curvals (hash-ref env ctc '()))
(hash-set! env ctc (cons val curvals)))
(define (with-definitely-available-contracts ctcs thunk)
(parameterize ([definitely-available-contracts
(append ctcs (definitely-available-contracts))])
(thunk)))
; generate : contract int -> ctc value or error
(define (contract-random-generate ctc fuel
[fail (λ ()
(error 'contract-random-generate
"unable to construct any generator for contract: ~s"
(contract-struct-name
(coerce-contract 'contract-random-generate ctc))))])
(let ([def-ctc (coerce-contract 'contract-random-generate ctc)])
(parameterize ([generate-env (make-hash)])
; choose randomly
(let ([val (generate/choose def-ctc fuel)])
(if (generate-ctc-fail? val)
(fail)
val)))))
"unable to construct any generator for contract: ~e"
(coerce-contract 'contract-random-generate ctc)))])
(define def-ctc (coerce-contract 'contract-random-generate ctc))
(parameterize ([generate-env (make-hash)])
(let ([proc (generate/choose def-ctc fuel)])
(if proc
(proc)
(fail)))))
;; generate/choose : contract? nonnegative-int -> (or/c #f (-> any/c))
; Iterates through generation methods until failure. Returns
; generate-ctc-fail if no value could be generated
; #f if no value could be generated
(define (generate/choose ctc fuel)
(let ([options (permute (list generate/direct
generate/direct-env
))])
; choose randomly
(let trygen ([options options])
(if (empty? options)
(make-generate-ctc-fail)
(let* ([option (car options)]
[val (option ctc fuel)])
(if (generate-ctc-fail? val)
(trygen (cdr options))
val))))))
(let loop ([options (permute (list generate/direct generate/env))])
(cond
[(empty? options)
#f]
[else
(define option (car options))
(define gen (option ctc fuel))
(or gen (loop (cdr options)))])))
; generate/direct :: contract int -> value for contract
; Attempts to make a generator that generates values for this contract
; directly. Returns generate-ctc-fail if making a generator fails.
(define (generate/direct ctc fuel)
(let ([g (contract-struct-generate ctc)])
; Check if the contract has a direct generate attached
(if (generate-ctc-fail? g)
; Everything failed -- we can't directly generate this ctc
g
(g fuel))))
; generate/direct-env :: contract int -> value
; 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))
; generate/direct-env :: contract nonnegative-int -> value
; Attemps to find a value with the given contract in the environment.
; Returns it if found and generate-ctc-fail otherwise.
(define (generate/direct-env ctc fuel)
; TODO: find out how to make negative test cases
(let* ([keys (hash-keys (generate-env))]
[valid-ctcs (filter (λ (c)
(contract-stronger? c ctc))
keys)])
(if (> (length valid-ctcs) 0)
(oneof (oneof (map (λ (key)
(hash-ref (generate-env) key))
valid-ctcs)))
(make-generate-ctc-fail))))
; generate/indirect-env :: contract int -> (int -> value for contract)
; Attempts to make a generator that generates values for this contract
; by calling functions in the environment
(define (generate/indirect-env ctc fuel)
(if (> fuel 0)
(make-generate-ctc-fail)
(make-generate-ctc-fail)))
;; NB: this doesn't yet try to call things in the environment to generate
(define (generate/env ctc fuel)
(for/or ([avail-ctc (in-list (definitely-available-contracts))])
(and (contract-stronger? avail-ctc ctc)
(λ ()
(define available
(for/list ([(avail-ctc vs) (in-hash (generate-env))]
#:when (contract-stronger? avail-ctc ctc)
[v (in-list vs)])
v))
(when (null? available)
(error 'generate.rkt "internal error: no values satisfying ~s available" ctc))
(oneof available)))))

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

@ -173,7 +173,7 @@
(cond
[(contract-struct? x) x]
[(and (procedure? x) (procedure-arity-includes? x 1))
(make-predicate-contract (or (object-name x) '???) x (make-generate-ctc-fail))]
(make-predicate-contract (or (object-name x) '???) x #f)]
[(or (symbol? x) (boolean? x) (char? x) (null? x) (keyword? x)) (make-eq-contract x)]
[(or (bytes? x) (string? x)) (make-equal-contract x)]
[(number? x) (make-=-contract x)]
@ -295,7 +295,9 @@
`',(eq-contract-val ctc)
(eq-contract-val ctc)))
#:generate
(λ (ctc) (λ (fuel) (eq-contract-val ctc)))
(λ (ctc)
(define v (eq-contract-val ctc))
(λ (fuel) (λ () v)))
#:stronger
(λ (this that)
(and (eq-contract? that)
@ -312,7 +314,9 @@
(and (equal-contract? that)
(equal? (equal-contract-val this) (equal-contract-val that))))
#:generate
(λ (ctc) (λ (fuel) (equal-contract-val ctc)))))
(λ (ctc)
(define v (equal-contract-val ctc))
(λ (fuel) (λ () v)))))
(define-struct =-contract (val)
#:property prop:custom-write custom-write-property-proc
@ -325,7 +329,9 @@
(and (=-contract? that)
(= (=-contract-val this) (=-contract-val that))))
#:generate
(λ (ctc) (λ (fuel) (=-contract-val ctc)))))
(λ (ctc)
(define v (=-contract-val ctc))
(λ (fuel) (λ () v)))))
(define-struct regexp/c (reg)
#:property prop:custom-write custom-write-property-proc
@ -372,17 +378,22 @@
predicate-contract-proj)))
#:generate (λ (ctc)
(let ([generate (predicate-contract-generate ctc)])
(if (generate-ctc-fail? generate)
(let ([fn (predicate-contract-pred ctc)])
(find-generate fn (predicate-contract-name ctc)))
generate)))
(cond
[generate generate]
[else
(define built-in-generator
(find-generate (predicate-contract-pred ctc)
(predicate-contract-name ctc)))
(λ (fuel)
(and built-in-generator
(λ () (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-contract predicate) (coerce-flat-contract 'flat-contract predicate))
(define (build-flat-contract name pred [generate (make-generate-ctc-fail)])
(define (build-flat-contract name pred [generate #f])
(make-predicate-contract name pred generate))

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

@ -611,16 +611,52 @@
#:generate
(λ (ctc)
(λ (fuel)
(let* ([max-n 2147483647]
[min-n -2147483648]
[upper (if (> (between/c-high ctc) max-n)
max-n
(between/c-high ctc))]
[lower (if (< (between/c-low ctc) min-n)
min-n
(between/c-low ctc))])
(+ (* (random) (- upper lower))
lower))))))
(define n (between/c-low ctc))
(define m (between/c-high ctc))
(cond
[(= n m)
(λ ()
(define choice (rand-choice
[1/2 n]
[else m]))
(rand-choice
[1/2 (if (exact? choice)
(if (= (exact->inexact choice) choice)
(exact->inexact choice)
choice)
(if (= (* 1.0 choice) choice)
(* 1.0 choice)
choice))]
[else choice]))]
[else
(λ ()
(rand-choice
[1/10 (if (<= n 0 m)
(rand-choice [1/3 0] [1/3 0.0] [else -0.0])
(rand-choice [1/2 n] [else m]))]
[1/20 (if (<= n 1 m)
1
(rand-choice [1/2 n] [else m]))]
[1/20 (if (<= n -1 m)
-1
(rand-choice [1/2 n] [else m]))]
[1/10 m]
[1/10 n]
[1/10 (if (<= n 0 1 m)
(random)
(rand-choice [1/2 n] [else m]))]
[else
(cond
[(or (= n -inf.0) (= m +inf.0))
(define c (random 4294967087))
(cond
[(and (= n -inf.0) (= m +inf.0)) c]
[(= m +inf.0) (+ n c)]
[(= n -inf.0) (- m c)])]
[else
(+ n (* (random) (- m n)))])]))])))))
(define (maybe-neg n) (rand-choice [1/2 n] [else (- n)]))
(define (check-unary-between/c sym x)
(unless (real? x)
@ -646,26 +682,24 @@
`(</c ,x)
(λ (y) (and (real? y) (< y x)))
(λ (fuel)
(let* ([max-n 2147483647]
[min-n -2147483648]
[upper (if (> x max-n)
max-n
x)])
(+ (* (random) (- upper min-n))
min-n)))))
(λ ()
(rand-choice
[1/10 -inf.0]
[1/10 (- x 0.01)]
[4/10 (- x (random))]
[else (- x (random 4294967087))])))))
(define (>/c x)
(flat-named-contract
`(>/c ,x)
(λ (y) (and (real? y) (> y x)))
(λ (fuel)
(let* ([max-n 2147483647]
[min-n -2147483648]
[lower (if (< x min-n)
min-n
x)])
(+ (* (random) (- max-n lower))
lower)))))
(λ ()
(rand-choice
[1/10 +inf.0]
[1/10 (+ x 0.01)]
[4/10 (+ x (random))]
[else (+ x (random 4294967087))])))))
(define (check-two-args name arg1 arg2 pred1? pred2?)
(unless (pred1? arg1)
@ -699,20 +733,30 @@
(define (listof-generate elem-ctc)
(λ (fuel)
(define (mk-rand-list so-far)
(rand-choice
[1/5 so-far]
[else
(define next-elem (generate/direct elem-ctc fuel))
(if (generate-ctc-fail? next-elem)
(mk-rand-list so-far)
(mk-rand-list (cons next-elem so-far)))]))
(mk-rand-list (list))))
(define eg (generate/choose elem-ctc fuel))
(if eg
(λ ()
(let loop ([so-far '()])
(rand-choice
[1/5 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)
(λ (fuel)
(define eg (generate/choose elem-ctc fuel))
(if eg
(λ ()
(let loop ([so-far (list (eg))])
(rand-choice
[1/5 so-far]
[else (loop (cons (eg) so-far))])))
#f)))
(define (*-listof predicate? name generate)
(λ (input)
(let* ([ctc (coerce-contract name input)]
@ -793,7 +837,7 @@
(define non-empty-listof-func (*-listof non-empty-list?
'non-empty-listof
(λ (ctc) (make-generate-ctc-fail))))
non-empty-listof-generate))
(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"))
@ -881,15 +925,15 @@
(define (list/c-generate ctc)
(define elem-ctcs (generic-list/c-args ctc))
(λ (fuel)
(let loop ([elem-ctcs elem-ctcs]
[result '()])
(cond
[(null? elem-ctcs) (reverse result)]
[else
(define next-elem (generate/direct (car elem-ctcs) fuel))
(if (generate-ctc-fail? next-elem)
next-elem
(loop (cdr elem-ctcs) (cons next-elem result)))]))))
(define gens (for/list ([elem-ctc (in-list elem-ctcs)])
(generate/choose elem-ctc fuel)))
(cond
[(andmap values gens)
(λ ()
(for/list ([gen (in-list gens)])
(gen)))]
[else
#f])))
(struct generic-list/c (args))
@ -1669,19 +1713,18 @@
(define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
(define (flat-named-contract name predicate [generate #f])
(let ([generate (or generate (make-generate-ctc-fail))])
(cond
[(and (procedure? predicate)
(procedure-arity-includes? predicate 1))
(make-predicate-contract name predicate generate)]
[(flat-contract? predicate)
(make-predicate-contract name (flat-contract-predicate predicate) generate)]
[else
(raise-argument-error 'flat-named-contract
(format "~s" `(or/c flat-contract?
(and/c procedure?
(λ (x) (procedure-arity-include? x 1)))))
predicate)])))
(cond
[(and (procedure? predicate)
(procedure-arity-includes? predicate 1))
(make-predicate-contract name predicate generate)]
[(flat-contract? predicate)
(make-predicate-contract name (flat-contract-predicate predicate) generate)]
[else
(raise-argument-error 'flat-named-contract
(format "~s" `(or/c flat-contract?
(and/c procedure?
(λ (x) (procedure-arity-include? x 1)))))
predicate)]))
(define printable/c
(flat-named-contract

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

@ -97,12 +97,11 @@
(stronger a b)))
(define (contract-struct-generate c)
(let* ([prop (contract-struct-property c)]
[generate (contract-property-generate prop)])
(if (procedure? generate)
; FIXME: Call needs to take multiple arguments
(generate c)
(make-generate-ctc-fail))))
(define prop (contract-struct-property c))
(define generate (contract-property-generate prop))
(if (procedure? generate)
(generate c)
#f))
(define (contract-struct-exercise c)
(let* ([prop (contract-struct-property c)]

9
racket/collects/racket/contract/private/rand.rkt
View File

@ -9,9 +9,6 @@
permute
oneof)
;; random generator
(define my-generator (make-pseudo-random-generator))
(define (rand [x #f])
(if x
@ -23,8 +20,6 @@
(parameterize ([current-pseudo-random-generator my-generator])
(random-seed x)))
(rand-seed 0)
(define-syntax (rand-choice stx)
(syntax-case stx ()
[(_ (a case1 case2 ...) ...)
@ -81,13 +76,13 @@
; oneof :: [a] -> a
; Randomly chooses one of the values from a given list
(define (oneof a-list)
(list-ref a-list (random (length a-list))))
(list-ref a-list (rand (length a-list))))
; fisher-yates shuffle
(define (permute a-list)
(do ((v (list->vector a-list)) (n (length a-list) (- n 1)))
((zero? n) (vector->list v))
(let* ((r (random n)) (t (vector-ref v r)))
(let* ((r (rand n)) (t (vector-ref v r)))
(vector-set! v r (vector-ref v (- n 1)))
(vector-set! v (- n 1) t))))