add generator for any/c and improve generator for or/c

also improve test cases a little bit and minor Rackety

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))

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
+(define (contract-random-generate ctc fuel [_fail #f])
-                                  [fail (λ () 
-                                          (error 'contract-random-generate
-                                                 "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)])
+  (define proc
-    (let ([proc (generate/choose def-ctc fuel)])
+    (parameterize ([generate-env (make-hash)]) 
-      (if proc
+      (generate/choose def-ctc fuel)))
-          (proc)
+  (cond
-          (fail)))))
+    [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)]

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))

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)))))
 
 
 

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)])