From 005d3b7218da6984b103b1ddd1a3ab7ff892903f Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Mon, 14 May 2012 21:43:28 -0500
Subject: [PATCH] add context information to hash/c (also, rackety)

---
 collects/racket/contract/private/hash.rkt | 74 ++++++++++++-----------
 collects/tests/racket/contract-test.rktl  | 17 ++++++
 2 files changed, 55 insertions(+), 36 deletions(-)

diff --git a/collects/racket/contract/private/hash.rkt b/collects/racket/contract/private/hash.rkt
index 9d84e00a67..a7f4f4a643 100644
--- a/collects/racket/contract/private/hash.rkt
+++ b/collects/racket/contract/private/hash.rkt
@@ -139,7 +139,7 @@
 
 (define-struct (flat-hash/c base-hash/c) ()
   #:omit-define-syntaxes
-
+  
   #:property prop:flat-contract
   (build-flat-contract-property
    #:name hash/c-name
@@ -149,11 +149,13 @@
      (λ (blame)
        (λ (val)
          (check-hash/c ctc val blame)
-         (let ([dom-proj ((contract-projection (base-hash/c-dom ctc)) blame)]
-               [rng-proj ((contract-projection (base-hash/c-rng ctc)) blame)])
-           (for ([(k v) (in-hash val)])
-             (dom-proj k)
-             (rng-proj v)))
+         (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)))))
 
 (define (ho-projection hash-wrapper)
@@ -162,36 +164,36 @@
           [rng-proc (contract-projection (base-hash/c-rng ctc))]
           [immutable (base-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)
-            (check-hash/c ctc val 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))
-                 impersonator-prop:contracted ctc))))))))
+        (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 (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))
+               impersonator-prop:contracted ctc)))))))
 
 (define-struct (chaperone-hash/c base-hash/c) ()
   #:omit-define-syntaxes
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index 6fb6d4f589..6493a6bbf1 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -12724,6 +12724,23 @@ so that propagation occurs.
                                      'neg)
                            0)))
   
+  (ctest '("the keys of")
+         extract-context-lines
+         (λ () (contract (hash/c integer? (-> integer? integer?))
+                         (hash #f (λ (x) #f))
+                         'pos
+                         'neg)))
+  
+  (ctest '("the range of" "the values of")
+         extract-context-lines
+         (λ () ((hash-ref
+                 (contract (hash/c integer? (-> integer? integer?))
+                           (hash 0 (λ (x) #f))
+                           'pos
+                           'neg)
+                 0)
+                1)))
+  
 ;                                                        
 ;                                                        
 ;