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

improve or/c random generation and get rid of old, not-working

Browse Source 
generation for the old-style -> contracts
This commit is contained in:
Robby Findler 2014-04-27 07:34:11 -05:00
parent 76c6a1b7b0
commit 9e9b291d4a
3 changed files with 30 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -55,3 +55,20 @@
(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?))))
(check-not-exn (lambda () (test-contract-generation (or/c #f number?))))
(check-not-exn (lambda () (test-contract-generation (or/c some-crazy-predicate?
some-crazy-predicate?
some-crazy-predicate?
some-crazy-predicate?
some-crazy-predicate?
some-crazy-predicate?
some-crazy-predicate?
some-crazy-predicate?
some-crazy-predicate?
some-crazy-predicate?
#f))))
(check-exn cannot-generate-exn? (λ () (test-contract-generation
(or/c some-crazy-predicate?
some-crazy-predicate?))))

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

@ -606,43 +606,6 @@
(not (base->-post this))
(not (base->-post 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 '->-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))))))
(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-random-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:custom-write custom-write-property-proc
#:property prop:chaperone-contract
@ -651,9 +614,7 @@
#:projection (->-proj chaperone-procedure)
#:name ->-name
#:first-order ->-first-order
#:stronger ->-stronger?
#:generate ->-generate
#:exercise ->-exercise)))
#:stronger ->-stronger?)))
(define-struct (impersonator-> base->) ()
#:property prop:custom-write custom-write-property-proc
@ -662,9 +623,7 @@
#:projection (->-proj impersonate-procedure)
#:name ->-name
#:first-order ->-first-order
#:stronger ->-stronger?
#:generate ->-generate
#:exercise ->-exercise))
#:stronger ->-stronger?))
(define (build--> name
pre post

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

@ -404,8 +404,17 @@
(λ (ctc) (flat-or/c-pred ctc))
#:generate
(λ (ctc)
(λ (fuel)
(generate/direct (oneof (flat-or/c-flat-ctcs ctc)) fuel)))))
(λ (fuel)
(define choices
(filter
values
(for/list ([ctc (in-list (flat-or/c-flat-ctcs ctc))])
(generate/choose ctc fuel))))
(cond
[(null? choices) #f]
[else
(lambda ()
((oneof choices)))])))))
(define (and-name ctc)