diff --git a/collects/racket/contract/private/generate.rkt b/collects/racket/contract/private/generate.rkt index a55384ca96..3dbd637806 100644 --- a/collects/racket/contract/private/generate.rkt +++ b/collects/racket/contract/private/generate.rkt @@ -101,16 +101,18 @@ (generate/direct ctc fuel))) ; generate : contract int -> ctc value or error -(define (contract-generate ctc fuel) - (let ([def-ctc (coerce-contract 'contract-generate ctc)]) - (parameterize ([generate-env (make-hash)]) - ; choose randomly - (let ([val (generate/choose def-ctc fuel)]) - (if (generate-ctc-fail? val) - (error 'contract-generate - "Unable to construct any generator for contract: ~e" - ctc) - val))))) +(define (contract-generate ctc fuel [fail (λ () + (error 'contract-generate + "Unable to construct any generator for contract: ~s" + (contract-struct-name (coerce-contract 'contract-generate ctc))))]) + (let ([def-ctc (coerce-contract 'contract-generate ctc)]) + (printf "def-ctc ~s\n" def-ctc) + (parameterize ([generate-env (make-hash)]) + ; choose randomly + (let ([val (generate/choose def-ctc fuel)]) + (if (generate-ctc-fail? val) + (fail) + val))))) ; Iterates through generation methods until failure. Returns ; generate-ctc-fail if no value could be generated diff --git a/collects/racket/contract/private/guts.rkt b/collects/racket/contract/private/guts.rkt index cbb9895abc..721960681f 100644 --- a/collects/racket/contract/private/guts.rkt +++ b/collects/racket/contract/private/guts.rkt @@ -269,6 +269,8 @@ (if (symbol? (eq-contract-val ctc)) `',(eq-contract-val ctc) (eq-contract-val ctc))) + #:generate + (λ (ctc) (λ (fuel) (eq-contract-val ctc))) #:stronger (λ (this that) (and (eq-contract? that) @@ -282,7 +284,9 @@ #:stronger (λ (this that) (and (equal-contract? that) - (equal? (equal-contract-val this) (equal-contract-val that)))))) + (equal? (equal-contract-val this) (equal-contract-val that)))) + #:generate + (λ (ctc) (λ (fuel) (equal-contract-val ctc))))) (define-struct =-contract (val) #:property prop:flat-contract @@ -292,7 +296,9 @@ #:stronger (λ (this that) (and (=-contract? that) - (= (=-contract-val this) (=-contract-val that)))))) + (= (=-contract-val this) (=-contract-val that)))) + #:generate + (λ (ctc) (λ (fuel) (=-contract-val ctc))))) (define-struct regexp/c (reg) #:property prop:flat-contract diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt index d6d283f26d..6f51a1559a 100644 --- a/collects/racket/contract/private/misc.rkt +++ b/collects/racket/contract/private/misc.rkt @@ -598,7 +598,7 @@ (define-syntax (*-listof stx) (syntax-case stx () - [(_ predicate? type-name name) + [(_ predicate? type-name name generate) (identifier? (syntax predicate?)) (syntax (λ (input) @@ -623,117 +623,26 @@ #:name ctc-name #:first-order fo-check #:projection (ho-check (λ (p v) (for-each p v) v)) - #:generate (listof-generate ctc))] + #:generate (generate ctc))] [(chaperone-contract? ctc) (make-chaperone-contract #:name ctc-name #:first-order fo-check #:projection (ho-check (λ (p v) (map p v))) - #:generate (listof-generate ctc))] + #:generate (generate ctc))] [else (make-contract #:name ctc-name #:first-order fo-check - #:projection (ho-check (λ (p v) (map p v))) - )]))))])) + #:projection (ho-check (λ (p v) (map p v))))]))))])) -(define listof-func (*-listof list? list listof)) +(define listof-func (*-listof list? list listof listof-generate)) (define/subexpression-pos-prop (listof x) (listof-func x)) -#| -(define (listof element-ctc) - ; (printf "bla") - (if (flat-contract? element-ctc) - (begin - ; (printf "flat\n") - (make-listof-flat/c element-ctc)) - (begin - ; (printf "non-flat\n") - (make-listof/c element-ctc)))) -|# - -;(*-immutableof list? map andmap list listof)) - -(define-struct listof-flat/c (element-ctc) - #:omit-define-syntaxes - #:property prop:flat-contract - (build-flat-contract-property - #:name - (λ (ctc) - (build-compound-type-name 'listof (object-name (listof-flat/c-element-ctc ctc)))) - #| - #:projection - (λ (ctc) - ; (let* ([content-pred? (listof-flat/c-element-ctc ctc)]) - (let* ([content-ctc (listof-flat/c-element-ctc ctc)] - [content-pred? (flat-contract-predicate ctc)]) - (λ (blame) - (λ (x) - (unless (and (list? x) (andmap content-pred? x)) - (raise-blame-error - blame - x - "expected <~a>, given: ~e" - 'type-name - x)) - #t)))) - |# - #:first-order - (λ (ctc) - (let ([content-pred? (listof-flat/c-element-ctc ctc)]) - (λ (val) - (and (list? val) (andmap content-pred? val))))) - #:generate - (λ (ctc) - ; #f) - (listof-generate (listof-flat/c-element-ctc ctc))) - #:exercise - (λ (ctc) - ; #f))) - (listof-exercise (listof-flat/c-element-ctc ctc))))) - - - - -(define-struct listof/c (element-ctc) - #:omit-define-syntaxes - #:property prop:contract - (build-contract-property - #:name - (λ (ctc) - (build-compound-type-name 'listof (object-name (listof/c-element-ctc ctc)))) - #:projection - (λ (ctc) - (let* ([el-ctc (listof/c-element-ctc ctc)] - [proj (contract-projection el-ctc)]) - (λ (blame) - (let ([p-app (proj blame)]) - (λ (val) - (unless (list? val) - (raise-blame-error - blame - val - "expected <~a>, given: ~e" - 'type-name - val)) - (map p-app val)))))) - #:first-order - (λ (ctc) - list?) - #:generate - (λ (ctc) - ; #f) - (listof-generate (listof/c-element-ctc ctc))) - #:exercise - (λ (ctc) - ; #f))) - (listof-exercise (listof/c-element-ctc ctc))))) - (define (non-empty-list? x) (and (pair? x) (list (cdr x)))) -(define non-empty-listof-func (*-listof non-empty-list? non-empty-list non-empty-listof)) +(define non-empty-listof-func (*-listof non-empty-list? non-empty-list non-empty-listof (λ (ctc) (make-generate-ctc-fail)))) (define/subexpression-pos-prop (non-empty-listof a) (non-empty-listof-func a)) - (define cons/c-main-function (λ (car-c cdr-c) (let* ([ctc-car (coerce-contract 'cons/c car-c)] @@ -994,19 +903,18 @@ (coerce-contract 'contract-projection ctc))) (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) -(define (flat-named-contract name predicate [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 - (error 'flat-named-contract - "expected a flat contract or procedure of arity 1 as second argument, got ~e" - 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 + (error 'flat-named-contract + "expected a flat contract or procedure of arity 1 as second argument, got ~e" + predicate)]))) (define printable/c (flat-named-contract diff --git a/collects/racket/contract/private/prop.rkt b/collects/racket/contract/private/prop.rkt index f2fe2fa5b0..7fc96ec920 100644 --- a/collects/racket/contract/private/prop.rkt +++ b/collects/racket/contract/private/prop.rkt @@ -186,7 +186,7 @@ get-name get-first-order)])] [stronger (or stronger weakest)]) - (mk get-name get-first-order get-projection stronger generate exercise ))) + (mk get-name get-first-order get-projection stronger generate exercise))) (define build-contract-property (build-property make-contract-property 'anonymous-contract values)) @@ -271,7 +271,7 @@ #:projection (lambda (c) (make-flat-contract-projection c)) #:stronger (lambda (a b) ((make-flat-contract-stronger a) a b)) #:generate (lambda (c) (make-flat-contract-generate c)) - #:exercise (lambda (c) (make-chaperone-contract-exercise c)))) + #:exercise (lambda (c) (make-flat-contract-exercise c)))) (define ((build-contract mk default-name) #:name [name #f] diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 9f62fc00e8..e372020475 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -86,13 +86,10 @@ satisfies the contract if the predicate returns a true value.} @defproc[(flat-named-contract [type-name any/c] [predicate (or/c flat-contract? (any/c . -> . any))] - [#:generate generator (-> contract (-> int? 'a-val))]) + [generator (or/c #f (-> contract (-> int? any))) #f]) flat-contract?]{ -The generator argument adds a generator for the flat-named-contract. See -@racket[contract-generate] for more information. - -On predicates like @racket[flat-contract], but the first argument must be the +On predicates, behaves like @racket[flat-contract], but the first argument must be the (quoted) name of a contract used for error reporting. For example, @racketblock[(flat-named-contract @@ -102,6 +99,9 @@ turns the predicate into a contract with the name @tt{odd-integer}. On flat contracts, the new flat contract is the same as the old except for the name. + +The generator argument adds a generator for the flat-named-contract. See +@racket[contract-generate] for more information. } @defthing[any/c flat-contract?]{ @@ -2089,9 +2089,13 @@ parts of the contract system. } @section{Random generation} -@defproc[(contract-generate [ctc contract?] [fuel int?]) any/c]{ +@defproc[(contract-generate [ctc contract?] [fuel int?] [fail (-> any/c) (λ () (error ...))]) any/c]{ Attempts to randomly generate a value which will match the contract. The fuel -argument limits the depth that the argument generation can go and thus the -memory used. In order to know which contracts to generate, it may be necessary -to add a generator for the generate keyword argument in @racket[struct] +argument limits how hard the generator tries to generate a contract and is a rough +limit of the size of the resulting value. + +The generator may fail to generate a contract, either because some contracts +do not have corresponding generators (for example, not all predicates have +generators) or because there is not enough fuel. In either case, the +thunk @racket[fail] is invoked. }