diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt index d500883b3f..75143175f0 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt @@ -2,7 +2,8 @@ (require racket/contract racket/contract/private/generate-base - rackunit) + rackunit + (for-syntax racket/base)) ;; this is expected to never have a generator. (define (some-crazy-predicate? x) (and (number? x) (= x 11))) @@ -36,6 +37,7 @@ (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 any/c))) (check-not-exn (λ () (test-contract-generation (listof boolean?)))) (check-not-exn (λ () (test-contract-generation (listof some-crazy-predicate?)))) @@ -106,3 +108,41 @@ (-> (listof some-crazy-predicate?) some-crazy-predicate?)))) +(define (pos-exn-or-silence? val-or-exn) + (or (void? val-or-exn) + (and (string? val-or-exn) + (regexp-match #rx"blaming: pos" val-or-exn)))) + +(define (pos-exn? val-or-exn) + (and (string? val-or-exn) + (regexp-match #rx"blaming: pos" val-or-exn))) + +(define-syntax (check-exercise stx) + (syntax-case stx () + [(_ N pred exp) + (syntax/loc stx + (check-pred + pred + (with-handlers ([exn:fail? exn-message]) + (contract-exercise exp N) + (void))))])) + + +;; the tests below that use pos-exn? have a +;; (vanishingly small) probability of not passing. + +(check-exercise + 10000 + pos-exn? + (contract (-> (or/c #f some-crazy-predicate?) some-crazy-predicate?) + (λ (x) (if x 'fail 11)) + 'pos + 'neg)) + +(check-exercise + 10000 + pos-exn? + (contract (-> (or/c #f some-crazy-predicate?) (or/c #f some-crazy-predicate?)) + (λ (x) (if x 'fail 11)) + 'pos + 'neg)) diff --git a/racket/collects/racket/contract/private/generate.rkt b/racket/collects/racket/contract/private/generate.rkt index 0a03a113df..39bf26d3ca 100644 --- a/racket/collects/racket/contract/private/generate.rkt +++ b/racket/collects/racket/contract/private/generate.rkt @@ -49,17 +49,18 @@ (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: ~e" - (coerce-contract 'contract-random-generate ctc)))]) +(define (contract-random-generate ctc fuel [_fail #f]) (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))))) + (define proc + (parameterize ([generate-env (make-hash)]) + (generate/choose def-ctc fuel))) + (cond + [proc (proc)] + [_fail (_fail)] + [else + (error 'contract-random-generate + "unable to construct any generator for contract: ~e" + def-ctc)])) ;; generate/choose : contract? nonnegative-int -> (or/c #f (-> any/c)) ; Iterates through generation methods until failure. Returns @@ -86,23 +87,6 @@ ;; 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. -;; NB: this doesn't yet try to call things in the environment to generate -(define (generate/env ctc fuel) - (define env (generate-env)) - (for/or ([avail-ctc (in-list (definitely-available-contracts))]) - (and (contract-stronger? avail-ctc ctc) - (λ () - (define available - (for/list ([(avail-ctc vs) (in-hash 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))))) - (define (try/env ctc env fail) (define available (for/list ([(avail-ctc vs) (in-hash env)] diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index e2425a8e30..8179d3b9ef 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -7,7 +7,8 @@ "blame.rkt" "guts.rkt" "rand.rkt" - "generate.rkt") + "generate.rkt" + "generate-base.rkt") (provide flat-rec-contract flat-murec-contract @@ -922,6 +923,14 @@ (define (any? x) #t) (define any/c-neg-party-fn (λ (val) (λ (neg-party) val))) +(define (random-any/c fuel) + (rand-choice + [1/2 (oneof '(0 #f "" () #() -1 1 #t elephant))] + [else + ((hash-ref predicate-generator-table + (oneof (hash-keys predicate-generator-table))) + fuel)])) + (define-struct any/c () #:property prop:custom-write custom-write-property-proc #:omit-define-syntaxes @@ -931,6 +940,7 @@ #:val-first-projection (λ (ctc) (λ (blame) any/c-neg-party-fn)) #:stronger (λ (this that) (any/c? that)) #:name (λ (ctc) 'any/c) + #:generate (λ (ctc) (λ (fuel) (λ () (random-any/c fuel)))) #:first-order get-any?)) (define/final-prop any/c (make-any/c)) diff --git a/racket/collects/racket/contract/private/orc.rkt b/racket/collects/racket/contract/private/orc.rkt index 17295dea4b..61fd09fe36 100644 --- a/racket/collects/racket/contract/private/orc.rkt +++ b/racket/collects/racket/contract/private/orc.rkt @@ -132,7 +132,7 @@ (loop (cdr ho-contracts))])))) '()))) -(define ((or/c-generate ctcs) fuel) +(define ((or/c-generate or/c-ctc ctcs) fuel) (define directs (filter values @@ -144,7 +144,8 @@ (can-generate/env? ctc)))) (cond [can-generate? - (define options (append directs ctcs)) + ;; #f => try to use me in the env. + (define options (cons #f (append directs ctcs))) (define env (generate-env)) (λ () (let loop ([options (permute options)]) @@ -153,11 +154,14 @@ [else (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))))] + (λ () (loop (cdr options))))] [else (option)])])))] [else #f])) @@ -176,7 +180,8 @@ #:name single-or/c-name #:first-order single-or/c-first-order #:stronger single-or/c-stronger? - #:generate (λ (ctc) (or/c-generate (cons (single-or/c-ho-ctc ctc) + #:generate (λ (ctc) (or/c-generate ctc + (cons (single-or/c-ho-ctc ctc) (single-or/c-flat-ctcs ctc)))) #:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc))))))) @@ -189,7 +194,8 @@ #:name single-or/c-name #:first-order single-or/c-first-order #:stronger single-or/c-stronger? - #:generate (λ (ctc) (or/c-generate (cons (single-or/c-ho-ctc ctc) + #:generate (λ (ctc) (or/c-generate ctc + (cons (single-or/c-ho-ctc ctc) (single-or/c-flat-ctcs ctc)))) #:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc)))))) @@ -325,7 +331,8 @@ #:name multi-or/c-name #:first-order multi-or/c-first-order #:stronger multi-or/c-stronger? - #:generate (λ (ctc) (or/c-generate (append (multi-or/c-ho-ctcs ctc) + #:generate (λ (ctc) (or/c-generate ctc + (append (multi-or/c-ho-ctcs ctc) (multi-or/c-flat-ctcs ctc)))) #:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc)))))) @@ -338,7 +345,8 @@ #:name multi-or/c-name #:first-order multi-or/c-first-order #:stronger multi-or/c-stronger? - #:generate (λ (ctc) (or/c-generate (append (multi-or/c-ho-ctcs ctc) + #:generate (λ (ctc) (or/c-generate ctc + (append (multi-or/c-ho-ctcs ctc) (multi-or/c-flat-ctcs ctc)))) #:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc))))) @@ -385,7 +393,7 @@ #:first-order (λ (ctc) (flat-or/c-pred ctc)) - #:generate (λ (ctc) (or/c-generate (flat-or/c-flat-ctcs ctc))))) + #:generate (λ (ctc) (or/c-generate ctc (flat-or/c-flat-ctcs ctc))))) diff --git a/racket/collects/racket/contract/private/struct-dc.rkt b/racket/collects/racket/contract/private/struct-dc.rkt index 55a3123bd5..ddae1237a7 100644 --- a/racket/collects/racket/contract/private/struct-dc.rkt +++ b/racket/collects/racket/contract/private/struct-dc.rkt @@ -25,7 +25,8 @@ "blame.rkt" "prop.rkt" "misc.rkt" - "opt.rkt") + "opt.rkt" + "generate.rkt") ;; these are the runtime structs for struct/dc. ;; each struct/dc contract has a list of subcontract's attached @@ -633,6 +634,17 @@ (define-struct base-struct/dc (subcontracts pred struct-name here name-info struct/c?)) +(define (struct/dc-exercise stct) + (λ (fuel) + (define env (generate-env)) + (values + (λ (val) + ;; need to extract the fields and do it in + ;; the right order to figure out the contracts + ;; and then throw them into the environment + (void)) + (map indep-ctc (filter indep? (base-struct/dc-subcontracts stct)))))) + (define-struct (struct/dc base-struct/dc) () #:property prop:chaperone-contract (parameterize ([skip-projection-wrapper? #t]) @@ -640,7 +652,8 @@ #:name struct/dc-name #:first-order struct/dc-first-order #:projection struct/dc-proj - #:stronger struct/dc-stronger?))) + #:stronger struct/dc-stronger? + #:exercise struct/dc-exercise))) (define-struct (flat-struct/dc base-struct/dc) () #:property prop:flat-contract @@ -649,7 +662,8 @@ #:name struct/dc-name #:first-order struct/dc-flat-first-order #:projection struct/dc-proj - #:stronger struct/dc-stronger?))) + #:stronger struct/dc-stronger? + #:exercise struct/dc-exercise))) (define-struct (impersonator-struct/dc base-struct/dc) () #:property prop:contract @@ -658,7 +672,8 @@ #:name struct/dc-name #:first-order struct/dc-first-order #:projection struct/dc-proj - #:stronger struct/dc-stronger?))) + #:stronger struct/dc-stronger? + #:exercise struct/dc-exercise))) (define (build-struct/dc subcontracts pred struct-name here name-info struct/c?) (for ([subcontract (in-list subcontracts)])