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

fix a bug in random contract generation that could cause

Browse Source 
nested structure to have contract-random-generate-fail stuck
into it

and clean up some confusing structure in the random generator
This commit is contained in:
Robby Findler 2015-02-02 22:13:52 -06:00
parent 68074f7fd7
commit ffd77693ee
3 changed files with 71 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -35,6 +35,7 @@
(check-not-exn (λ () (test-contract-generation +nan.0)))
(check-not-exn (λ () (test-contract-generation 'x)))
(check-not-exn (λ () (test-contract-generation "x")))
(check-not-exn (λ () (test-contract-generation #t)))
(check-not-exn (λ () (test-contract-generation (listof boolean?))))
(check-not-exn (λ () (test-contract-generation (listof number?))))
@ -169,6 +170,14 @@
any/c
number?)))))
;; in this test, the and/c shoudl generate a dynamic
;; failure, which should trigger the 'cons/c' failing
;; it shouldn't make a pair of a strange value and #t
(check-not-exn
(λ ()
(test-contract-generation
(cons/c #t (and/c integer? even? odd?)))))
(check-not-exn
(λ ()
(define eleven

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

@ -13,7 +13,6 @@
contract-random-generate-env-hash
contract-random-generate-env?
contract-exercise
generate/direct
contract-random-generate-fail
contract-random-generate-fail?
with-definitely-available-contracts
@ -152,23 +151,23 @@
(define proc
(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
[(and success?
(not (contract-random-generate-fail? value)))
value]
[fail (fail (not success?))]
[else
(if success?
(error 'contract-random-generate
"unable generate a value satisfying: ~e"
def-ctc)
[proc
(define value
(let/ec k
(parameterize ([fail-escape (λ () (k contract-random-generate-fail))])
(proc))))
(cond
[(contract-random-generate-fail? value)
(if fail
(fail #f)
(error 'contract-random-generate
"unable generate a value satisfying: ~e"
def-ctc))]
[else value])]
[else
(if fail
(fail #t)
(error 'contract-random-generate
"unable to construct any generator for contract: ~e"
def-ctc))]))
@ -178,7 +177,7 @@
; #f if no value could be generated
;; 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 direct ((contract-struct-generate ctc) fuel))
(define env-can? (can-generate/env? ctc))
(define env (generate-env))
(unless (contract-random-generate-env? env)
@ -187,31 +186,30 @@
(cond
[direct
(λ ()
(define use-direct? (zero? (rand 2)))
(cond
[use-direct?
(define candidate (direct))
(if (contract-random-generate-fail? candidate)
(try/env ctc env direct)
candidate)]
[else (try/env ctc env direct)]))]
(define to-try (list direct (λ () (try/env ctc env))))
(let loop ([to-try (if (zero? (rand 2))
(reverse to-try)
to-try)])
(cond
[(null? to-try) ((fail-escape))]
[else
(define this-try ((car to-try)))
(cond
[(contract-random-generate-fail? this-try)
(loop (cdr to-try))]
[else
this-try])])))]
[env-can?
(λ ()
(try/env
ctc env
(λ () (error 'generate/choose "internal generation failure"))))]
(define candidate (try/env ctc env))
(when (contract-random-generate-fail? candidate)
(error 'contract-random-generate/choose
"internal generation failure; env should have had ~s but didn't"
ctc))
candidate)]
[else #f]))
;; generate/direct :: contract nonnegative-int -> (or/c #f (-> val))
;; generate directly via the contract's built-in generator, if possible
;; 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 (try/env ctc env)
(define env-hash (contract-random-generate-env-hash env))
(define available
(for/list ([(avail-ctc vs) (in-hash env-hash)]
@ -219,7 +217,8 @@
[v (in-list vs)])
v))
(cond
[(null? available) (fail)]
[(null? available)
contract-random-generate-fail]
[else
(oneof available)]))

37
racket/collects/racket/contract/private/orc.rkt
View File

@ -140,15 +140,17 @@
(filter
values
(for/list ([ctc (in-list ctcs)])
(generate/direct ctc fuel))))
((contract-struct-generate ctc) fuel))))
(define can-generate?
(or (pair? directs)
(for/or ([ctc (in-list ctcs)])
(can-generate/env? ctc))))
(cond
[can-generate?
;; #f => try to use me in the env.
(define options (cons #f (append directs ctcs)))
;; #f => try to use the entire or/c contract in the environment
(define options (cons #f (append
(map (λ (x) (cons 'direct x)) directs)
(map (λ (x) (cons 'env x)) ctcs))))
(define env (contract-random-generate-get-current-environment))
(λ ()
(let loop ([options (permute options)])
@ -158,21 +160,28 @@
(define option (car options))
(cond
[(not option)
(try/env
or/c-ctc env
(λ () (loop (cdr options))))]
[(contract? option)
(try/env
option env
(λ () (loop (cdr options))))]
[else
(define candidate (try/env or/c-ctc env))
(cond
[(contract-random-generate-fail? candidate)
(loop (cdr options))]
[else
candidate])]
[(equal? (car option) 'env)
(define candidate (try/env (cdr option) env))
(cond
[(contract-random-generate-fail? candidate)
(loop (cdr options))]
[else
candidate])]
[(equal? (car option) 'direct)
(define-values (succ? val)
(let/ec k
(parameterize ([fail-escape (λ () (k #f #f))])
(k #t (option)))))
(if succ?
(k #t ((cdr option))))))
(if (and succ? (not (contract-random-generate-fail? val)))
val
(loop (cdr options)))])])))]
(loop (cdr options)))]
[else (error 'racket/contract/orc.rkt "ack ~s" options)])])))]
[else #f]))
(define (single-or/c-list-contract? c)