From afa0530b3ac1ebc7f197c4f550aa14d6d69f1928 Mon Sep 17 00:00:00 2001
From: Ben Greenman <benjaminlgreenman@gmail.com>
Date: Thu, 13 Jul 2017 15:13:56 -0400
Subject: [PATCH] backwards-compatibility: make HashTableTop generate a flat
 contract

Changing `HashTableTop` from a singleton to the union:

```
  (U (Immutable-HashTable Any Any) MutableHashTable WeakHashTable)
```

is a backwards compatibility issue because the type `Any` requires a chaperone,
therefore `HashTableTop` requires a chaperone.

This commit adds a case to make sure `HashTableTop` generates a flat contract.
---
 typed-racket-lib/typed-racket/private/type-contract.rkt  | 7 +++++++
 typed-racket-lib/typed-racket/types/match-expanders.rkt  | 9 +++++++++
 typed-racket-test/succeed/hashtabletop-flat-contract.rkt | 6 ++++++
 3 files changed, 22 insertions(+)
 create mode 100644 typed-racket-test/succeed/hashtabletop-flat-contract.rkt

diff --git a/typed-racket-lib/typed-racket/private/type-contract.rkt b/typed-racket-lib/typed-racket/private/type-contract.rkt
index 9a416b7a..71608289 100644
--- a/typed-racket-lib/typed-racket/private/type-contract.rkt
+++ b/typed-racket-lib/typed-racket/private/type-contract.rkt
@@ -464,6 +464,13 @@
             (apply or/sc (append other-scs (map t->sc (nbits->base-types nbits)))))]
        [(? Union? t)
         (match (normalize-type t)
+          [(HashTableTop:)
+           ;; NOTE: this is a special case to make `HashTableTop` produce a flat contract.
+           ;; Without this case:
+           ;; - `HashTableTop` would make a chaperone contract
+           ;; - because `HashTableTop` is a union containing `(Immutable-HashTable Any Any)`
+           ;; - and `Any` makes a chaperone contract
+           hash?/sc]
           [(Union-all: elems)
            (define-values [hash-elems other-elems] (partition hash/kv? elems))
            (define maybe-hash/sc (hash-types->sc hash-elems))
diff --git a/typed-racket-lib/typed-racket/types/match-expanders.rkt b/typed-racket-lib/typed-racket/types/match-expanders.rkt
index a0d2c294..23c17c1e 100644
--- a/typed-racket-lib/typed-racket/types/match-expanders.rkt
+++ b/typed-racket-lib/typed-racket/types/match-expanders.rkt
@@ -9,6 +9,7 @@
          (for-syntax racket/base syntax/parse))
 
 (provide Listof: List: MListof: AnyPoly: AnyPoly-names:
+         HashTableTop:
          SimpleListof: SimpleMListof:
          PredicateProp:
          Val-able:
@@ -172,3 +173,11 @@
                              _
                              _
                              (Values: (list (Result: _ ps _))))))])))
+
+(define-match-expander HashTableTop:
+  (lambda (stx)
+    (syntax-parse stx
+     [(_) #'(Union-all: (list-no-order (Immutable-HashTable: Univ Univ)
+                                       Mutable-HashTableTop:
+                                       Weak-HashTableTop:))])))
+
diff --git a/typed-racket-test/succeed/hashtabletop-flat-contract.rkt b/typed-racket-test/succeed/hashtabletop-flat-contract.rkt
new file mode 100644
index 00000000..09919047
--- /dev/null
+++ b/typed-racket-test/succeed/hashtabletop-flat-contract.rkt
@@ -0,0 +1,6 @@
+#lang typed/racket/base
+
+;; Test that `HashTableTop` generates a flat contract
+
+(define h : HashTableTop (hash))
+(void (cast h HashTableTop))