From daf142c1c0336b529c0ef034fe3a9d0750ceaf47 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 3 Nov 2020 09:47:18 -0600
Subject: [PATCH] improve the error messages for flat hash/dc contracts

---
 .../tests/racket/contract/hash.rkt            | 47 +++++++++++++++++++
 .../collects/racket/contract/private/hash.rkt | 36 ++++++++++----
 2 files changed, 73 insertions(+), 10 deletions(-)

diff --git a/pkgs/racket-test/tests/racket/contract/hash.rkt b/pkgs/racket-test/tests/racket/contract/hash.rkt
index ab0415528c..b298b264e0 100644
--- a/pkgs/racket-test/tests/racket/contract/hash.rkt
+++ b/pkgs/racket-test/tests/racket/contract/hash.rkt
@@ -288,7 +288,54 @@
    '(contract (hash/dc [d integer?] [r (d) string?] #:immutable #t)
               (hash 3 "x")
               'pos 'neg))
+
+  (test/pos-blame
+   'hash/dc-flat1
+   '(contract (hash/dc [d integer?] [r (d) (if (even? d) string? symbol?)] #:kind 'flat)
+              1
+              'pos 'neg))
+  (test/pos-blame
+   'hash/dc-flat2
+   '(contract (hash/dc [d integer?] [r (d) (if (even? d) string? symbol?)] #:kind 'flat)
+              (hash #f #f)
+              'pos 'neg))
+
+  (test/pos-blame
+   'hash/dc-flat3
+   '(contract (hash/dc [d integer?] [r (d) (if (even? d) string? symbol?)] #:kind 'flat)
+              (hash 0 #f)
+              'pos 'neg))
   
+  (test/pos-blame
+   'hash/dc-flat4
+   '(contract (hash/dc [d integer?] [r (d) (if (even? d) string? symbol?)] #:kind 'flat)
+              (hash 1 "x")
+              'pos 'neg))
+  (test/pos-blame
+   'hash/dc-flat5
+   '(contract (hash/dc [d integer?] [r (d) (if (even? d) string? symbol?)] #:kind 'flat)
+              (hash 3 "x")
+              'pos 'neg))
+  (test/pos-blame
+   'hash/dc-flat6
+   '(contract (hash/dc [d integer?] [r (d) string?] #:immutable #f #:kind 'flat)
+              (hash 3 "x")
+              'pos 'neg))
+  (test/spec-passed
+   'hash/dc-flat7
+   '(contract (hash/dc [d integer?] [r (d) string?] #:immutable #t #:kind 'flat)
+              (hash 3 "x")
+              'pos 'neg))
+  (test/spec-passed/result
+   'hash/dc-flat8
+   '(regexp-match?
+     #rx"\n *in: the values of\n"
+     (with-handlers ([exn:fail? exn-message])
+       (contract (hash/dc [d integer?] [r (d) string?] #:immutable #t #:kind 'flat)
+                 (hash 3 'not-a-string)
+                 'pos 'neg)))
+   #t)
+
   (test/no-error
    '(let ([v (chaperone-hash (make-immutable-hash (list (cons 1 2)))
                              (λ (hash k) (values k (λ (h k v) v)))
diff --git a/racket/collects/racket/contract/private/hash.rkt b/racket/collects/racket/contract/private/hash.rkt
index 6cdb96e8db..687d67953d 100644
--- a/racket/collects/racket/contract/private/hash.rkt
+++ b/racket/collects/racket/contract/private/hash.rkt
@@ -423,17 +423,32 @@
                                                    (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
+    (cond
+      [chaperone-or-impersonate-hash
+       (λ (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-late-neg-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)]))]
+      [else
+       (λ (val neg-party)
+         (check-hash/c dom-ctc immutable flat? val blame neg-party)
          (define ((mk-rng-proj x-value-blame) key)
            ((get/build-late-neg-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)]))))
+         (define mk-pos-rng-proj (mk-rng-proj pos-value-blame))
+         (define mk-neg-rng-proj (mk-rng-proj neg-value-blame))
+         (with-contract-continuation-mark (cons blame neg-party)
+           (for ([(k v) (in-hash val)])
+             (pos-dom-proj k neg-party)
+             ((mk-pos-rng-proj k) v neg-party)))
+         val)])))
         
 (struct base-hash/dc (dom dep-rng here name-info immutable))
 (struct flat-hash/dc base-hash/dc ()
@@ -444,7 +459,8 @@
    #:name hash/dc-name
    #:first-order hash/dc-first-order
    #:equivalent hash/dc-equivalent
-   #:stronger hash/dc-stronger))
+   #:stronger hash/dc-stronger
+   #:late-neg-projection (hash/dc-late-neg-projection #f)))
 
 (struct chaperone-hash/dc base-hash/dc ()
   #:property prop:custom-write custom-write-property-proc
@@ -522,7 +538,7 @@
               (loop #'more))]
            [(x . y)
             (raise-syntax-error 'hash/dc
-                                "expected either the keyword #:flat? or #:immutable"
+                                "expected either the keyword #:kind or #:immutable"
                                 stx
                                 #'x)]))
        #`(build-hash/dc dom-ctc-expr