Cleanups to first-order checking for box/vector/hash contracts.

* We no longer capture a contination when we have blame information. * We perform first-order checks more eagerly in the mutable case.
2010-09-16 14:29:42 -04:00 · 2010-09-16 14:29:42 -04:00 · 2677cbf1a4
commit 2677cbf1a4
parent 2c940a7fd0
4 changed files with 123 additions and 124 deletions
--- a/collects/racket/contract/private/box.rkt
+++ b/collects/racket/contract/private/box.rkt
@ -11,32 +11,31 @@

 (define-struct box/c (content immutable))

-(define (box/c-first-order ctc)
+(define (check-box/c ctc)
  (let ([elem-ctc (box/c-content ctc)]
        [immutable (box/c-immutable ctc)]
        [flat? (flat-box/c? ctc)])
-    (λ (val #:blame [blame #f])
+    (λ (val fail [first-order? #f])
+      (unless (box? val)
+        (fail "expected a box, got ~a" val))
+      (case immutable
+        [(#t)
+         (unless (immutable? val)
+           (fail "expected an immutable box, got ~a" val))]
+        [(#f)
+         (when (immutable? val)
+           (fail "expected a mutable box, got ~a" val))]
+        [(dont-care) (void)])
+      (when first-order?
+        (unless (contract-first-order-passes? elem-ctc (unbox val))
+          (fail "expected <~s>, got ~v" (contract-name elem-ctc) val)))
+      #t)))
+
+(define (box/c-first-order ctc)
+  (let ([check (check-box/c ctc)])
+    (λ (val)
      (let/ec return
-        (define (fail . args)
-          (if blame
-              (apply raise-blame-error blame val args)
-              (return #f)))
-        (unless (box? val)
-          (fail "expected a box, got ~a" val))
-        (case immutable
-          [(#t)
-           (unless (immutable? val)
-             (fail "expected an immutable box, got ~a" val))]
-          [(#f)
-           (when (immutable? val)
-             (fail "expected a mutable box, got ~a" val))]
-          [(dont-care) (void)])
-        (when (or flat? (and (immutable? val) (not blame)))
-          (if blame
-              (begin (((contract-projection elem-ctc) blame) (unbox val))
-                     (void))
-              (unless (contract-first-order-passes? elem-ctc (unbox val))
-                (fail))))))))
+        (check val (λ _ (return #f)) #t)))))

 (define (box/c-name ctc)
  (let ([elem-name (contract-name (box/c-content ctc))]
@ -64,7 +63,8 @@
   (λ (ctc)
     (λ (blame)
       (λ (val)
-         ((box/c-first-order ctc) val #:blame blame)
+         ((check-box/c ctc) val (λ args (apply raise-blame-error blame val args)))
+         (((contract-projection (box/c-content ctc)) blame) (unbox val))
         val)))))

 (define (ho-projection box-wrapper)
@ -75,7 +75,7 @@
        (let ([pos-elem-proj ((contract-projection elem-ctc) blame)]
              [neg-elem-proj ((contract-projection elem-ctc) (blame-swap blame))])
          (λ (val)
-            ((box/c-first-order ctc) val #:blame blame)
+            ((check-box/c ctc) val (λ args (apply raise-blame-error blame val args)))
            (if (immutable? val)
                (box-immutable (pos-elem-proj (unbox val)))
                (box-wrapper val
--- a/collects/racket/contract/private/hash.rkt
+++ b/collects/racket/contract/private/hash.rkt
@ -74,41 +74,39 @@
      [else
       (make-proxy-hash/c dom-ctc rng-ctc immutable)])))

-(define (hash/c-first-order ctc) 
+(define (check-hash/c ctc) 
  (let ([dom-ctc (hash/c-dom ctc)]
        [rng-ctc (hash/c-rng ctc)]
        [immutable (hash/c-immutable ctc)]
        [flat? (flat-hash/c? ctc)])
-    (λ (val #:blame [blame #f])
+    (λ (val fail [first-order? #f])
+      (unless (hash? val)
+        (fail "expected a hash, got ~a" val))
+      (when (and (not flat?)
+                 (not (flat-contract? dom-ctc))
+                 (not (hash-equal? val)))
+        (fail "expected equal?-based hash table due to higher-order domain contract, got ~a" val))
+      (case immutable
+        [(#t) 
+         (unless (immutable? val) 
+           (fail "expected an immutable hash, got ~a" val))]
+        [(#f)
+         (when (immutable? val)
+           (fail "expected an mutable hash, got ~a" val))]
+        [(dont-care) (void)])
+      (when first-order?
+        (for ([(k v) (in-hash val)])
+          (unless (contract-first-order-passes? dom-ctc k)
+            (fail "expected <~s> for key, got ~v" (contract-name dom-ctc) k))
+          (unless (contract-first-order-passes? rng-ctc v)
+            (fail "expected <~s> for value, got ~v" (contract-name rng-ctc) v))))
+        #t)))
+
+(define (hash/c-first-order ctc)
+  (let ([check (check-hash/c ctc)])
+    (λ (val)
      (let/ec return
-        (define (fail . args)
-          (if blame
-              (apply raise-blame-error blame val args)
-              (return #f)))
-        (unless (hash? val)
-          (fail "expected a hash, got ~a" val))
-        (when (and (not flat?)
-                   (not (flat-contract? dom-ctc))
-                   (not (hash-equal? val)))
-          (fail "expected equal?-based hash table due to higher-order domain contract, got ~a" val))
-        (case immutable
-          [(#t) 
-           (unless (immutable? val) 
-             (fail "expected an immutable hash, got ~a" val))]
-          [(#f)
-           (when (immutable? val)
-             (fail "expected an mutable hash, got ~a" val))]
-          [(dont-care) (void)])
-        (when (or flat? (immutable? val))
-          (for ([(k v) (in-hash val)])
-            (if blame
-                (begin (((contract-projection dom-ctc) blame) k)
-                       (((contract-projection rng-ctc) blame) v)
-                       (void))
-                (unless (and (contract-first-order-passes? dom-ctc k)
-                             (contract-first-order-passes? rng-ctc v))
-                  (fail)))))
-        #t))))
+        (check val (λ _ (return #f)) #t)))))

 (define (hash/c-name ctc)
  (apply 
@ -135,12 +133,16 @@
  (build-flat-contract-property
   #:name hash/c-name
   #:first-order hash/c-first-order
-   
   #:projection
   (λ (ctc)
     (λ (blame)
       (λ (val)
-         ((hash/c-first-order ctc) val #:blame blame)
+         ((check-hash/c ctc) val (λ args (apply raise-blame-error blame val args)))
+         (let ([dom-proj ((contract-projection (hash/c-dom ctc)) blame)]
+               [rng-proj ((contract-projection (hash/c-rng ctc)) blame)])
+           (for ([(k v) (in-hash val)])
+             (dom-proj k)
+             (rng-proj v)))
         val)))))

 (define (ho-projection hash-wrapper)
@ -154,7 +156,7 @@
              [pos-rng-proj (rng-proc blame)]
              [neg-rng-proj (rng-proc (blame-swap blame))])
          (λ (val)
-            ((hash/c-first-order ctc) val #:blame blame)
+            ((check-hash/c ctc) val (λ args (apply raise-blame-error blame val args)))
            
            (if (immutable? val)
                (let ([hash-maker
@ -182,22 +184,16 @@

 (define-struct (chaperone-hash/c hash/c) ()
  #:omit-define-syntaxes
-
  #:property prop:chaperone-contract
  (build-chaperone-contract-property
   #:name hash/c-name
   #:first-order hash/c-first-order
-   
-   #:projection
-   (ho-projection chaperone-hash)))
+   #:projection (ho-projection chaperone-hash)))

 (define-struct (proxy-hash/c hash/c) ()
  #:omit-define-syntaxes
-
  #:property prop:contract
  (build-contract-property
   #:name hash/c-name
   #:first-order hash/c-first-order
-   
-   #:projection
-   (ho-projection proxy-hash)))
+   #:projection (ho-projection proxy-hash)))
--- a/collects/racket/contract/private/vector.rkt
+++ b/collects/racket/contract/private/vector.rkt
@ -22,35 +22,33 @@
                (list '#:immutable immutable)
                null)))))

-(define (vectorof-first-order c) 
+(define (check-vectorof c) 
  (let ([elem-ctc (vectorof-elem c)]
        [immutable (vectorof-immutable c)]
        [flat? (flat-vectorof? c)])
-    (λ (val #:blame [blame #f])
+    (λ (val fail [first-order? #f])
+      (unless (vector? val)
+        (fail "expected a vector, got ~a" val))
+      (cond
+        [(eq? immutable #t)
+         (unless (immutable? val)
+           (fail "expected an immutable vector, got ~a" val))]
+        [(eq? immutable #f)
+         (when (immutable? val)
+           (fail "expected an mutable vector, got ~a" val))]
+        [else (void)])
+      (when first-order?
+        (for ([e (in-vector val)]
+              [n (in-naturals)])
+          (unless (contract-first-order-passes? elem-ctc e)
+            (fail "expected <~s> for element ~v, got ~v" (contract-name elem-ctc) n e))))
+      #t)))
+
+(define (vectorof-first-order ctc)
+  (let ([check (check-vectorof ctc)])
+    (λ (val)
      (let/ec return
-        (define (fail . args)
-          (if blame
-              (apply raise-blame-error blame val args)
-              (return #f)))
-        (unless (vector? val)
-          (fail "expected a vector, got ~a" val))
-        (cond
-          [(eq? immutable #t)
-           (unless (immutable? val)
-             (fail "expected an immutable vector, got ~a" val))]
-          [(eq? immutable #f)
-           (when (immutable? val)
-             (fail "expected an mutable vector, got ~a" val))]
-          [else (void)])
-        (when (or flat? (and (immutable? val) (not blame)))
-          (if blame
-              (let ([elem-proj ((contract-projection elem-ctc) blame)])
-                (for ([e (in-vector val)])
-                  (elem-proj e)))
-              (for ([e (in-vector val)])
-                (unless (contract-first-order-passes? elem-ctc e)
-                  (fail)))))
-        #t))))
+        (check val (λ _ (return #f)) #t)))))

 (define-struct (flat-vectorof vectorof) ()
  #:property prop:flat-contract
@ -61,7 +59,11 @@
   (λ (ctc) 
     (λ (blame) 
       (λ (val)
-         ((vectorof-first-order ctc) val #:blame blame)
+         ((check-vectorof ctc) val (λ args (apply raise-blame-error blame val args)))
+         (let* ([elem-ctc (vectorof-elem ctc)]
+                [p ((contract-projection elem-ctc) blame)])
+           (for ([e (in-vector val)])
+             (p e)))
         val)))))

 (define (vectorof-ho-projection vector-wrapper)
@ -72,7 +74,7 @@
         (let ([elem-pos-proj ((contract-projection elem-ctc) blame)]
               [elem-neg-proj ((contract-projection elem-ctc) (blame-swap blame))])
           (λ (val)
-             ((vectorof-first-order ctc) val #:blame blame)
+             ((check-vectorof ctc) val (λ args (apply raise-blame-error blame val args)))
             (if (immutable? val)
                 (apply vector-immutable
                        (for/list ([e (in-vector val)])
@ -166,40 +168,38 @@
                (list '#:immutable immutable)
                null)))))

-(define (vector/c-first-order c) 
+(define (check-vector/c c) 
  (let ([elem-ctcs (vector/c-elems c)]
        [immutable (vector/c-immutable c)]
        [flat? (flat-vector/c? c)])
-    (λ (val #:blame [blame #f])
-      (let/ec return
-        (define (fail . args)
-          (if blame
-              (apply raise-blame-error blame val args)
-              (return #f)))
-        (unless (vector? val)
-          (fail "expected a vector, got ~a" val))
-        (cond
-          [(eq? immutable #t)
-           (unless (immutable? val)
-             (fail "expected an immutable vector, got ~a" val))]
-          [(eq? immutable #f)
-           (when (immutable? val)
-             (fail "expected an mutable vector, got ~a" val))]
-          [else (void)])
-        (let ([elem-count (length elem-ctcs)])
+    (λ (val fail [first-order? #f])
+      (unless (vector? val)
+        (fail "expected a vector, got ~a" val))
+      (cond
+        [(eq? immutable #t)
+         (unless (immutable? val)
+           (fail "expected an immutable vector, got ~a" val))]
+        [(eq? immutable #f)
+         (when (immutable? val)
+           (fail "expected an mutable vector, got ~a" val))]
+        [else (void)])
+      (let ([elem-count (length elem-ctcs)])
          (unless (= (vector-length val) elem-count)
            (fail "expected a vector of ~a element~a, got ~a"
                  elem-count (if (= elem-count 1) "" "s") val)))
-        (when (or flat? (and (immutable? val) (not blame)))
-          (if blame
-              (for ([e (in-vector val)]
-                    [c (in-list elem-ctcs)])
-                (((contract-projection c) blame) e))
-              (for ([e (in-vector val)]
-                    [c (in-list elem-ctcs)])
-                (unless (contract-first-order-passes? c e)
-                  (fail)))))
-        #t))))
+      (when first-order?
+        (for ([e (in-vector val)]
+              [n (in-naturals)]
+              [c (in-list elem-ctcs)])
+          (unless (contract-first-order-passes? c e)
+            (fail "expected <~s> for element ~v, got ~v" (contract-name c) n val))))
+      #t)))
+
+(define (vector/c-first-order ctc)
+  (let ([check (check-vector/c ctc)])
+    (λ (val)
+      (let/ec return
+        (check val (λ _ (return #f)) #t)))))

 (define-struct (flat-vector/c vector/c) ()
  #:property prop:flat-contract
@ -210,7 +210,10 @@
   (λ (ctc) 
     (λ (blame) 
       (λ (val)
-         ((vector/c-first-order ctc) val #:blame blame)
+         ((check-vector/c ctc) val (λ args (apply raise-blame-error blame val args)))
+         (for ([e (in-vector val)]
+               [c (in-list (vector/c-elems ctc))])
+           (((contract-projection c) blame) e))
         val)))))

 (define (vector/c-ho-projection vector-wrapper)
@ -223,7 +226,7 @@
               [elem-neg-projs (apply vector-immutable
                                      (map (λ (c) ((contract-projection c) (blame-swap blame))) elem-ctcs))])
           (λ (val)
-             ((vector/c-first-order ctc) val #:blame blame)
+             ((check-vector/c ctc) val (λ args (apply raise-blame-error blame val args)))
             (if (immutable? val)
                 (apply vector-immutable
                        (for/list ([e (in-vector val)]
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@ -9629,12 +9629,12 @@ so that propagation occurs.
  
  (ctest #t contract-first-order-passes? (hash/c any/c any/c) (make-hash))
  (ctest #f contract-first-order-passes? (hash/c any/c any/c) #f)
-  (ctest #t contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)])
+  (ctest #f contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)])
                                                                     (hash-set! ht 'x 1)
                                                                     ht))
  (ctest #f contract-first-order-passes? (hash/c symbol? boolean? #:flat? #t)
         (let ([ht (make-hash)]) (hash-set! ht 'x 1) ht))
-  (ctest #t contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)])
+  (ctest #f contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)])
                                                                     (hash-set! ht 1 #f)
                                                                     ht))
  (ctest #f contract-first-order-passes? (hash/c symbol? boolean? #:flat? #t)