add generator for (and/c real? (not/c negative?)) and (and/c rational? (not/c negative?))

rfindler · rfindler · commit 39195bd04f53 · 2014-05-16T22:43:57.000-05:00
and fix -&gt; generator for mandatory keyword arguments
diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt
@@ -36,6 +36,8 @@
 (check-not-exn (λ () (test-contract-generation (</c 0.0))))
 (check-not-exn (λ () (test-contract-generation (=/c 0))))
 (check-not-exn (λ () (test-contract-generation (=/c 0.0))))
+(check-not-exn (λ () (test-contract-generation (and/c real? (not/c negative?)))))
+(check-not-exn (λ () (test-contract-generation (and/c rational? (not/c negative?)))))
 (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)))
@@ -167,6 +169,14 @@
           (contract-exercise #:fuel N . exps)
           (void))))]))
 
+(check-exercise
+ 10
+ pos-exn-or-silence?
+ (contract (-> #:b boolean? any/c)
+           (λ (#:b b) b)
+           'pos
+           'neg))
+
 (check-exercise
  1
  pos-exn?
diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt
@@ -754,24 +754,36 @@
     [else (λ (fuel) #f)]))
 
 (define (->-exercise ctc)
-  (define dom-ctcs (base->-doms ctc))
   (define rng-ctcs (base->-rngs ctc))
+  (define dom-ctcs (for/list ([doms (in-list (base->-doms ctc))]
+                              [i (in-range (base->-min-arity ctc))])
+                     doms))
+  (define dom-kwd-infos (for/list ([dom-kwd (in-list (base->-kwd-infos ctc))]
+                                   #:when (kwd-info-mandatory? dom-kwd))
+                          dom-kwd))
+  (define dom-kwds (map kwd-info-kwd dom-kwd-infos))
   (cond
-    [(and (equal? (length dom-ctcs) (base->-min-arity ctc))
-          (not (base->-rest ctc)))
+    [(not (base->-rest ctc))
      (λ (fuel)
        (define gens 
          (for/list ([dom-ctc (in-list dom-ctcs)])
            (generate/choose dom-ctc fuel)))
+       (define kwd-gens
+         (for/list ([kwd-info (in-list dom-kwd-infos)])
+           (generate/choose (kwd-info-ctc kwd-info) fuel)))
        (define env (generate-env))
        (cond
-         [(andmap values gens)
+         [(and (andmap values gens)
+               (andmap values kwd-gens))
           (values 
            (λ (f)
              (call-with-values
               (λ ()
-                (apply 
+                (keyword-apply 
                  f
+                 dom-kwds
+                 (for/list ([kwd-gen (in-list kwd-gens)])
+                   (kwd-gen))
                  (for/list ([gen (in-list gens)])
                    (gen))))
               (λ results 
diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt
@@ -175,6 +175,33 @@
                       this-ctcs
                       that-ctcs)))))
 
+(define (and/c-generate? ctc)
+  (cond
+    [(and/c-check-nonneg ctc real?) => values]
+    [(and/c-check-nonneg ctc rational?) => values]
+    [else (λ (fuel) #f)]))
+
+(define (and/c-check-nonneg ctc pred)
+  (define sub-contracts (base-and/c-ctcs ctc))
+  (cond
+    [(are-stronger-contracts? (list pred (not/c negative?))
+                              sub-contracts)
+     (define go (hash-ref predicate-generator-table pred))
+     (λ (fuel)
+       (λ ()
+         (abs (go fuel))))]
+    [else #f]))
+
+(define (are-stronger-contracts? c1s c2s)
+  (let loop ([c1s c1s]
+             [c2s c2s])
+    (cond
+      [(and (null? c1s) (null? c2s)) #t]
+      [(and (pair? c1s) (pair? c2s))
+       (and (contract-stronger? (car c1s) (car c2s))
+            (loop (cdr c1s) (cdr c2s)))]
+      [else #f])))
+
 (define-struct base-and/c (ctcs))
 (define-struct (first-order-and/c base-and/c) (predicates)
   #:property prop:custom-write custom-write-property-proc
@@ -184,7 +211,8 @@
    #:val-first-projection first-order-val-first-and-proj
    #:name and-name
    #:first-order and-first-order
-   #:stronger and-stronger?))
+   #:stronger and-stronger?
+   #:generate and/c-generate?))
 (define-struct (chaperone-and/c base-and/c) ()
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
@@ -194,7 +222,8 @@
      #:val-first-projection val-first-and-proj
      #:name and-name
      #:first-order and-first-order
-     #:stronger and-stronger?)))
+     #:stronger and-stronger?
+     #:generate and/c-generate?)))
 (define-struct (impersonator-and/c base-and/c) ()
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
@@ -203,7 +232,8 @@
    #:val-first-projection val-first-and-proj
    #:name and-name
    #:first-order and-first-order
-   #:stronger and-stronger?))
+   #:stronger and-stronger?
+   #:generate and/c-generate?))
 
 
 (define/subexpression-pos-prop (and/c . raw-fs)
