From ffd77693ee14728d8e196414559c02573dcfa115 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 2 Feb 2015 22:13:52 -0600 Subject: [PATCH] fix a bug in random contract generation that could cause nested structure to have contract-random-generate-fail stuck into it and clean up some confusing structure in the random generator --- .../tests/racket/contract-rand-test.rkt | 9 +++ .../racket/contract/private/generate.rkt | 79 +++++++++---------- .../collects/racket/contract/private/orc.rkt | 37 +++++---- 3 files changed, 71 insertions(+), 54 deletions(-) diff --git a/pkgs/racket-test/tests/racket/contract-rand-test.rkt b/pkgs/racket-test/tests/racket/contract-rand-test.rkt index e1dd4e986b..d7cf7ff6c9 100644 --- a/pkgs/racket-test/tests/racket/contract-rand-test.rkt +++ b/pkgs/racket-test/tests/racket/contract-rand-test.rkt @@ -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 diff --git a/racket/collects/racket/contract/private/generate.rkt b/racket/collects/racket/contract/private/generate.rkt index 9a9143f93b..1523a90db3 100644 --- a/racket/collects/racket/contract/private/generate.rkt +++ b/racket/collects/racket/contract/private/generate.rkt @@ -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)])) diff --git a/racket/collects/racket/contract/private/orc.rkt b/racket/collects/racket/contract/private/orc.rkt index 85ebdf09e6..ff74567209 100644 --- a/racket/collects/racket/contract/private/orc.rkt +++ b/racket/collects/racket/contract/private/orc.rkt @@ -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)