added hash/dc

pkgs/racket-doc/scribblings/reference/contracts.scrbl

@@ -696,6 +696,40 @@ and either a @tech{chaperone} or @tech{impersonator} of the original hash table
 for mutable hash tables.
 }]}
 
+@defform[(hash/dc [key-id key-contract-expr] [value-id (key-id) value-contract-expr]
+                  hash/dc-option)
+         #:grammar ([hash/dc-option (code:line)
+                                    (code:line #:immutable immutable?-expr hash/dc-option)
+                                    (code:line #:kind kind-expr hash/dc-option)])]{
+ Creates a contract for @racket[hash?] tables with keys matching @racket[key-contract-expr]
+ and where the contract on the values can depend on the key itself, since
+ @racket[key-id] will be bound to the corresponding key before evaluating
+ the @racket[values-contract-expr].
+ 
+ If @racket[immutable?-expr] is @racket[#t], then only @racket[immutable?] hashes
+ are accepted. If it is @racket[#f] then @racket[immutable?] hashes are always
+ rejected. It defaults to @racket['dont-care], in which case both mutable and
+ immutable hashes are accepted.
+ 
+ If @racket[kind-expr] evaluates to @racket['flat], then @racket[key-contract-expr]
+ and @racket[value-contract-expr] are expected to evaluate to @racket[flat-contract?]s.
+ If it is @racket['chaperone], then they are expected to be @racket[chaperone-contract?]s,
+ and it may also be @racket['impersonator], in which case they may be any @racket[contract?]s.
+ The default is @racket['chaperone].
+ 
+ @examples[#:eval
+            (contract-eval)
+            (define/contract h
+              (hash/dc [k real?] [v (k) (>=/c k)])
+              (hash 1 3
+                    2 4))
+            (define/contract h
+              (hash/dc [k real?] [v (k) (>=/c k)])
+              (hash 3 1
+                    4 2))]
+ 
+ 
+}
 
 @defproc[(channel/c [val contract?])
           contract?]{

pkgs/racket-test/tests/racket/contract/hash.rkt

@@ -191,7 +191,43 @@
       (for ([(k v) (in-hash h)])
         (hash-ref k v))))
   
+  (test/pos-blame
+   'hash/dc1
+   '(contract (hash/dc [d integer?] [r (d) (if (even? d) string? symbol?)])
+              1
+              'pos 'neg))
+  (test/pos-blame
+   'hash/dc2
+   '(contract (hash/dc [d integer?] [r (d) (if (even? d) string? symbol?)])
+              (hash #f #f)
+              'pos 'neg))
   
+  (test/pos-blame
+   'hash/dc3
+   '(contract (hash/dc [d integer?] [r (d) (if (even? d) string? symbol?)])
+              (hash 0 #f)
+              'pos 'neg))
+  
+  (test/pos-blame
+   'hash/dc4
+   '(contract (hash/dc [d integer?] [r (d) (if (even? d) string? symbol?)])
+              (hash 1 "x")
+              'pos 'neg))
+  (test/pos-blame
+   'hash/dc5
+   '(contract (hash/dc [d integer?] [r (d) (if (even? d) string? symbol?)])
+              (hash 3 "x")
+              'pos 'neg)) 
+  (test/pos-blame
+   'hash/dc6
+   '(contract (hash/dc [d integer?] [r (d) string?] #:immutable #f)
+              (hash 3 "x")
+              'pos 'neg))
+  (test/spec-passed
+   'hash/dc7
+   '(contract (hash/dc [d integer?] [r (d) string?] #:immutable #t)
+              (hash 3 "x")
+              'pos 'neg))
   
   (test/no-error
    '(let ([v (chaperone-hash (make-immutable-hash (list (cons 1 2)))
@@ -215,4 +251,4 @@
                              (λ (hash k v) (values k v))
                              (λ (hash k) k)
                              (λ (hash k) k))])
-      (contract (hash/c any/c any/c) v 'pos 'neg))))
+      (contract (hash/c any/c any/c) v 'pos 'neg))))

pkgs/racket-test/tests/racket/contract/name.rkt

@@ -260,7 +260,11 @@
   (test-name '(hash/c symbol? boolean? #:immutable #t) (hash/c symbol? boolean? #:immutable #t))
   (test-name '(hash/c symbol? boolean? #:immutable #f) (hash/c symbol? boolean? #:immutable #f))
   (test-name '(hash/c symbol? boolean?) (hash/c symbol? boolean? #:immutable 'dont-care))
-
+  (test-name '(hash/dc [k symbol?] [v (k) boolean?]) 
+             (hash/dc [k symbol?] [v (k) boolean?]))
+  (test-name '(hash/dc [k symbol?] [v (k) boolean?] #:immutable #t #:kind 'flat) 
+             (hash/dc [k symbol?] [v (k) boolean?]  #:immutable #t #:kind 'flat))
+  
   (test-name '(box/c boolean?) (box/c boolean?))
   (test-name '(box/c boolean?) (box/c (flat-contract boolean?)))
   (test-name 'the-name (flat-rec-contract the-name))

racket/collects/racket/contract/private/hash.rkt

@@ -1,12 +1,14 @@
 #lang racket/base
 
-(require (for-syntax racket/base)
+(require (for-syntax racket/base "arr-util.rkt")
+         syntax/location
          "guts.rkt"
          "blame.rkt"
          "prop.rkt"
          "misc.rkt")
 
-(provide (rename-out [wrap-hash/c hash/c]))
+(provide (rename-out [wrap-hash/c hash/c])
+         hash/dc)
 
 (define-syntax (wrap-hash/c stx)
   (syntax-case stx ()
@@ -76,30 +78,48 @@
     [else
      (make-impersonator-hash/c dom-ctc rng-ctc immutable)]))
 
-(define (check-hash/c ctc val blame) 
-  (define dom-ctc (base-hash/c-dom ctc))
-  (define rng-ctc (base-hash/c-rng ctc))
-  (define immutable (base-hash/c-immutable ctc))
-  (define flat? (flat-hash/c? ctc))
-  (unless (hash? val)
-    (raise-blame-error blame val '(expected "a hash" given: "~e") val))
-  (when (and (not flat?)
+
+;; ... --> boolean
+;;  returns #t when it called raise-blame-error, #f otherwise
+(define (check-hash/c dom-ctc immutable flat? val blame neg-party) 
+  ;(define dom-ctc (base-hash/c-dom ctc))
+  ;(define immutable (base-hash/c-immutable ctc))
+  ;(define flat? (flat-hash/c? ctc))
+  (cond
+    [(hash? val)
+     (cond
+       [(and (not flat?)
              (not (flat-contract? dom-ctc))
              (not (hash-equal? val)))
-    (raise-blame-error
-     blame val
-     '(expected "equal?-based hash table due to higher-order domain contract" given: "~e")
-     val))
-  (case immutable
-    [(#t) 
-     (unless (immutable? val) 
-       (raise-blame-error blame val
-                          '(expected "an immutable hash" given: "~e") val))]
-    [(#f)
-     (when (immutable? val)
-       (raise-blame-error blame val
-                          '(expected "a mutable hash" given: "~e") val))]
-    [(dont-care) (void)]))
+        (raise-blame-error
+         blame val #:missing-party neg-party
+         '(expected "equal?-based hash table due to higher-order domain contract" given: "~e")
+         val)
+        #t]
+       [else
+        (case immutable
+          [(#t) 
+           (cond
+             [(immutable? val) 
+              #f]
+             [else
+              (raise-blame-error 
+               blame val #:missing-party neg-party
+               '(expected "an immutable hash" given: "~e") val)
+              #t])]
+          [(#f)
+           (cond
+             [(immutable? val)
+              (raise-blame-error 
+               blame val #:missing-party neg-party
+               '(expected "a mutable hash" given: "~e") val)
+              #t]
+             [else #f])]
+          [(dont-care) #f])])]
+    [else 
+     (raise-blame-error blame val #:missing-party neg-party
+                        '(expected "a hash" given: "~e") val)
+     #t]))
 
 (define (hash/c-first-order ctc)
   (define dom-ctc (base-hash/c-dom ctc))
@@ -168,57 +188,80 @@
    #:name hash/c-name
    #:first-order hash/c-first-order
    #:stronger hash/c-stronger
-   #:projection
+   #:val-first-projection
    (λ (ctc)
+     (define dom-ctc (base-hash/c-dom ctc))
+     (define immutable (base-hash/c-immutable ctc))
+     (define flat? (flat-hash/c? ctc))
      (λ (blame)
+       (define dom-proj ((contract-projection (base-hash/c-dom ctc))
+                         (blame-add-key-context blame #f)))
+       (define rng-proj ((contract-projection (base-hash/c-rng ctc))
+                         (blame-add-value-context blame #f)))
        (λ (val)
-         (check-hash/c ctc val blame)
-         (define dom-proj ((contract-projection (base-hash/c-dom ctc)) 
-                           (blame-add-context blame "the keys of")))
-         (define rng-proj ((contract-projection (base-hash/c-rng ctc))
-                           (blame-add-context blame "the values of")))
-         (for ([(k v) (in-hash val)])
-           (dom-proj k)
-           (rng-proj v))
-         val)))))
+         (λ (neg-party)
+           (cond
+             [(check-hash/c dom-ctc immutable flat? val blame neg-party)
+              val]
+             [else
+              (for ([(k v) (in-hash val)])
+                (dom-proj k)
+                (rng-proj v))
+              val])))))))
 
-(define (ho-projection hash-wrapper)
+(define (ho-projection chaperone-or-impersonate-hash)
   (λ (ctc)
-    (let ([dom-proc (contract-projection (base-hash/c-dom ctc))]
-          [rng-proc (contract-projection (base-hash/c-rng ctc))]
-          [immutable (base-hash/c-immutable ctc)])
-      (λ (blame)
-        (define pos-dom-proj (dom-proc (blame-add-context blame "the keys of")))
-        (define neg-dom-proj (dom-proc (blame-add-context blame "the keys of" #:swap? #t)))
-        (define pos-rng-proj (rng-proc (blame-add-context blame "the values of")))
-        (define neg-rng-proj (rng-proc (blame-add-context blame "the values of" #:swap? #t)))
-        (λ (val)
-          (check-hash/c ctc val blame)
-          (if (and (immutable? val) (not (chaperone? 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))
-               impersonator-prop:contracted ctc
-               impersonator-prop:blame blame)))))))
+    (define immutable (base-hash/c-immutable ctc))
+    (define dom-ctc (base-hash/c-dom ctc))
+    (define flat? (flat-hash/c? ctc))
+    (define dom-proc (get/build-val-first-projection dom-ctc))
+    (define rng-proc (get/build-val-first-projection (base-hash/c-rng ctc)))
+    (λ (blame)
+      (define pos-dom-proj (dom-proc (blame-add-key-context blame #f)))
+      (define neg-dom-proj (dom-proc (blame-add-key-context blame #t)))
+      (define pos-rng-proj (rng-proc (blame-add-value-context blame #f)))
+      (define neg-rng-proj (rng-proc (blame-add-value-context blame #t)))
+      (λ (val)
+        (λ (neg-party)
+          (cond
+            [(check-hash/c dom-ctc immutable flat? val blame neg-party)
+             val]
+            [else
+             (handle-the-hash val neg-party
+                              pos-dom-proj neg-dom-proj (λ (v) pos-rng-proj) (λ (v) neg-rng-proj)
+                              chaperone-or-impersonate-hash ctc blame)]))))))
+
+(define (blame-add-key-context blame swap?) (blame-add-context blame "the keys of" #:swap? swap?))
+(define (blame-add-value-context blame swap?) (blame-add-context blame "the values of" #:swap? swap?))
+
+(define (handle-the-hash val neg-party
+                         pos-dom-proj neg-dom-proj mk-pos-rng-proj mk-neg-rng-proj
+                         chaperone-or-impersonate-hash ctc blame)
+  (if (and (immutable? val) (not (chaperone? 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) neg-party)
+                 (((mk-pos-rng-proj k) v) neg-party)))))
+      (chaperone-or-impersonate-hash
+       val
+       (λ (h k)
+         (values ((neg-dom-proj k) neg-party)
+                 (λ (h k v)
+                   (((mk-pos-rng-proj k) v) neg-party))))
+       (λ (h k v)
+         (values ((neg-dom-proj k) neg-party)
+                 (((mk-neg-rng-proj k) v) neg-party)))
+       (λ (h k)
+         ((neg-dom-proj k) neg-party))
+       (λ (h k)
+         ((pos-dom-proj k) neg-party))
+       impersonator-prop:contracted ctc
+       impersonator-prop:blame blame)))
 
 (define-struct (chaperone-hash/c base-hash/c) ()
   #:omit-define-syntaxes
@@ -228,7 +271,7 @@
    #:name hash/c-name
    #:first-order hash/c-first-order
    #:stronger hash/c-stronger
-   #:projection (ho-projection chaperone-hash)))
+   #:val-first-projection (ho-projection chaperone-hash)))
 
 (define-struct (impersonator-hash/c base-hash/c) ()
   #:omit-define-syntaxes
@@ -238,4 +281,149 @@
    #:name hash/c-name
    #:first-order hash/c-first-order
    #:stronger hash/c-stronger
-   #:projection (ho-projection impersonate-hash)))
+   #:val-first-projection (ho-projection impersonate-hash)))
+
+
+(define (hash/dc-name a-hash-dc)
+  (define info (base-hash/dc-name-info a-hash-dc))
+  (define immutable (base-hash/dc-immutable a-hash-dc))
+  `(hash/dc [,(vector-ref info 0) ,(contract-name (base-hash/dc-dom a-hash-dc))]
+            [,(vector-ref info 1) (,(vector-ref info 0)) ,(vector-ref info 2)]
+            ,@(if (equal? immutable 'dont-care)
+                  '()
+                  `(#:immutable ,immutable))
+            ,@(cond
+                [(flat-hash/dc? a-hash-dc)
+                 '(#:kind 'flat)]
+                [(chaperone-hash/dc? a-hash-dc)
+                 '()]
+                [else '(#:kind 'impersonator)])))
+
+(define (hash/dc-first-order a-hash-dc)
+  (define dom (base-hash/dc-dom a-hash-dc))
+  (define rng-f (base-hash/dc-dep-rng a-hash-dc))
+  (λ (val)
+    (and (hash? val)
+         (for/and ([(k v) (in-hash val)])
+           (and (contract-first-order-passes? dom k)
+                (contract-first-order-passes? (rng-f k) v))))))
+
+(define (hash/dc-stronger this that) #f)
+
+(define ((hash/dc-val-first-projection chaperone-or-impersonate-hash) ctc)
+  (define dom-ctc (base-hash/dc-dom ctc))
+  (define immutable (base-hash/dc-immutable ctc))
+  (define flat? (flat-hash/dc? ctc))
+  (define dom-proc (get/build-val-first-projection dom-ctc))
+  (define dep-rng-proc (base-hash/dc-dep-rng ctc))
+  (λ (blame)
+    (define pos-dom-proj (dom-proc (blame-add-key-context blame #f)))
+    (define neg-dom-proj (dom-proc (blame-add-key-context blame #t)))
+    (define indy-dom-proj (dom-proc 
+                           (blame-replace-negative (blame-add-key-context blame #f)
+                                                   (base-hash/dc-here ctc))))
+    (define pos-value-blame (blame-add-value-context blame #f))
+    (define neg-value-blame (blame-add-value-context blame #t))
+    (λ (val)
+      (λ (neg-party)
+        (cond
+          [(check-hash/c dom-ctc immutable flat? val blame neg-party) val]
+          [else
+           (define ((mk-rng-proj x-value-blame) key)
+             ((get/build-val-first-projection (dep-rng-proc ((indy-dom-proj key) neg-party)))
+              x-value-blame))
+           (handle-the-hash val neg-party
+                            pos-dom-proj neg-dom-proj 
+                            (mk-rng-proj pos-value-blame) (mk-rng-proj neg-value-blame)
+                            chaperone-or-impersonate-hash ctc blame)])))))
+        
+(struct base-hash/dc (dom dep-rng here name-info immutable))
+(struct flat-hash/dc base-hash/dc ()
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:name hash/dc-name
+   #:first-order hash/dc-first-order
+   #:stronger hash/dc-stronger))
+
+(struct chaperone-hash/dc base-hash/dc ()
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:chaperone-contract
+  (build-chaperone-contract-property
+   #:name hash/dc-name
+   #:first-order hash/dc-first-order
+   #:stronger hash/dc-stronger
+   #:val-first-projection (hash/dc-val-first-projection chaperone-hash)))
+(struct impersonator-hash/dc base-hash/dc ()
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:contract
+  (build-contract-property
+   #:name hash/dc-name
+   #:first-order hash/dc-first-order
+   #:stronger hash/dc-stronger
+   #:val-first-projection (hash/dc-val-first-projection impersonate-hash)))
+
+(define (build-hash/dc dom dep-rng here name-info immutable kind)
+  (unless (member kind '(flat chaperone impersonator))
+    (error 'hash/dc 
+           "expected (or/c 'flat 'chaperone 'impersonator) for the #:kind argument, got ~s"
+           kind))
+  (cond
+    [(equal? kind 'flat) 
+     (flat-hash/dc (coerce-flat-contract 'hash/dc dom)
+                   (λ (v) (coerce-flat-contract 'hash/dc (dep-rng v)))
+                   here name-info immutable)]
+    [(equal? kind 'chaperone)
+     (chaperone-hash/dc (coerce-chaperone-contract 'hash/dc dom)
+                        (λ (v) (coerce-chaperone-contract 'hash/dc (dep-rng v)))
+                        here name-info immutable)]
+    [else
+     (chaperone-hash/dc (coerce-contract 'hash/dc dom)
+                        (λ (v) (coerce-contract 'hash/dc (dep-rng v)))
+                        here name-info immutable)]))
+
+(define-syntax (hash/dc stx)
+  (syntax-case stx ()
+    [(_ [dom-id dom-ctc-expr] [rng-id (dom-id2) rng-ctc-expr] . more)
+     (begin
+       (unless (free-identifier=? #'dom-id2 #'dom-id)
+         (raise-syntax-error
+          'hash/dc
+          "expected the same identifier for the domain and the dependency"
+          stx
+          #'dom-id
+          (list #'dom-id2)))
+       (define immutable-expression #f)
+       (define kind-expression #f)
+       (let loop ([kwd-stx #'more])
+         (syntax-case kwd-stx ()
+           [() (void)]
+           [(#:immutable immutable . more)
+            (begin
+              (when immutable-expression
+                (raise-syntax-error 'hash/dc "multiple #:immutable arguments"
+                                    stx
+                                    immutable-expression
+                                    (list #'immutable)))
+              (set! immutable-expression #'immutable)
+              (loop #'more))]
+           [(#:kind kind . more)
+            (begin
+              (when kind-expression
+                (raise-syntax-error 'hash/dc "multiple #:kind arguments"
+                                    stx
+                                    kind-expression
+                                    (list #'kind)))
+              (set! kind-expression #'kind)
+              (loop #'more))]
+           [(x . y)
+            (raise-syntax-error 'hash/dc
+                                "expected either the keyword #:flat? or #:immutable"
+                                stx
+                                #'x)]))
+       #`(build-hash/dc dom-ctc-expr
+                        (λ (dom-id2) rng-ctc-expr)
+                        (quote-module-name)
+                        '#(dom-id rng-id #,(compute-quoted-src-expression #'rng-ctc-expr))
+                        #,(or immutable-expression #''dont-care)
+                        #,(or kind-expression #''chaperone)))]))