clean up and export support for exercising values with contracts

racket/collects/racket/contract.rkt

@@ -12,4 +12,5 @@
                        "contract/region.rkt"
                        "contract/private/legacy.rkt"
                        "contract/private/ds.rkt")
-         contract-random-generate)
+         contract-random-generate
+         contract-exercise)

racket/collects/racket/contract/private/arrow-val-first.rkt

@@ -784,28 +784,6 @@
     [else
      (λ (fuel) (values void '()))]))
 
-#|
-
-         (λ (v) 
-           (let* ([new-fuel (/ fuel 2)]
-                  [gen-if-fun (λ (c v)
-                                ; If v is a function we need to gen the domain and call
-                                (if (procedure? v)
-                                    (let ([newargs (map (λ (c) (contract-random-generate c new-fuel))
-                                                        (base->-doms c))])
-                                      (let* ([result (call-with-values 
-                                                      (λ () (apply v newargs))
-                                                      list)]
-                                             [rngs (base->-rngs c)])
-                                        (andmap (λ (c v) 
-                                                  ((contract-struct-exercise c) v new-fuel))
-                                                rngs 
-                                                result)))
-                                    ; Delegate to check-ctc-val
-                                    ((contract-struct-exercise c) v new-fuel)))])
-             (andmap gen-if-fun (base->-doms ctc) args)))))]
-|#
-
 (define (base->-name ctc)
   (define rngs (base->-rngs ctc))
   (define rng-sexp

racket/collects/racket/contract/private/generate.rkt

@@ -9,11 +9,23 @@
 (provide generate-env
          env-stash
          contract-random-generate
+         contract-exercise
          generate/direct
          generate/choose
          make-generate-ctc-fail
          generate-ctc-fail?
-         with-definitely-available-contracts)
+         with-definitely-available-contracts
+         can-generate/env?
+         try/env)
+
+(define (contract-exercise v [fuel 10])
+  (define ctc (value-contract v))
+  (when ctc
+    (define-values (go ctcs) 
+      (parameterize ([generate-env (make-hash)])
+        ((contract-struct-exercise ctc) fuel)))
+    (for ([x (in-range fuel)])
+      (go v))))
 
 ;; a stash of values and the contracts that they correspond to
 ;; that generation has produced earlier in the process 
@@ -54,15 +66,21 @@
 ; #f if no value could be generated
 (define (generate/choose ctc fuel)
   (define direct (generate/direct ctc fuel))
-  (define env (generate/env ctc fuel))
+  (define env-can? (can-generate/env? ctc))
+  (define env (generate-env))
   (cond
-    [(and direct env)
+    [direct
      (λ ()
-       (if (zero? (rand 2))
+       (define use-direct? (zero? (rand 2)))
+       (if use-direct?
            (direct)
-           (env)))]
-    [else
-     (or direct env)]))
+           (try/env ctc env direct)))]
+    [env-can?
+     (λ ()
+       (try/env 
+        ctc env
+        (λ () (error 'generate/choose "internal generation failure"))))]
+    [else #f]))
 
 ; generate/direct :: contract nonnegative-int -> (or/c #f (-> val))
 ;; generate directly via the contract's built-in generator, if possible
@@ -84,3 +102,17 @@
            (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)]
+               #:when (contract-stronger? avail-ctc ctc)
+               [v (in-list vs)])
+      v))
+  (cond
+    [(null? available) (fail)]
+    [else (oneof available)]))
+
+(define (can-generate/env? ctc)
+  (for/or ([avail-ctc (in-list (definitely-available-contracts))])
+    (contract-stronger? avail-ctc ctc)))

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

@@ -132,18 +132,33 @@
                      (loop (cdr ho-contracts))]))))
             '())))
 
-(define (or/c-generate ctcs)
-  (λ (fuel)
-    (define choices 
-      (filter 
-       values
-       (for/list ([ctc (in-list ctcs)])
-         (generate/choose ctc fuel))))
-    (cond
-      [(null? choices) #f]
-      [else
-       (lambda ()
-         ((oneof choices)))])))
+(define ((or/c-generate ctcs) fuel)
+  (define directs 
+    (filter
+     values
+     (for/list ([ctc (in-list ctcs)])
+       (generate/direct ctc fuel))))
+  (define can-generate?
+    (or (pair? directs)
+        (for/or ([ctc (in-list ctcs)])
+          (can-generate/env? ctc))))
+  (cond
+    [can-generate?
+     (define options (append directs ctcs))
+     (define env (generate-env))
+     (λ ()
+       (let loop ([options (permute options)])
+         (cond
+           [(null? options) (error 'or/c-generate "shouldn't fail!")]
+           [else
+            (define option (car options))
+            (cond
+              [(contract? option)
+               (try/env 
+                option env
+                (λ () 
+                  (loop (cdr options))))]
+              [else (option)])])))]))
 
 (define-struct single-or/c (name pred flat-ctcs ho-ctc)
   #:property prop:orc-contract
@@ -406,4 +421,4 @@
   (λ (x)
      (or (char? x) (symbol? x) (boolean? x)
          (null? x) (keyword? x) (number? x)
-         (void? x))))
+         (void? x))))