[commit: ghc] wip/generalized-arrow: More serialization (660b13e)

[git at git.haskell.org]

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

On branch  : wip/generalized-arrow
Link       : http://ghc.haskell.org/trac/ghc/changeset/660b13e29b2f8f668a2e62e4b3c996c12e1e7b29/ghc

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

commit 660b13e29b2f8f668a2e62e4b3c996c12e1e7b29
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Wed Mar 16 10:33:37 2016 +0100

    More serialization


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

660b13e29b2f8f668a2e62e4b3c996c12e1e7b29
 compiler/utils/Binary.hs         | 14 +++++++++-----
 libraries/base/Data/Typeable.hs  | 20 +++++++++++++-------
 libraries/ghci/GHCi/TH/Binary.hs | 13 ++++++++-----
 3 files changed, 30 insertions(+), 17 deletions(-)

diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index 431b187..2dd2182 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -587,12 +587,13 @@ putTypeRep bh (TRApp f x) = do
     put_ bh (1 :: Word8)
     putTypeRep bh f
     putTypeRep bh x
+putTypeRep _ _ = fail "putTypeRep: Impossible"
 
 getTypeRepX :: BinHandle -> IO TypeRepX
 getTypeRepX bh = do
     tag <- get bh :: IO Word8
     case tag of
-        0 -> do con <- get bh
+        0 -> do con <- get bh :: IO TyCon
                 TypeRepX rep_k <- getTypeRepX bh
                 case rep_k `eqTypeRep` (typeRep :: TypeRep Type) of
                     Just HRefl -> pure $ TypeRepX $ mkTrCon con rep_k
@@ -602,10 +603,13 @@ getTypeRepX bh = do
                 TypeRepX x <- getTypeRepX bh
                 case typeRepKind f of
                     TRFun arg _ ->
-                        case arg `eqTypeRep` x of
-                            Just HRefl ->
-                                pure $ TypeRepX $ mkTrApp f x
-                            _ -> fail "getTypeRepX: Kind mismatch"
+                        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"
                     _ -> fail "getTypeRepX: Applied non-arrow type"
         _ -> fail "Binary: Invalid TypeRepX"
 
diff --git a/libraries/base/Data/Typeable.hs b/libraries/base/Data/Typeable.hs
index 7718cf3..21f93d2 100644
--- a/libraries/base/Data/Typeable.hs
+++ b/libraries/base/Data/Typeable.hs
@@ -154,13 +154,19 @@ typeRepTyCon = I.typeRepXTyCon
 -- represents a function of type @t -> u@ and the second argument represents a
 -- function of type @t at . Otherwise, returns @Nothing at .
 funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
-funResultTy (I.TypeRepX f) (I.TypeRepX x)
-  | Just HRefl <- (I.typeRep :: I.TypeRep Type) `I.eqTypeRep` I.typeRepKind f
-  , I.TRFun arg res <- f
-  , Just HRefl <- arg `I.eqTypeRep` x
-  = Just (I.TypeRepX res)
-  | otherwise
-  = Nothing
+{-
+funResultTy (I.TypeRepX f) (I.TypeRepX x) =
+    case (I.typeRep :: I.TypeRep Type) `I.eqTypeRep` I.typeRepKind f of
+        Just HRefl ->
+            case f of
+                I.TRFun arg res ->
+                    case arg `I.eqTypeRep` x of
+                        Just HRefl -> Just (I.TypeRepX res)
+                        Nothing    -> Nothing
+                _ -> Nothing
+        Nothing -> Nothing
+-}
+funResultTy _ _ = Nothing
 
 -- | Force a 'TypeRep' to normal form.
 rnfTypeRep :: TypeRep -> ()
diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs
index 522cc80..e0f0ba2 100644
--- a/libraries/ghci/GHCi/TH/Binary.hs
+++ b/libraries/ghci/GHCi/TH/Binary.hs
@@ -11,7 +11,6 @@ module GHCi.TH.Binary () where
 import Data.Binary
 import qualified Data.ByteString as B
 #if MIN_VERSION_base(4,9,0)
-import Control.Monad (when)
 import Type.Reflection
 import Type.Reflection.Unsafe
 import Data.Kind (Type)
@@ -88,6 +87,7 @@ putTypeRep (TRApp f x) = do
     put (1 :: Word8)
     putTypeRep f
     putTypeRep x
+putTypeRep _ = fail "putTypeRep: Impossible"
 
 getTypeRepX :: Get TypeRepX
 getTypeRepX = do
@@ -103,10 +103,13 @@ getTypeRepX = do
                 TypeRepX x <- getTypeRepX
                 case typeRepKind f of
                     TRFun arg _ ->
-                        case arg `eqTypeRep` x of
-                            Just HRefl ->
-                                pure $ TypeRepX $ mkTrApp f x
-                            _ -> fail "getTypeRepX: Kind mismatch"
+                        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"
                     _ -> fail "getTypeRepX: Applied non-arrow type"
         _ -> fail "getTypeRepX: Invalid TypeRepX"