Some small cleanups of Andy's contract generator code

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)
+(define (contract-generate ctc fuel [fail (λ () 
- (let ([def-ctc (coerce-contract 'contract-generate ctc)])
+                                            (error 'contract-generate
-   (parameterize ([generate-env (make-hash)])
+                                                   "Unable to construct any generator for contract: ~s"
-     ; choose randomly
+                                                   (contract-struct-name (coerce-contract 'contract-generate ctc))))])
-     (let ([val (generate/choose def-ctc fuel)])
+  (let ([def-ctc (coerce-contract 'contract-generate ctc)])
-       (if (generate-ctc-fail? val)
+    (printf "def-ctc ~s\n" def-ctc)
-         (error 'contract-generate
+    (parameterize ([generate-env (make-hash)])
-                "Unable to construct any generator for contract: ~e"
+      ; choose randomly
-                ctc)
+      (let ([val (generate/choose def-ctc fuel)])
-         val)))))
+        (if (generate-ctc-fail? val)
+            (fail)
+            val)))))
 
 ; Iterates through generation methods until failure. Returns
 ; generate-ctc-fail if no value could be generated

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

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)])
+(define (flat-named-contract name predicate [generate #f])
-  (cond
+  (let ([generate (or generate (make-generate-ctc-fail))])
-    [(and (procedure? predicate)
+    (cond
-          (procedure-arity-includes? predicate 1))
+      [(and (procedure? predicate)
-     (make-predicate-contract name predicate generate)]
+            (procedure-arity-includes? predicate 1))
-    [(flat-contract? predicate)
+       (make-predicate-contract name predicate generate)]
-     (make-predicate-contract name (flat-contract-predicate predicate) generate)]
+      [(flat-contract? predicate)
-    [else
+       (make-predicate-contract name (flat-contract-predicate predicate) generate)]
-     (error 'flat-named-contract 
+      [else
-            "expected a flat contract or procedure of arity 1 as second argument, got ~e" 
+       (error 'flat-named-contract 
-            predicate)]))
+              "expected a flat contract or procedure of arity 1 as second argument, got ~e" 
-
+              predicate)])))
-
 
 (define printable/c
   (flat-named-contract

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]

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 
+On predicates, behaves like @racket[flat-contract], but the first argument must be the
-@racket[contract-generate] for more information.
-
-On predicates 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
+argument limits how hard the generator tries to generate a contract and is a rough
-memory used. In order to know which contracts to generate, it may be necessary
+limit of the size of the resulting value. 
-to add a generator for the generate keyword argument in @racket[struct]
+
+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.
 }