contract improvements

- add a generator for cons/c
- make flat-rec-contract not just build the predicate, meaning:
  - it has a better name
  - it can do random generation
- make the procedures that come from any/c random generation indicate that from their names
- make or/c with one argument just (check and) return that argument, so
  (or/c (or/c number?)) has the name 'number?'

pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt

@@ -37,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 (cons/c integer? boolean?))))
 (check-not-exn (λ () (test-contract-generation any/c)))
 
 (check-not-exn (λ () (test-contract-generation (listof boolean?))))
@@ -45,6 +46,14 @@
 (check-not-exn (λ () (test-contract-generation (list/c boolean? number?))))
 (check-not-exn (λ () ((car (test-contract-generation (list/c (-> number? number?)))) 0)))
 
+(check-not-exn
+ (λ ()
+   (test-contract-generation
+    (flat-rec-contract
+     even-length-list/c
+     (or/c (cons/c any/c (cons/c any/c even-length-list/c))
+           '())))))
+
 (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?)) +)))

pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt

@@ -121,7 +121,7 @@
   (test-name '(unconstrained-domain-> number?) (unconstrained-domain-> number?))
 
   (test-name '(or/c) (or/c))
-  (test-name '(or/c '()) (or/c '()))
+  (test-name 'integer? (or/c integer?))
   (test-name '(or/c integer? gt0?) (or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?)))
   (test-name '(or/c integer? boolean?)
              (or/c (flat-contract integer?)

racket/collects/racket/contract/base.rkt

@@ -51,6 +51,7 @@
              check-unary-between/c
              random-any/c)
  symbols or/c one-of/c
+ flat-rec-contract
  provide/contract
  ;(for-syntax make-provide/contract-transformer) ;; not documented!
  contract-out

racket/collects/racket/contract/private/misc.rkt

@@ -10,8 +10,7 @@
          "generate.rkt"
          "generate-base.rkt")
 
-(provide flat-rec-contract
+(provide flat-murec-contract
-         flat-murec-contract
          and/c
          not/c
          =/c >=/c <=/c </c >/c between/c
@@ -62,29 +61,6 @@
          
          random-any/c)
 
-(define-syntax (flat-rec-contract stx)
-  (syntax-case stx  ()
-    [(_ name ctc ...)
-     (identifier? (syntax name))
-     (with-syntax ([(ctc-id ...) (generate-temporaries (syntax (ctc ...)))]
-                   [(pred-id ...) (generate-temporaries (syntax (ctc ...)))])
-       (syntax 
-        (let* ([pred flat-rec-contract/init]
-               [name (flat-contract (let ([name (λ (x) (pred x))]) name))])
-          (let ([ctc-id (coerce-flat-contract 'flat-rec-contract ctc)] ...)
-            (set! pred
-                  (let ([pred-id (flat-contract-predicate ctc-id)] ...)
-                    (λ (x)
-                      (or (pred-id x) ...))))
-            name))))]
-    [(_ name ctc ...)
-     (raise-syntax-error 'flat-rec-contract
-                         "expected first argument to be an identifier"
-                         stx
-                         (syntax name))]))
-
-(define (flat-rec-contract/init x) (error 'flat-rec-contract "applied too soon"))
-
 (define-syntax (flat-murec-contract stx)
   (syntax-case stx  ()
     [(_ ([name ctc ...] ...) body1 body ...)
@@ -563,19 +539,30 @@
           #:name ctc-name
           #:first-order fo-check
           #:val-first-projection (val-first-ho-check (λ (v a d) v))
-          #:projection (ho-check (λ (v a d) v)))]
+          #:projection (ho-check (λ (v a d) v))
+          #:generate (cons/c-generate ctc-car ctc-cdr))]
         [(and (chaperone-contract? ctc-car) (chaperone-contract? ctc-cdr))
          (make-chaperone-contract
           #:name ctc-name
           #:first-order fo-check
           #:val-first-projection (val-first-ho-check (λ (v a d) (cons a d)))
-          #:projection (ho-check (λ (v a d) (cons a d))))]
+          #:projection (ho-check (λ (v a d) (cons a d)))
+          #:generate (cons/c-generate ctc-car ctc-cdr))]
         [else
          (make-contract
           #:name ctc-name
           #:first-order fo-check
           #:val-first-projection (val-first-ho-check (λ (v a d) (cons a d)))
-          #:projection (ho-check (λ (v a d) (cons a d))))]))))
+          #:projection (ho-check (λ (v a d) (cons a d)))
+          #:generate (cons/c-generate ctc-car ctc-cdr))]))))
+
+(define (cons/c-generate ctc-car ctc-cdr)
+  (λ (fuel)
+    (define car-gen (generate/choose ctc-car fuel))
+    (define cdr-gen (generate/choose ctc-cdr fuel))
+    (and car-gen
+         cdr-gen
+         (λ () (cons (car-gen) (cdr-gen))))))
 
 (define (raise-not-cons-blame-error blame val #:missing-party [missing-party #f])
   (raise-blame-error
@@ -946,13 +933,15 @@
              (oneof (hash-keys predicate-generator-table)))
    fuel))
 (define (any/c-procedure env fuel)
-  (procedure-reduce-arity
+  (procedure-rename
-   (λ args
+   (procedure-reduce-arity
-     (apply
+    (λ args
-      values
+      (apply
-      (for/list ([i (in-range (rand-nat))])
+       values
-        (random-any/c env fuel))))
+       (for/list ([i (in-range (rand-nat))])
-   (rand-nat)))
+         (random-any/c env fuel))))
+    (rand-nat))
+   'random-any/c-generated-procedure))
 
 (define-struct any/c ()
   #:property prop:custom-write custom-write-property-proc

racket/collects/racket/contract/private/opters.rkt

@@ -142,7 +142,10 @@
        #:stronger-ribs stronger-ribs
        #:chaperone chaperone?
        #:no-negative-blame? no-negative-blame
-       #:name (or name-from-hos #`(list 'or/c #,@names)))))
+       #:name (or name-from-hos 
+                  (if (= (length names) 1)
+                      (car names)
+                      #`(list 'or/c #,@names))))))
   
   (syntax-case stx (or/c)
     [(or/c p ...)

racket/collects/racket/contract/private/orc.rkt

@@ -4,14 +4,17 @@
          "guts.rkt"
          "rand.rkt"
          "generate.rkt"
-         "misc.rkt")
+         "misc.rkt"
+         (for-syntax racket/base))
 
 (provide symbols or/c one-of/c
-         blame-add-or-context)
+         blame-add-or-context
+         (rename-out [_flat-rec-contract flat-rec-contract]))
 
 (define/subexpression-pos-prop or/c
   (case-lambda 
     [() (make-none/c '(or/c))]
+    [(x) (coerce-contract 'or/c x)]
     [raw-args
      (define args (coerce-contracts 'or/c raw-args))
      (define-values (ho-contracts flat-contracts)
@@ -431,3 +434,46 @@
      (or (char? x) (symbol? x) (boolean? x)
          (null? x) (keyword? x) (number? x)
          (void? x))))
+
+(define (get-flat-rec-me ctc)
+  (define ans (flat-rec-contract-me ctc))
+  (unless ans (error 'flat-rec-contract "attempted to access the contract too early"))
+  ans)
+
+(struct flat-rec-contract ([me #:mutable] name)
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:name
+   (λ (ctc) (flat-rec-contract-name ctc))
+   #:stronger
+   (λ (this that) (equal? this that))
+   #:first-order
+   (λ (ctc) 
+     (λ (v)
+       ((contract-first-order (get-flat-rec-me ctc)) v)))
+   #:generate 
+   (λ (ctc) 
+     (λ (fuel)
+       (if (zero? fuel)
+           #f
+           (generate/choose (get-flat-rec-me ctc) (- fuel 1)))))))
+
+(define-syntax (_flat-rec-contract stx)
+  (syntax-case stx  ()
+    [(_ name ctc ...)
+     (identifier? (syntax name))
+     (syntax
+      (let ([name (flat-rec-contract #f 'name)])
+        (set-flat-rec-contract-me!
+         name
+         (or/c (coerce-flat-contract 'flat-rec-contract ctc) 
+               ...))
+        name))]
+    [(_ name ctc ...)
+     (raise-syntax-error 'flat-rec-contract
+                         "expected first argument to be an identifier"
+                         stx
+                         (syntax name))]))
+(define (flat-rec-contract/init x) 
+  (error 'flat-rec-contract "applied too soon"))