Add chaperone-based hash/c contracts.

* Domain contracts must be either flat or chaperone contracts.
 * When the domain is a chaperone contract, hash/c must check
   that the hash is equal?-based.

collects/racket/contract/private/hash.rkt

@@ -13,12 +13,18 @@
         [rng-ctc (if flat?
                      (coerce-flat-contract 'hash/c rng)
                      (coerce-contract 'hash/c rng))])
-    (if (or flat?
+    (unless (chaperone-contract? dom-ctc)
-            (and (eq? immutable #t)
+      (error 'hash/c "expected either a flat or chaperone contract for the domain, got ~s" (contract-name dom-ctc)))
-                 (flat-contract? dom-ctc)
+    (cond
-                 (flat-contract? rng-ctc)))
+      [(or flat?
-        (make-flat-hash/c dom-ctc rng-ctc immutable)
+           (and (eq? immutable #t)
-        (make-ho-hash/c dom-ctc rng-ctc immutable))))
+                (flat-contract? dom-ctc)
+                (flat-contract? rng-ctc)))
+       (make-flat-hash/c dom-ctc rng-ctc immutable)]
+      [(chaperone-contract? rng-ctc)
+       (make-chaperone-hash/c dom-ctc rng-ctc immutable)]
+      [else
+       (make-proxy-hash/c dom-ctc rng-ctc immutable)])))
 
 (define (hash/c-first-order ctc) 
   (let ([dom-ctc (hash/c-dom ctc)]
@@ -33,6 +39,10 @@
               (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) 
@@ -85,7 +95,55 @@
          ((hash/c-first-order ctc) val #:blame blame)
          val)))))
 
-(define-struct (ho-hash/c hash/c) ()
+(define (ho-projection hash-wrapper)
+  (λ (ctc)
+    (let ([dom-proc (contract-projection (hash/c-dom ctc))]
+          [rng-proc (contract-projection (hash/c-rng ctc))]
+          [immutable (hash/c-immutable ctc)])
+      (λ (blame)
+        (let ([pos-dom-proj (dom-proc blame)]
+              [neg-dom-proj (dom-proc (blame-swap blame))]
+              [pos-rng-proj (rng-proc blame)]
+              [neg-rng-proj (rng-proc (blame-swap blame))])
+          (λ (val)
+            ((hash/c-first-order ctc) val #:blame blame)
+            
+            (if (immutable? val)
+                (let ([hash-maker
+                       (cond
+                         [(hash-equal? val) make-immutable-hash]
+                         [(hash-eqv? val) make-immutable-hasheqv]
+                         [(hash-eq? val) make-immutable-hasheq])])
+                  (hash-maker
+                   (for/list ([(k v) (in-hash val)])
+                     (cons (pos-dom-proj k)
+                           (pos-rng-proj v)))))
+                (hash-wrapper
+                 val
+                 (λ (h k)
+                   (values (neg-dom-proj k)
+                           (λ (h k v)
+                             (pos-rng-proj v))))
+                 (λ (h k v)
+                   (values (neg-dom-proj k)
+                           (neg-rng-proj v)))
+                 (λ (h k)
+                   (neg-dom-proj k))
+                 (λ (h k)
+                   (pos-dom-proj k))))))))))
+
+(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)))
+
+(define-struct (proxy-hash/c hash/c) ()
   #:omit-define-syntaxes
 
   #:property prop:contract
@@ -94,38 +152,4 @@
    #:first-order hash/c-first-order
    
    #:projection
-   (λ (ctc)
+   (ho-projection proxy-hash)))
-      (let ([dom-proc (contract-projection (hash/c-dom ctc))]
-            [rng-proc (contract-projection (hash/c-rng ctc))]
-            [immutable (hash/c-immutable ctc)])
-        (λ (blame)
-           (let ([pos-dom-proj (dom-proc blame)]
-                 [neg-dom-proj (dom-proc (blame-swap blame))]
-                 [pos-rng-proj (rng-proc blame)]
-                 [neg-rng-proj (rng-proc (blame-swap blame))])
-             (λ (val)
-               ((hash/c-first-order ctc) val #:blame blame)
-               
-               (if (immutable? val)
-                   (let ([hash-maker
-                          (cond
-                            [(hash-equal? val) make-immutable-hash]
-                            [(hash-eqv? val) make-immutable-hasheqv]
-                            [(hash-eq? val) make-immutable-hasheq])])
-                     (hash-maker
-                      (for/list ([(k v) (in-hash val)])
-                        (cons (pos-dom-proj k)
-                              (pos-rng-proj v)))))
-                   (proxy-hash
-                    val
-                    (λ (h k)
-                      (values (neg-dom-proj k)
-                              (λ (h k v)
-                                (pos-rng-proj v))))
-                    (λ (h k v)
-                      (values (neg-dom-proj k)
-                              (neg-rng-proj v)))
-                    (λ (h k)
-                      (neg-dom-proj k))
-                    (λ (h k)
-                      (pos-dom-proj k)))))))))))

collects/tests/racket/contract-test.rktl

@@ -3665,6 +3665,31 @@
                         'neg)
               'x)
    1)
+  
+  (test/pos-blame
+   'hash/c13a
+   '(contract (hash/c (hash/c number? number?) number?)
+              (make-hasheq)
+              'pos
+              'neg))
+
+  (test/pos-blame
+   'hash/c13b
+   '(contract (hash/c (hash/c number? number?) number?)
+              (make-hasheq)
+              'pos
+              'neg))
+  
+  (test/neg-blame
+   'hash/c13c
+   '(let ([h (contract (hash/c (hash/c number? number?) number?)
+                       (make-hash)
+                       'pos
+                       'neg)])
+      (hash-set! h (make-hash '((2 . 3))) 2)
+      (hash-set! h (make-hash '((3 . #t))) 3)
+      (for ([(k v) (in-hash h)])
+        (hash-ref k v))))
 
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;
@@ -8821,23 +8846,45 @@ so that propagation occurs.
                             (define-struct s (a b))
                             (struct/c s any/c any/c)))
   
-  (ctest #t contract?      (hash/c any/c any/c #:immutable #f))
+  ;; Hash contracts with flat domain/range contracts
-  (ctest #t flat-contract? (hash/c any/c any/c #:immutable #f #:flat? #t))
+  (ctest #t contract?           (hash/c any/c any/c #:immutable #f))
+  (ctest #t chaperone-contract? (hash/c any/c any/c #:immutable #f))
+  (ctest #t flat-contract?      (hash/c any/c any/c #:immutable #f #:flat? #t))
 
-  (ctest #t flat-contract? (hash/c any/c any/c #:immutable #t))
+  (ctest #t flat-contract?      (hash/c any/c any/c #:immutable #t))
-  (ctest #t flat-contract? (hash/c any/c any/c #:immutable #t #:flat? #t))
+  (ctest #t flat-contract?      (hash/c any/c any/c #:immutable #t #:flat? #t))
 
-  (ctest #t contract?      (hash/c any/c any/c))
+  (ctest #t contract?           (hash/c any/c any/c))
-  (ctest #t flat-contract? (hash/c any/c any/c #:flat? #t))
+  (ctest #t chaperone-contract? (hash/c any/c any/c))
+  (ctest #t flat-contract?      (hash/c any/c any/c #:flat? #t))
   
-  (ctest #t contract?      (hash/c number? (-> number? number?) #:immutable #f))
+  ;; Hash contracts with chaperone range contracts
-  (ctest #f flat-contract? (hash/c number? (-> number? number?) #:immutable #f))
+  (ctest #t contract?           (hash/c number? (hash/c number? number?)))
-
+  (ctest #t chaperone-contract? (hash/c number? (hash/c number? number?)))
-  (ctest #t contract?      (hash/c number? (-> number? number?) #:immutable #t))
+  (ctest #f flat-contract?      (hash/c number? (hash/c number? number?)))
-  (ctest #f flat-contract? (hash/c number? (-> number? number?) #:immutable #t))
   
-  (ctest #t contract?      (hash/c number? (-> number? number?)))
+  ;; Hash contracts with proxy range contracts
-  (ctest #f flat-contract? (hash/c number? (-> number? number?)))
+  (ctest #t contract?           (hash/c number? (-> number? number?) #:immutable #f))
+  (ctest #f chaperone-contract? (hash/c number? (-> number? number?) #:immutable #f))
+  (ctest #f flat-contract?      (hash/c number? (-> number? number?) #:immutable #f))
+
+  (ctest #t contract?           (hash/c number? (-> number? number?) #:immutable #t))
+  (ctest #f chaperone-contract? (hash/c number? (-> number? number?) #:immutable #t))
+  (ctest #f flat-contract?      (hash/c number? (-> number? number?) #:immutable #t))
+  
+  (ctest #t contract?           (hash/c number? (-> number? number?)))
+  (ctest #f chaperone-contract? (hash/c number? (-> number? number?)))
+  (ctest #f flat-contract?      (hash/c number? (-> number? number?)))
+  
+  ;; Make sure that proxies cannot be used as the domain contract in hash/c.
+  (contract-error-test
+   '(let ([proxy-ctc
+           (make-contract
+            #:name 'proxy-ctc
+            #:first-order values
+            #:higher-order (λ (b) values))])
+      (hash/c proxy-ctc proxy-ctc))
+   exn:fail?)
 
   (ctest #t contract? 1)
   (ctest #t contract? (-> 1 1))