From a9c0c8bccd2259daf637c45bccb8cf27e6a4afa4 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 25 Sep 2014 14:26:02 -0500
Subject: [PATCH] add hash/c stronger

also, bring down below 102 columns
---
 .../tests/racket/contract/stronger.rkt        | 16 +++++++++
 .../collects/racket/contract/private/hash.rkt | 33 +++++++++++++++++--
 2 files changed, 46 insertions(+), 3 deletions(-)

diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
index 141660f596..139c2e400b 100644
--- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
@@ -193,6 +193,22 @@
   (ctest #f contract-stronger? (box/c (<=/c 3)) (box/c (<=/c 3) #:immutable #t))
   (ctest #f contract-stronger? (box/c (<=/c 3)) (box/c (<=/c 3) #:immutable #f))
   
+  (ctest #t contract-stronger? (hash/c integer? symbol?) (hash/c integer? symbol?))
+  (ctest #f contract-stronger? (hash/c integer? symbol?) (hash/c symbol? integer?))
+  (ctest #f contract-stronger? (hash/c (<=/c 2) symbol?) (hash/c (<=/c 3) symbol?))
+  (ctest #t contract-stronger?
+         (hash/c (<=/c 2) symbol? #:immutable #t)
+         (hash/c (<=/c 3) symbol? #:immutable #t))
+  (ctest #f contract-stronger?
+         (hash/c (<=/c 3) symbol? #:immutable #t)
+         (hash/c (<=/c 2) symbol? #:immutable #t))
+  (ctest #t contract-stronger?
+         (hash/c (<=/c 2) symbol? #:immutable #f)
+         (hash/c (<=/c 2) symbol?))
+  (ctest #f contract-stronger?
+         (hash/c (<=/c 2) symbol?)
+         (hash/c (<=/c 2) symbol? #:immutable #f))
+  
   (contract-eval
    `(let ()
       (define x (flat-rec-contract x (or/c (cons/c x '()) '())))
diff --git a/racket/collects/racket/contract/private/hash.rkt b/racket/collects/racket/contract/private/hash.rkt
index a5b3a53502..5c4291d89b 100644
--- a/racket/collects/racket/contract/private/hash.rkt
+++ b/racket/collects/racket/contract/private/hash.rkt
@@ -86,9 +86,10 @@
   (when (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))
+    (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) 
@@ -136,6 +137,29 @@
 
 (define-struct base-hash/c (dom rng immutable))
 
+(define (hash/c-stronger this that)
+  (define this-dom (base-hash/c-dom this))
+  (define this-rng (base-hash/c-rng this))
+  (define this-immutable (base-hash/c-immutable this))
+  (cond
+    [(base-hash/c? that)
+     (define that-dom (base-hash/c-dom that))
+     (define that-rng (base-hash/c-rng that))
+     (define that-immutable (base-hash/c-immutable that))
+     (cond
+       [(and (equal? this-immutable #t)
+             (equal? that-immutable #t))
+        (and (contract-stronger? this-dom that-dom)
+             (contract-stronger? this-rng that-rng))]
+       [(or (equal? that-immutable 'dont-care)
+            (equal? this-immutable that-immutable))
+        (and (contract-stronger? this-dom that-dom)
+             (contract-stronger? that-dom this-dom)
+             (contract-stronger? this-rng that-rng)
+             (contract-stronger? that-rng this-rng))]
+       [else #f])]
+    [else #f]))
+
 (define-struct (flat-hash/c base-hash/c) ()
   #:omit-define-syntaxes
   #:property prop:custom-write custom-write-property-proc
@@ -143,6 +167,7 @@
   (build-flat-contract-property
    #:name hash/c-name
    #:first-order hash/c-first-order
+   #:stronger hash/c-stronger
    #:projection
    (λ (ctc)
      (λ (blame)
@@ -202,6 +227,7 @@
   (build-chaperone-contract-property
    #:name hash/c-name
    #:first-order hash/c-first-order
+   #:stronger hash/c-stronger
    #:projection (ho-projection chaperone-hash)))
 
 (define-struct (impersonator-hash/c base-hash/c) ()
@@ -211,4 +237,5 @@
   (build-contract-property
    #:name hash/c-name
    #:first-order hash/c-first-order
+   #:stronger hash/c-stronger
    #:projection (ho-projection impersonate-hash)))