[commit: ghc] wip/ttypeable: Finally serialization is both general and correct (ace8fd9)

[git at git.haskell.org]

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

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

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

commit ace8fd96e33983f6ddeb46084e10de3c894916c3
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Wed Mar 16 12:16:20 2016 +0100

    Finally serialization is both general and correct


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

ace8fd96e33983f6ddeb46084e10de3c894916c3
 compiler/utils/Binary.hs         | 13 +++++--------
 libraries/ghci/GHCi/TH/Binary.hs | 11 ++++-------
 2 files changed, 9 insertions(+), 15 deletions(-)

diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index f06de81..88ea8cd 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -606,15 +606,12 @@ getTypeRepX bh = do
                 TypeRepX x <- getTypeRepX bh
                 case typeRepKind f of
                     TRFun arg _ ->
-                        case (typeRep :: TypeRep Type) `eqTypeRep` arg of
-                            Just HRefl ->  -- FIXME: Generalize (->)
-                                case x `eqTypeRep` arg of
-                                    Just HRefl ->
-                                        pure $ TypeRepX $ mkTrApp f x
-                                    _ -> fail "getTypeRepX: Kind mismatch"
-                            Nothing -> fail "getTypeRepX: Arrow of non-Type argument"
+                        case arg `eqTypeRep` typeRepKind x of
+                            Just HRefl ->
+                                pure $ TypeRepX $ mkTrApp f x
+                            _ -> fail "getTypeRepX: Kind mismatch"
                     _ -> fail "getTypeRepX: Applied non-arrow type"
-        _ -> fail "Binary: Invalid TypeRepX"
+        _ -> fail "getTypeRepX: Invalid TypeRepX"
 
 instance Typeable a => Binary (TypeRep (a :: k)) where
     put_ = putTypeRep
diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs
index c714514..5dd6fa8 100644
--- a/libraries/ghci/GHCi/TH/Binary.hs
+++ b/libraries/ghci/GHCi/TH/Binary.hs
@@ -108,13 +108,10 @@ getTypeRepX = do
                 TypeRepX x <- getTypeRepX
                 case typeRepKind f of
                     TRFun arg _ ->
-                        case (typeRep :: TypeRep Type) `eqTypeRep` arg of
-                            Just HRefl -> -- FIXME: Generalize (->)
-                                case arg `eqTypeRep` x of
-                                    Just HRefl ->
-                                        pure $ TypeRepX $ mkTrApp f x
-                                    _ -> fail "getTypeRepX: Kind mismatch"
-                            _ -> fail "getTypeRepX: Arrow of non-Type argument"
+                        case arg `eqTypeRep` typeRepKind x of
+                            Just HRefl ->
+                                pure $ TypeRepX $ mkTrApp f x
+                            _ -> fail "getTypeRepX: Kind mismatch"
                     _ -> fail "getTypeRepX: Applied non-arrow type"
         _ -> fail "getTypeRepX: Invalid TypeRepX"