diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl index 48feee3645..2a95b9bb0e 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -2237,10 +2237,14 @@ is expected to be the contract on the value). stronger (or/c (-> contract? contract? boolean?) #f) #f] - [#:generator + [#:generate generator - (or/c (-> number? (listof (list any/c contract?)) any/c) - #f) + (->i ([c contract?]) + ([generator + (c) + (-> (and/c positive? real?) + (or/c #f + (-> c)))])) #f]) flat-contract-property?] @defproc[(build-chaperone-contract-property @@ -2271,10 +2275,14 @@ is expected to be the contract on the value). stronger (or/c (-> contract? contract? boolean?) #f) #f] - [#:generator + [#:generate generator - (or/c (-> number? (listof (list any/c contract?)) any/c) - #f) + (->i ([c contract?]) + ([generator + (c) + (-> (and/c positive? real?) + (or/c #f + (-> c)))])) #f]) chaperone-contract-property?] @defproc[(build-contract-property @@ -2305,10 +2313,14 @@ is expected to be the contract on the value). stronger (or/c (-> contract? contract? boolean?) #f) #f] - [#:generator + [#:generate generator - (or/c (-> number? (listof (list any/c contract?)) any/c) - #f) + (->i ([c contract?]) + ([generator + (c) + (-> (and/c positive? real?) + (or/c #f + (-> c)))])) #f]) contract-property?])]{ @@ -2316,7 +2328,7 @@ is expected to be the contract on the value). @racket[val-first-projection] argument are subject to change. (Probably also the default values of the @racket[project] - arguments will change.} + arguments will change.)} These functions build the arguments for @racket[prop:contract], @@ -2330,9 +2342,9 @@ which produces a description to @racket[write] as part of a contract violation; produces a blame-tracking projection defining the behavior of the contract; @racket[stronger], which is a predicate that determines whether this contract (passed in the first argument) is stronger than some other contract (passed -in the second argument); and @racket[generator], which makes a random value -that matches the contract, given a size bound and an environment from which -to draw interesting values. +in the second argument); and @racket[generate], which returns a thunk +that generates random values matching the contract or @racket[#f], indicating +that random generation for this contract isn't supported. These accessors are passed as (optional) keyword arguments to @racket[build-contract-property], and are applied to instances of the 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 ae730aa21f..564312f6bc 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,20 +2,23 @@ (require racket/contract racket/contract/private/generate-base - rackunit - rackunit/text-ui - net/url) + rackunit) ;; this is expected to never have a generator. (define (some-crazy-predicate? x) (and (number? x) (= x 11))) (define (test-contract-generation ctc #:size [size 10]) - (define example-vals (contract-random-generate ctc size)) - (contract ctc example-vals 'pos 'neg)) + (define example-val (contract-random-generate ctc size)) + (contract ctc example-val 'pos 'neg)) (for ([(k v) (in-hash predicate-generator-table)]) (check-not-exn (λ () (test-contract-generation k)))) +;; test =, eq?, and equal? contract random generators +(check-not-exn (λ () (test-contract-generation 0))) +(check-not-exn (λ () (test-contract-generation 'x))) +(check-not-exn (λ () (test-contract-generation "x"))) + (check-not-exn (λ () (test-contract-generation (listof boolean?)))) (check-not-exn (λ () (test-contract-generation (listof number?)))) @@ -30,16 +33,21 @@ (check-not-exn (λ () (test-contract-generation (>/c 0.0)))) (check-not-exn (λ () (test-contract-generation ( number? number?)))) 0))) (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 (-> some-crazy-predicate? some-crazy-predicate?)) 11))) (define (cannot-generate-exn? x) (and (exn:fail? x) diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index 7ca9009069..a673a28c90 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -713,25 +713,37 @@ (base->-min-arity ctc)) (not (base->-rest ctc))) ;; only handle the case with no optional args and no rest args - (define doms-l (length (base->-doms ctc))) + (define dom-ctcs (base->-doms ctc)) + (define doms-l (length dom-ctcs)) (λ (fuel) - (define rngs-gens (map (λ (c) (generate/choose c (/ fuel 2))) - (base->-rngs ctc))) + (define rngs-gens + (with-definitely-available-contracts + dom-ctcs + (λ () + (for/list ([c (in-list (base->-rngs ctc))]) + (generate/choose c fuel))))) (cond - [(for/or ([rng-gen (in-list rngs-gens)]) - (generate-ctc-fail? rng-gen)) - (make-generate-ctc-fail)] - [else - (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)]))] - [else (λ (fuel) (make-generate-ctc-fail))])) + [(for/and ([rng-gen (in-list rngs-gens)]) + rng-gen) + (λ () + (define env (generate-env)) + (procedure-reduce-arity + (λ args + ; Make sure that the args match the contract + (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 + (parameterize ([generate-env env]) + (for ([ctc (in-list dom-ctcs)] + [arg (in-list args)]) + (env-stash ctc arg)) + (define results + (for/list ([rng-gen (in-list rngs-gens)]) + (rng-gen))) + (apply values results))) + doms-l))] + [else #f]))] + [else (λ (fuel) #f)])) (define (->-exercise ctc) (λ (args fuel) diff --git a/racket/collects/racket/contract/private/generate-base.rkt b/racket/collects/racket/contract/private/generate-base.rkt index 046f0ca87e..d97d041b00 100644 --- a/racket/collects/racket/contract/private/generate-base.rkt +++ b/racket/collects/racket/contract/private/generate-base.rkt @@ -125,7 +125,7 @@ ;; given a predicate returns a generate for this predicate or generate-ctc-fail (define (find-generate func [name "internal"]) - (hash-ref predicate-generator-table func make-generate-ctc-fail)) + (hash-ref predicate-generator-table func #f)) (define (get-arg-names-space space-needed) (let ([rv (thread-cell-ref arg-names-count)]) diff --git a/racket/collects/racket/contract/private/generate.rkt b/racket/collects/racket/contract/private/generate.rkt index 4126cf269a..d424ade659 100644 --- a/racket/collects/racket/contract/private/generate.rkt +++ b/racket/collects/racket/contract/private/generate.rkt @@ -8,90 +8,77 @@ (provide generate-env env-stash - contract-random-generate - generate/direct generate/choose - make-generate-ctc-fail - generate-ctc-fail?) + generate-ctc-fail? + with-definitely-available-contracts) -; env parameter +;; a stash of values and the contracts that they correspond to +;; that generation has produced earlier in the process (define generate-env (make-parameter #f)) +;; (parameter/c (listof contract?)) +;; contracts in this will definitely have values available +;; by the time generation happens; those values will be +;; in the env-stash. +(define definitely-available-contracts (make-parameter '())) + ; 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)))) - -(define (gen-pred/direct pred fuel) - (let ([ctc (coerce-contract 'contract-direct-gen pred)]) - (generate/direct ctc fuel))) +(define (env-stash ctc val) + (define env (generate-env)) + (define curvals (hash-ref env ctc '())) + (hash-set! env ctc (cons val curvals))) +(define (with-definitely-available-contracts ctcs thunk) + (parameterize ([definitely-available-contracts + (append ctcs (definitely-available-contracts))]) + (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: ~s" - (contract-struct-name - (coerce-contract 'contract-random-generate ctc))))]) - (let ([def-ctc (coerce-contract 'contract-random-generate ctc)]) - (parameterize ([generate-env (make-hash)]) - ; choose randomly - (let ([val (generate/choose def-ctc fuel)]) - (if (generate-ctc-fail? val) - (fail) - val))))) + "unable to construct any generator for contract: ~e" + (coerce-contract 'contract-random-generate ctc)))]) + (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))))) +;; generate/choose : contract? nonnegative-int -> (or/c #f (-> any/c)) ; Iterates through generation methods until failure. Returns -; generate-ctc-fail if no value could be generated +; #f 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)))))) + (let loop ([options (permute (list generate/direct generate/env))]) + (cond + [(empty? options) + #f] + [else + (define option (car options)) + (define gen (option ctc fuel)) + (or gen (loop (cdr options)))]))) -; 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 +; generate/direct :: contract nonnegative-int -> (or/c #f (-> val)) +;; 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. -; 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))) - +;; NB: this doesn't yet try to call things in the environment to generate +(define (generate/env ctc fuel) + (for/or ([avail-ctc (in-list (definitely-available-contracts))]) + (and (contract-stronger? avail-ctc ctc) + (λ () + (define available + (for/list ([(avail-ctc vs) (in-hash (generate-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))))) diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt index 13b989405f..2582c39bac 100644 --- a/racket/collects/racket/contract/private/guts.rkt +++ b/racket/collects/racket/contract/private/guts.rkt @@ -173,7 +173,7 @@ (cond [(contract-struct? x) x] [(and (procedure? x) (procedure-arity-includes? x 1)) - (make-predicate-contract (or (object-name x) '???) x (make-generate-ctc-fail))] + (make-predicate-contract (or (object-name x) '???) x #f)] [(or (symbol? x) (boolean? x) (char? x) (null? x) (keyword? x)) (make-eq-contract x)] [(or (bytes? x) (string? x)) (make-equal-contract x)] [(number? x) (make-=-contract x)] @@ -295,7 +295,9 @@ `',(eq-contract-val ctc) (eq-contract-val ctc))) #:generate - (λ (ctc) (λ (fuel) (eq-contract-val ctc))) + (λ (ctc) + (define v (eq-contract-val ctc)) + (λ (fuel) (λ () v))) #:stronger (λ (this that) (and (eq-contract? that) @@ -312,7 +314,9 @@ (and (equal-contract? that) (equal? (equal-contract-val this) (equal-contract-val that)))) #:generate - (λ (ctc) (λ (fuel) (equal-contract-val ctc))))) + (λ (ctc) + (define v (equal-contract-val ctc)) + (λ (fuel) (λ () v))))) (define-struct =-contract (val) #:property prop:custom-write custom-write-property-proc @@ -325,7 +329,9 @@ (and (=-contract? that) (= (=-contract-val this) (=-contract-val that)))) #:generate - (λ (ctc) (λ (fuel) (=-contract-val ctc))))) + (λ (ctc) + (define v (=-contract-val ctc)) + (λ (fuel) (λ () v))))) (define-struct regexp/c (reg) #:property prop:custom-write custom-write-property-proc @@ -372,17 +378,22 @@ predicate-contract-proj))) #: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))) + (cond + [generate generate] + [else + (define built-in-generator + (find-generate (predicate-contract-pred ctc) + (predicate-contract-name ctc))) + (λ (fuel) + (and built-in-generator + (λ () (built-in-generator fuel))))]))) #: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)]) +(define (build-flat-contract name pred [generate #f]) (make-predicate-contract name pred generate)) diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 3f706c10c5..13a0f3e60b 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -611,16 +611,52 @@ #: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 n (between/c-low ctc)) + (define m (between/c-high ctc)) + (cond + [(= n m) + (λ () + (define choice (rand-choice + [1/2 n] + [else m])) + (rand-choice + [1/2 (if (exact? choice) + (if (= (exact->inexact choice) choice) + (exact->inexact choice) + choice) + (if (= (* 1.0 choice) choice) + (* 1.0 choice) + choice))] + [else choice]))] + [else + (λ () + (rand-choice + [1/10 (if (<= n 0 m) + (rand-choice [1/3 0] [1/3 0.0] [else -0.0]) + (rand-choice [1/2 n] [else m]))] + [1/20 (if (<= n 1 m) + 1 + (rand-choice [1/2 n] [else m]))] + [1/20 (if (<= n -1 m) + -1 + (rand-choice [1/2 n] [else m]))] + [1/10 m] + [1/10 n] + [1/10 (if (<= n 0 1 m) + (random) + (rand-choice [1/2 n] [else m]))] + [else + (cond + [(or (= n -inf.0) (= m +inf.0)) + (define c (random 4294967087)) + (cond + [(and (= n -inf.0) (= m +inf.0)) c] + [(= m +inf.0) (+ n c)] + [(= n -inf.0) (- m c)])] + [else + (+ n (* (random) (- m n)))])]))]))))) + +(define (maybe-neg n) (rand-choice [1/2 n] [else (- n)])) (define (check-unary-between/c sym x) (unless (real? x) @@ -646,26 +682,24 @@ `( x max-n) - max-n - x)]) - (+ (* (random) (- upper min-n)) - min-n))))) + (λ () + (rand-choice + [1/10 -inf.0] + [1/10 (- x 0.01)] + [4/10 (- x (random))] + [else (- x (random 4294967087))]))))) (define (>/c x) (flat-named-contract `(>/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))))) + (λ () + (rand-choice + [1/10 +inf.0] + [1/10 (+ x 0.01)] + [4/10 (+ x (random))] + [else (+ x (random 4294967087))]))))) (define (check-two-args name arg1 arg2 pred1? pred2?) (unless (pred1? arg1) @@ -699,20 +733,30 @@ (define (listof-generate elem-ctc) (λ (fuel) - (define (mk-rand-list so-far) - (rand-choice - [1/5 so-far] - [else - (define next-elem (generate/direct elem-ctc fuel)) - (if (generate-ctc-fail? next-elem) - (mk-rand-list so-far) - (mk-rand-list (cons next-elem so-far)))])) - (mk-rand-list (list)))) + (define eg (generate/choose elem-ctc fuel)) + (if eg + (λ () + (let loop ([so-far '()]) + (rand-choice + [1/5 so-far] + [else (loop (cons (eg) so-far))]))) + (λ () '())))) (define (listof-exercise el-ctc) (λ (f n-tests size env) #t)) +(define (non-empty-listof-generate elem-ctc) + (λ (fuel) + (define eg (generate/choose elem-ctc fuel)) + (if eg + (λ () + (let loop ([so-far (list (eg))]) + (rand-choice + [1/5 so-far] + [else (loop (cons (eg) so-far))]))) + #f))) + (define (*-listof predicate? name generate) (λ (input) (let* ([ctc (coerce-contract name input)] @@ -793,7 +837,7 @@ (define non-empty-listof-func (*-listof non-empty-list? 'non-empty-listof - (λ (ctc) (make-generate-ctc-fail)))) + non-empty-listof-generate)) (define/subexpression-pos-prop (non-empty-listof a) (non-empty-listof-func a)) (define (blame-add-car-context blame) (blame-add-context blame "the car of")) @@ -881,15 +925,15 @@ (define (list/c-generate ctc) (define elem-ctcs (generic-list/c-args ctc)) (λ (fuel) - (let loop ([elem-ctcs elem-ctcs] - [result '()]) - (cond - [(null? elem-ctcs) (reverse result)] - [else - (define next-elem (generate/direct (car elem-ctcs) fuel)) - (if (generate-ctc-fail? next-elem) - next-elem - (loop (cdr elem-ctcs) (cons next-elem result)))])))) + (define gens (for/list ([elem-ctc (in-list elem-ctcs)]) + (generate/choose elem-ctc fuel))) + (cond + [(andmap values gens) + (λ () + (for/list ([gen (in-list gens)]) + (gen)))] + [else + #f]))) (struct generic-list/c (args)) @@ -1669,19 +1713,18 @@ (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) (define (flat-named-contract name predicate [generate #f]) - (let ([generate (or generate (make-generate-ctc-fail))]) - (cond - [(and (procedure? predicate) - (procedure-arity-includes? predicate 1)) - (make-predicate-contract name predicate generate)] - [(flat-contract? predicate) - (make-predicate-contract name (flat-contract-predicate predicate) generate)] - [else - (raise-argument-error 'flat-named-contract - (format "~s" `(or/c flat-contract? - (and/c procedure? - (λ (x) (procedure-arity-include? x 1))))) - predicate)]))) + (cond + [(and (procedure? predicate) + (procedure-arity-includes? predicate 1)) + (make-predicate-contract name predicate generate)] + [(flat-contract? predicate) + (make-predicate-contract name (flat-contract-predicate predicate) generate)] + [else + (raise-argument-error 'flat-named-contract + (format "~s" `(or/c flat-contract? + (and/c procedure? + (λ (x) (procedure-arity-include? x 1))))) + predicate)])) (define printable/c (flat-named-contract diff --git a/racket/collects/racket/contract/private/prop.rkt b/racket/collects/racket/contract/private/prop.rkt index 8d4d941e74..28c849260c 100644 --- a/racket/collects/racket/contract/private/prop.rkt +++ b/racket/collects/racket/contract/private/prop.rkt @@ -97,12 +97,11 @@ (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) - (make-generate-ctc-fail)))) + (define prop (contract-struct-property c)) + (define generate (contract-property-generate prop)) + (if (procedure? generate) + (generate c) + #f)) (define (contract-struct-exercise c) (let* ([prop (contract-struct-property c)] diff --git a/racket/collects/racket/contract/private/rand.rkt b/racket/collects/racket/contract/private/rand.rkt index bb458d79ab..beb46df1b3 100644 --- a/racket/collects/racket/contract/private/rand.rkt +++ b/racket/collects/racket/contract/private/rand.rkt @@ -9,9 +9,6 @@ permute oneof) - -;; random generator - (define my-generator (make-pseudo-random-generator)) (define (rand [x #f]) (if x @@ -23,8 +20,6 @@ (parameterize ([current-pseudo-random-generator my-generator]) (random-seed x))) -(rand-seed 0) - (define-syntax (rand-choice stx) (syntax-case stx () [(_ (a case1 case2 ...) ...) @@ -81,13 +76,13 @@ ; 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)))) + (list-ref a-list (rand (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))) + (let* ((r (rand n)) (t (vector-ref v r))) (vector-set! v r (vector-ref v (- n 1))) (vector-set! v (- n 1) t))))