[commit: ghc] wip/ttypeable: Fix serialization (4f3c051)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/ttypeable
Link       : http://ghc.haskell.org/trac/ghc/changeset/4f3c05163b39337180df62b990a3e1c4f36c6a7a/ghc

>---------------------------------------------------------------

commit 4f3c05163b39337180df62b990a3e1c4f36c6a7a
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Fri Mar 11 19:23:16 2016 +0100

    Fix serialization


>---------------------------------------------------------------

4f3c05163b39337180df62b990a3e1c4f36c6a7a
 compiler/utils/Binary.hs         | 12 +++++++-----
 libraries/ghci/GHCi/TH/Binary.hs | 14 ++++++++------
 2 files changed, 15 insertions(+), 11 deletions(-)

diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index c8f1d44..fcf9ce7 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -594,14 +594,16 @@ getTypeRepX bh = do
     case tag of
         0 -> do con <- get bh
                 TypeRepX rep_k <- getTypeRepX bh
-                Just HRefl <- pure $ eqTypeRep rep_k (typeRep :: TypeRep Type)
-                pure $ TypeRepX $ mkTrCon con rep_k
+                case rep_k `eqTypeRep` (typeRep :: TypeRep Type) of
+                    Just HRefl -> pure $ TypeRepX $ mkTrCon con rep_k
+                    Nothing    -> fail "getTypeRepX: Kind mismatch"
+
         1 -> do TypeRepX f <- getTypeRepX bh
                 TypeRepX x <- getTypeRepX bh
                 case typeRepKind f of
-                  TRFun arg _ -> do
-                    Just HRefl <- pure $ eqTypeRep arg x
-                    pure $ TypeRepX $ mkTrApp f x
+                    TRFun arg _ | Just HRefl <- arg `eqTypeRep` x ->
+                      pure $ TypeRepX $ mkTrApp f x
+                    _ -> fail "getTypeRepX: Kind mismatch"
         _ -> fail "Binary: Invalid TypeRepX"
 
 instance Typeable a => Binary (TypeRep (a :: k)) where
diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs
index d067e54..2433057 100644
--- a/libraries/ghci/GHCi/TH/Binary.hs
+++ b/libraries/ghci/GHCi/TH/Binary.hs
@@ -95,15 +95,17 @@ getTypeRepX = do
     case tag of
         0 -> do con <- get :: Get TyCon
                 TypeRepX rep_k <- getTypeRepX
-                Just HRefl <- pure $ eqTypeRep rep_k (typeRep :: TypeRep Type)
-                pure $ TypeRepX $ mkTrCon con rep_k
+                case rep_k `eqTypeRep` (typeRep :: TypeRep Type) of
+                    Just HRefl -> pure $ TypeRepX $ mkTrCon con rep_k
+                    Nothing    -> fail "getTypeRepX: Kind mismatch"
+
         1 -> do TypeRepX f <- getTypeRepX
                 TypeRepX x <- getTypeRepX
                 case typeRepKind f of
-                  TRFun arg _ -> do
-                    Just HRefl <- pure $ eqTypeRep arg x
-                    pure $ TypeRepX $ mkTrApp f x
-        _ -> fail "Binary: Invalid TTypeRep"
+                    TRFun arg _ | Just HRefl <- arg `eqTypeRep` x ->
+                      pure $ TypeRepX $ mkTrApp f x
+                    _ -> fail "getTypeRepX: Kind mismatch"
+        _ -> fail "getTypeRepX: Invalid TypeRepX"
 
 instance Typeable a => Binary (TypeRep (a :: k)) where
     put = putTypeRep