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

Started on random testing for contracts

Browse Source
This commit is contained in:
Andy Gocke 2011-02-22 03:43:31 -06:00 committed by Robby Findler
parent 37a7e0a2e1
commit b8847a53bf
13 changed files with 728 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/racket/contract.rkt
View File

@ -5,10 +5,12 @@
"contract/region.rkt"
"contract/private/basic-opters.rkt"
"contract/private/legacy.rkt"
"contract/private/ds.rkt")
"contract/private/ds.rkt"
"contract/private/generate.rkt")
(provide (all-from-out "contract/base.rkt"
"contract/combinator.rkt"
"contract/parametric.rkt"
"contract/region.rkt"
"contract/private/legacy.rkt"
"contract/private/ds.rkt"))
"contract/private/ds.rkt"
"contract/private/generate.rkt"))

3
collects/racket/contract/base.rkt
View File

@ -20,8 +20,7 @@
procedure-accepts-and-more?
check-procedure
check-procedure/more
make-contracted-function
contracted-function?
contracted-function-proc
contracted-function-ctc

58
collects/racket/contract/private/arrow.rkt
View File

@ -18,10 +18,12 @@ v4 todo:
|#
(require "guts.rkt"
"blame.rkt"
"prop.rkt"
"misc.rkt"
"generate.rkt"
racket/stxparam)
(require (for-syntax racket/base)
(for-syntax "helpers.rkt")
@ -30,9 +32,12 @@ v4 todo:
(for-syntax "arr-util.rkt"))
(provide ->
base->?
->*
->d
case->
base->-rngs/c
base->-doms/c
unconstrained-domain->
the-unsupplied-arg
(rename-out [-predicate/c predicate/c])
@ -520,13 +525,54 @@ v4 todo:
(= (length (base->-rngs/c that)) (length (base->-rngs/c this)))
(andmap contract-stronger? (base->-rngs/c this) (base->-rngs/c that))))
(define (->-generate ctc)
(let ([doms-l (length (base->-doms/c ctc))])
(λ (fuel)
(let ([rngs-gens (map (λ (c) (generate/choose c (/ fuel 2)))
(base->-rngs/c ctc))])
(if (member #t (map generate-ctc-fail? rngs-gens))
(make-generate-ctc-fail)
(procedure-reduce-arity
(λ args
; Make sure that the args match the contract
(begin (unless ((contract-struct-exercise ctc) args (/ fuel 2))
(error "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))))))
(define (->-exercise ctc)
(λ (args fuel)
(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-generate c new-fuel))
(base->-doms/c c))])
(let* ([result (call-with-values
(λ () (apply v newargs))
list)]
[rngs (base->-rngs/c 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/c ctc) args))))
(define-struct (chaperone-> base->) ()
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:projection (->-proj chaperone-procedure)
#:name ->-name
#:first-order ->-first-order
#:stronger ->-stronger?))
#:stronger ->-stronger?
#:generate ->-generate
#:exercise ->-exercise))
(define-struct (impersonator-> base->) ()
#:property prop:contract
@ -534,7 +580,9 @@ v4 todo:
#:projection (->-proj impersonate-procedure)
#:name ->-name
#:first-order ->-first-order
#:stronger ->-stronger?))
#:stronger ->-stronger?
#:generate ->-generate
#:exercise ->-exercise))
(define (build--> name
pre post
@ -659,9 +707,9 @@ v4 todo:
#f))]))))]))
(define-for-syntax (maybe-a-method/name stx)
(if (syntax-parameter-value #'making-a-method)
(syntax-property stx 'method-arity-error #t)
stx))
(if (syntax-parameter-value #'making-a-method)
(syntax-property stx 'method-arity-error #t)
stx))
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define-for-syntax (->/proc/main stx)

26
collects/racket/contract/private/env.rkt Normal file
View File

@ -0,0 +1,26 @@
#lang racket/base
(require "arrow.rkt"
"guts.rkt")
(provide
build-env)
(define (make-env)
(list))
(define (extend-env ctc exp env)
(cons (list ctc exp)
env))
(define (build-env f-l)
(let ([value-contract (dynamic-require 'racket/contract 'value-contract)]
; [->-rngs/c (dynamic-require 'racket/contract/private/arrow '->-rngs/c)]
; [contract-stronger? (dynamic-require 'racket/contract 'contract-stronger?)]
[env-item (dynamic-require 'racket/contract/private/generator-base 'env-item)]
; [->-rngs/c (dynamic-require 'racket/contract/private/arrow '->-rngs/c)]
)
(map (λ (f)
(env-item (value-contract f)
f))
f-l))
)

82
collects/racket/contract/private/generate-base.rkt Normal file
View File

@ -0,0 +1,82 @@
#lang racket/base
(provide
make-generate-ctc-fail
generate-ctc-fail?
find-generate
add-generate
print-freq
get-freq
merge-freq
count-missing-generate
get-arg-names-space
gen-arg-names
env-item
env-item-name
env-item-ctc)
;; generate
(define-struct env-item (ctc name))
;; generate failure type
(define-struct generate-ctc-fail ())
;; hash tables
(define freq-hash (make-hash))
(define gen-hash (make-hash))
;; thread-cell
(define arg-names-count (make-thread-cell 0))
;; given a predicate returns a generate for this predicate or generate-ctc-fail
(define (find-generate func [name "internal"])
(hash-ref gen-hash func (make-generate-ctc-fail)))
(define (add-generate ctc gen)
(hash-set! gen-hash ctc gen))
(define (get-arg-names-space space-needed)
(let ([rv (thread-cell-ref arg-names-count)])
(thread-cell-set! arg-names-count (+ rv space-needed))
rv))
(define (gen-arg-names st-num size)
(cond
[(<= size 0) (list)]
[else (cons (string->symbol (string-append "x-" (number->string st-num)))
(gen-arg-names (+ st-num 1) (- size 1)))]))
(define (print-freq)
(let* ([l (hash-map freq-hash (λ (k v)
(list k v)))]
[l-s (sort l (λ (e1 e2)
(> (list-ref e1 1)
(list-ref e2 1))))])
(map (λ (x)
(printf "# ~a : ~a\n"
(list-ref x 1)
(list-ref x 0)))
l-s))
null)
(define (count-missing-generate ctc)
(hash-update! freq-hash
ctc
(λ (x)
(+ x 1))
0))
(define (get-freq)
freq-hash)
(define (merge-freq h)
(hash-for-each h (λ (k v)
(hash-set! freq-hash k (+ (hash-ref freq-hash k 0)
v)))))

164
collects/racket/contract/private/generate.rkt Normal file
View File

@ -0,0 +1,164 @@
#lang racket/base
(require "rand.rkt"
"generate-base.rkt"
"guts.rkt"
"prop.rkt"
racket/list)
(provide generate-env
env-stash
contract-generate
generate/direct
generate/choose
make-generate-ctc-fail
generate-ctc-fail?)
; env parameter
(define generate-env (make-parameter #f))
; 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))))
;; hash tables
;(define freq-hash (make-hash))
;(define gen-hash (make-hash))
;; thread-cell
;(define arg-names-count (make-thread-cell 0))
;; generate integer?
(add-generate integer?
(λ (fuel)
(rand-choice
[1/10 0]
[1/10 1]
[1/10 -1]
[1/10 2147483647]
[1/10 -2147483648]
[3/10 (rand-range -100 200)]
[else (rand-range -1000000000 2000000000)])))
(add-generate exact-nonnegative-integer?
(λ (fuel)
(abs ((find-generate integer?) fuel))))
(add-generate positive?
(λ (fuel)
(rand-choice
[1/10 1]
[1/10 1/3]
[1/10 0.12]
[1/10 2147483647]
[else 4])))
(add-generate boolean?
(λ (fuel)
(rand-choice
[1/2 #t]
[else #f])))
(add-generate char?
(λ (fuel)
(let* ([gen (oneof (list (rand-range 0 55295)
(rand-range 57344 1114111)))])
(integer->char gen))))
(add-generate string?
(λ (fuel)
(let* ([len (rand-choice [1/10 0]
[1/10 1]
[else (rand-range 2 260)])]
[strl (build-list len
(λ (x)
(gen-pred/direct char? fuel)))])
(apply string strl))))
(add-generate byte?
(λ (fuel)
(rand 256)))
(add-generate bytes?
(λ (fuel)
(let* ([len (rand-choice
[1/10 0]
[1/10 1]
[else (+ 2 (rand 260))])]
[bstr (build-list len
(λ (x)
(rand 256)))])
(apply bytes bstr))))
(define (gen-pred/direct pred fuel)
(let ([ctc (coerce-contract 'contract-direct-gen pred)])
(generate/direct ctc fuel)))
; generate : contract int -> ctc value or error
(define (contract-generate ctc fuel)
(let ([def-ctc (coerce-contract 'contract-generate ctc)])
(parameterize ([generate-env (make-hash)])
; choose randomly
(let ([val (generate/choose def-ctc fuel)])
(if (generate-ctc-fail? val)
(error 'contract-generate
"Unable to construct any generator for contract: ~e"
ctc)
val)))))
; Iterates through generation methods until failure. Returns
; generate-ctc-fail 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))))))
; 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
; 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)))

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

@ -1,6 +1,11 @@
#lang racket/base
(require "prop.rkt")
(require "helpers.rkt"
"blame.rkt"
"prop.rkt"
"rand.rkt"
"generate-base.rkt"
racket/pretty)
(require (for-syntax racket/base))
@ -148,7 +153,7 @@
(cond
[(contract-struct? x) x]
[(and (procedure? x) (procedure-arity-includes? x 1))
(make-predicate-contract (or (object-name x) '???) x)]
(make-predicate-contract (or (object-name x) '???) x (make-generate-ctc-fail))]
[(or (symbol? x) (boolean? x) (char? x) (null? x)) (make-eq-contract x)]
[(or (bytes? x) (string? x)) (make-equal-contract x)]
[(number? x) (make-=-contract x)]
@ -237,10 +242,6 @@
(if (contract-struct? sub) (contract-struct-name sub) sub)))
;
;
;
@ -308,7 +309,7 @@
(and (regexp/c? that) (eq? (regexp/c-reg this) (regexp/c-reg that))))))
(define-struct predicate-contract (name pred)
(define-struct predicate-contract (name pred generate)
#:property prop:flat-contract
(build-flat-contract-property
#:stronger
@ -317,7 +318,18 @@
(procedure-closure-contents-eq? (predicate-contract-pred this)
(predicate-contract-pred that))))
#:name (λ (ctc) (predicate-contract-name ctc))
#:first-order (λ (ctc) (predicate-contract-pred ctc))))
#:first-order (λ (ctc) (predicate-contract-pred ctc))
#: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)))
#: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)])
(make-predicate-contract name pred generate))

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

@ -4,7 +4,9 @@
racket/promise
"prop.rkt"
"blame.rkt"
"guts.rkt")
"guts.rkt"
"rand.rkt"
"generate.rkt")
(provide flat-rec-contract
flat-murec-contract
@ -295,7 +297,12 @@
that-ctcs)))))
#:first-order
(λ (ctc) (flat-or/c-pred ctc))))
(λ (ctc) (flat-or/c-pred ctc))
#:generate
(λ (ctc)
(λ (fuel)
(generate/direct (oneof (flat-or/c-flat-ctcs ctc)) fuel)))
))
(define (and-name ctc)
@ -482,7 +489,20 @@
[m (between/c-high ctc)])
(λ (x)
(and (real? x)
(<= n x m)))))))
(<= n x m)))))
#: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-syntax (check-unary-between/c stx)
(syntax-case stx ()
@ -514,11 +534,28 @@
(define (</c x)
(flat-named-contract
`(</c ,x)
(λ (y) (and (real? y) (< y 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)))))
(define (>/c x)
(flat-named-contract
`(>/c ,x)
(λ (y) (and (real? y) (> y x)))))
`(>/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)))))
(define/final-prop (integer-in start end)
(unless (and (integer? start)
@ -546,6 +583,19 @@
(build-compound-type-name 'not/c ctc)
(λ (x) (not (pred x))))))
(define (listof-generate elem-ctc)
(λ (fuel)
(define (mk-rand-list so-far)
(rand-choice
[1/5 so-far]
[else (mk-rand-list (cons (generate/direct elem-ctc fuel)
so-far))]))
(mk-rand-list (list))))
(define (listof-exercise el-ctc)
(λ (f n-tests size env)
#t))
(define-syntax (*-listof stx)
(syntax-case stx ()
[(_ predicate? type-name name)
@ -572,25 +622,118 @@
(make-flat-contract
#:name ctc-name
#:first-order fo-check
#:projection (ho-check (λ (p v) (for-each p v) v)))]
#:projection (ho-check (λ (p v) (for-each p v) v))
#:generate (listof-generate ctc))]
[(chaperone-contract? ctc)
(make-chaperone-contract
#:name ctc-name
#:first-order fo-check
#:projection (ho-check (λ (p v) (map p v))))]
#:projection (ho-check (λ (p v) (map p v)))
#:generate (listof-generate ctc))]
[else
(make-contract
#:name ctc-name
#:first-order fo-check
#:projection (ho-check (λ (p v) (map p v))))]))))]))
#:projection (ho-check (λ (p v) (map p v)))
)]))))]))
(define listof-func (*-listof list? list listof))
(define/subexpression-pos-prop (listof x) (listof-func x))
(define (non-empty-list? x) (and (pair? x) (list? (cdr x))))
#|
(define (listof element-ctc)
; (printf "bla")
(if (flat-contract? element-ctc)
(begin
; (printf "flat\n")
(make-listof-flat/c element-ctc))
(begin
; (printf "non-flat\n")
(make-listof/c element-ctc))))
|#
;(*-immutableof list? map andmap list listof))
(define-struct listof-flat/c (element-ctc)
#:omit-define-syntaxes
#:property prop:flat-contract
(build-flat-contract-property
#:name
(λ (ctc)
(build-compound-type-name 'listof (object-name (listof-flat/c-element-ctc ctc))))
#|
#:projection
(λ (ctc)
; (let* ([content-pred? (listof-flat/c-element-ctc ctc)])
(let* ([content-ctc (listof-flat/c-element-ctc ctc)]
[content-pred? (flat-contract-predicate ctc)])
(λ (blame)
(λ (x)
(unless (and (list? x) (andmap content-pred? x))
(raise-blame-error
blame
x
"expected <~a>, given: ~e"
'type-name
x))
#t))))
|#
#:first-order
(λ (ctc)
(let ([content-pred? (listof-flat/c-element-ctc ctc)])
(λ (val)
(and (list? val) (andmap content-pred? val)))))
#:generate
(λ (ctc)
; #f)
(listof-generate (listof-flat/c-element-ctc ctc)))
#:exercise
(λ (ctc)
; #f)))
(listof-exercise (listof-flat/c-element-ctc ctc)))))
(define-struct listof/c (element-ctc)
#:omit-define-syntaxes
#:property prop:contract
(build-contract-property
#:name
(λ (ctc)
(build-compound-type-name 'listof (object-name (listof/c-element-ctc ctc))))
#:projection
(λ (ctc)
(let* ([el-ctc (listof/c-element-ctc ctc)]
[proj (contract-projection el-ctc)])
(λ (blame)
(let ([p-app (proj blame)])
(λ (val)
(unless (list? val)
(raise-blame-error
blame
val
"expected <~a>, given: ~e"
'type-name
val))
(map p-app val))))))
#:first-order
(λ (ctc)
list?)
#:generate
(λ (ctc)
; #f)
(listof-generate (listof/c-element-ctc ctc)))
#:exercise
(λ (ctc)
; #f)))
(listof-exercise (listof/c-element-ctc ctc)))))
(define (non-empty-list? x) (and (pair? x) (list (cdr x))))
(define non-empty-listof-func (*-listof non-empty-list? non-empty-list non-empty-listof))
(define/subexpression-pos-prop (non-empty-listof a) (non-empty-listof-func a))
(define cons/c-main-function
(λ (car-c cdr-c)
(let* ([ctc-car (coerce-contract 'cons/c car-c)]
@ -851,13 +994,13 @@
(coerce-contract 'contract-projection ctc)))
(define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
(define (flat-named-contract name predicate)
(define (flat-named-contract name predicate [generate (make-generate-ctc-fail)])
(cond
[(and (procedure? predicate)
(procedure-arity-includes? predicate 1))
(make-predicate-contract name predicate)]
(make-predicate-contract name predicate generate)]
[(flat-contract? predicate)
(make-predicate-contract name (flat-contract-predicate predicate))]
(make-predicate-contract name (flat-contract-predicate predicate) generate)]
[else
(error 'flat-named-contract
"expected a flat contract or procedure of arity 1 as second argument, got ~e"

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

@ -1,6 +1,7 @@
#lang racket/base
(require "blame.rkt")
(require "blame.rkt"
"generate-base.rkt")
(provide prop:contract
contract-struct?
@ -8,6 +9,8 @@
contract-struct-first-order
contract-struct-projection
contract-struct-stronger?
contract-struct-generate
contract-struct-exercise
prop:flat-contract
flat-contract-struct?
@ -34,7 +37,7 @@
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct contract-property [ name first-order projection stronger generator ]
(define-struct contract-property [ name first-order projection stronger generate exercise ]
#:omit-define-syntaxes)
(define (contract-property-guard prop info)
@ -73,6 +76,23 @@
[stronger (contract-property-stronger prop)])
(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)
(begin
(count-missing-generate (contract-struct-name c))
(make-generate-ctc-fail)))))
(define (contract-struct-exercise c)
(let* ([prop (contract-struct-property c)]
[exercise (contract-property-exercise prop)])
(if (procedure? exercise)
(exercise c)
(make-generate-ctc-fail))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Chaperone Contract Property
@ -154,7 +174,8 @@
#:first-order [get-first-order #f]
#:projection [get-projection #f]
#:stronger [stronger #f]
#:generator [generator #f])
#:generate [generate (make-generate-ctc-fail)]
#:exercise [exercise (make-generate-ctc-fail)])
(let* ([get-name (or get-name (lambda (c) default-name))]
[get-first-order (or get-first-order get-any?)]
@ -165,7 +186,7 @@
get-name get-first-order)])]
[stronger (or stronger weakest)])
(mk get-name get-first-order get-projection stronger generator)))
(mk get-name get-first-order get-projection stronger generate exercise )))
(define build-contract-property
(build-property make-contract-property 'anonymous-contract values))
@ -219,7 +240,7 @@
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct make-contract [ name first-order projection stronger ]
(define-struct make-contract [ name first-order projection stronger generate exercise ]
#:omit-define-syntaxes
#:property prop:contract
(build-contract-property
@ -227,9 +248,10 @@
#:first-order (lambda (c) (make-contract-first-order c))
#:projection (lambda (c) (make-contract-projection c))
#:stronger (lambda (a b) ((make-contract-stronger a) a b))
#:generator #f))
#:generate (lambda (c) ((make-contract-generate c)))
#:exercise (lambda (c) ((make-contract-exercise c)))))
(define-struct make-chaperone-contract [ name first-order projection stronger ]
(define-struct make-chaperone-contract [ name first-order projection stronger generate exercise ]
#:omit-define-syntaxes
#:property prop:chaperone-contract
(build-chaperone-contract-property
@ -237,9 +259,10 @@
#:first-order (lambda (c) (make-chaperone-contract-first-order c))
#:projection (lambda (c) (make-chaperone-contract-projection c))
#:stronger (lambda (a b) ((make-chaperone-contract-stronger a) a b))
#:generator #f))
#:generate (lambda (c) (make-chaperone-contract-generate c))
#:exercise (lambda (c) (make-chaperone-contract-exercise c))))
(define-struct make-flat-contract [ name first-order projection stronger ]
(define-struct make-flat-contract [ name first-order projection stronger generate exercise ]
#:omit-define-syntaxes
#:property prop:flat-contract
(build-flat-contract-property
@ -247,20 +270,23 @@
#:first-order (lambda (c) (make-flat-contract-first-order c))
#:projection (lambda (c) (make-flat-contract-projection c))
#:stronger (lambda (a b) ((make-flat-contract-stronger a) a b))
#:generator #f))
#:generate (lambda (c) (make-flat-contract-generate c))
#:exercise (lambda (c) (make-chaperone-contract-exercise c))))
(define ((build-contract mk default-name)
#:name [name #f]
#:first-order [first-order #f]
#:projection [projection #f]
#:stronger [stronger #f])
#:stronger [stronger #f]
#:generate [generate (make-generate-ctc-fail)]
#:exercise [exercise (make-generate-ctc-fail)] )
(let* ([name (or name default-name)]
[first-order (or first-order any?)]
[projection (or projection (first-order-projection name first-order))]
[stronger (or stronger as-strong?)])
(mk name first-order projection stronger)))
(mk name first-order projection stronger generate exercise)))
(define (as-strong? a b)
(procedure-closure-contents-eq?
@ -275,3 +301,4 @@
(define make-flat-contract
(build-contract make-make-flat-contract 'anonymous-flat-contract))

89
collects/racket/contract/private/rand.rkt Normal file
View File

@ -0,0 +1,89 @@
#lang racket/base
(require (for-syntax scheme/base))
(provide rand
rand-seed
rand-choice
rand-range
permute
oneof)
;; random generator
(define my-generator (make-pseudo-random-generator))
(define (rand [x #f])
(if x
(random x my-generator)
(random my-generator)))
(define (rand-seed x)
(parameterize ([current-pseudo-random-generator my-generator])
(random-seed x)))
(rand-seed 0)
(define-syntax (rand-choice stx)
(syntax-case stx ()
[(_ (a case1 case2 ...) ...)
(begin
(let ([ns (let loop ([sum 0]
[as (syntax->list #'(a ...))])
(cond
[(null? as) (raise-syntax-error #f "expected at least one case" stx)]
[(null? (cdr as))
(syntax-case (car as) (else)
[else (list (- 1 sum))]
[_ (raise-syntax-error #f "expected last option to be `else'" stx (car as))])]
[else
(let ([n (syntax-e (car as))])
(unless (and (real? n)
(exact? n)
(positive? n)
(< n 1))
(raise-syntax-error #f "expected each option to be a real exact number in the interval (0,1)" stx (car as)))
(unless (< (+ n sum) 1)
(raise-syntax-error #f "expected the sum of the options to be less than 1" stx #f (syntax->list #'(a ...))))
(cons n (loop (+ sum n)
(cdr as))))]))])
(let* ([dens (map denominator ns)]
[choices (map (λ (x) (* (numerator x) (apply * (remove
(denominator x) dens))))
ns)])
#`(rand-choice/proc '(#,@choices)
#,(apply * dens)
(list (λ () case1 case2 ...) ...)))))]))
(define (rand-choice/proc choices prod thunks)
(let ([choice (rand prod)])
(let loop ([n choice]
[nums choices]
[thunks thunks])
(cond
[(null? nums) (error 'rand-chance "internal error!")]
[else
(cond
[(< n (car nums))
((car thunks))]
[else
(loop (- n (car nums))
(cdr nums)
(cdr thunks))])]))))
; 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))))
; 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)))
(vector-set! v r (vector-ref v (- n 1)))
(vector-set! v (- n 1) t))))
(define (rand-range lower upper)
(+ lower (rand (- upper lower))))

18
collects/scribblings/reference/contracts.scrbl
View File

@ -6,7 +6,7 @@
@(define contract-eval
(lambda ()
(let ([the-eval (make-base-eval)])
(the-eval '(require racket/contract))
(the-eval '(require racket/contract racket/contract/parametric))
the-eval)))
@title[#:tag "contracts" #:style 'toc]{Contracts}
@ -84,10 +84,14 @@ Constructs a @tech{flat contract} from @racket[predicate]. A value
satisfies the contract if the predicate returns a true value.}
@defproc[(flat-named-contract [type-name any/c]
[predicate (or/c flat-contract? (any/c . -> . any))])
@defproc[(flat-named-contract [type-name any/c]
[predicate (or/c flat-contract? (any/c . -> . any))]
[#:generate generator (-> contract (-> int? 'a-val))])
flat-contract?]{
The generator argument adds a generator for the flat-named-contract. See
@racket[contract-generate] for more information.
On predicates like @racket[flat-contract], but the first argument must be the
(quoted) name of a contract used for error reporting.
For example,
@ -2083,3 +2087,11 @@ parts of the contract system.
struct and returns a projection function that checks the contract.
}
@section{Random generation}
@defproc[(contract-generate [ctc contract?] [fuel int?]) any/c]{
Attempts to randomly generate a value which will match the contract. The fuel
argument limits the depth that the argument generation can go and thus the
memory used. In order to know which contracts to generate, it may be necessary
to add a generator for the generate keyword argument in @racket[struct]
}

12
collects/scribblings/reference/struct.scrbl
View File

@ -100,7 +100,9 @@ override the default @racket[equal?] definition through the
[immutables (listof exact-nonnegative-integer?)
null]
[guard (or/c procedure? #f) #f]
[constructor-name (or/c symbol? #f) #f])
[constructor-name (or/c symbol? #f) #f]
[generate (-> contract? (-> int? any/c))]
[exercise (-> contract? (-> int? any/c any/c))])
(values struct-type?
struct-constructor-procedure?
struct-predicate-procedure?
@ -174,6 +176,14 @@ If @racket[constructor-name] is not @racket[#f], it is used as the
name of the generated @tech{constructor} procedure as returned by
@racket[object-name] or in the printed form of the constructor value.
The @racket[generate] argument is used to define a new generator for
this structure type, which can be used to create random instances of
the structure type. For more information see @racket[contract-generate].
The @racket[exercise] argument allows you to define a function to verify
that a given value is an instance of your contract. This will also be used
for random generation.
The result of @racket[make-struct-type] is five values:
@itemize[

68
collects/tests/racket/contract-rand-test.rkt Normal file
View File

@ -0,0 +1,68 @@
#lang racket/base
(require racket/contract
rackunit
rackunit/text-ui
net/url)
(define (test-contract-generation ctc
[monkey-with values]
#:size [size 10])
;; generator : number[of tests] number[size bound] ??[env] -> any
(define example-vals (contract-generate ctc size))
(monkey-with (contract ctc example-vals 'pos 'neg)))
(define pred-tests
(test-suite
"Predicate contract"
(check-not-exn (λ () (test-contract-generation integer?)))
(check-not-exn (λ () (test-contract-generation exact-nonnegative-integer?)))
(check-not-exn (λ () (test-contract-generation boolean?)))
(check-not-exn (λ () (test-contract-generation char?)))
(check-not-exn (λ () (test-contract-generation byte?)))
(check-not-exn (λ () (test-contract-generation bytes?)))
(check-not-exn (λ () (test-contract-generation string?)))
))
(define flat-ctc-tests
(test-suite
"Built-in flat contracts"
(check-not-exn (λ () (test-contract-generation (between/c 1 100))))
(check-not-exn (λ () (test-contract-generation (listof integer?))))
(check-not-exn (λ () (test-contract-generation (>=/c 0))))
(check-not-exn (λ () (test-contract-generation (<=/c 0))))
(check-not-exn (λ () (test-contract-generation (>/c 0))))
(check-not-exn (λ () (test-contract-generation (</c 0))))
(check-not-exn (λ () (test-contract-generation (or/c boolean? boolean?))))
))
(define func-tests
(test-suite
"Function contracts"
(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 (-> (or/c bytes string?)
; url?)
; "test")))
))
;(define net/url-tests
; (test-suite "net/url contracts"
(define ctc-gen-tests
(test-suite
"All random contract generation tests"
pred-tests
flat-ctc-tests
func-tests))
(run-tests ctc-gen-tests)