[commit: ghc] master: Deserialize all function TypeReps (19ca2ca)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/19ca2cab4b32ff2eaacb1fb3502849ad762af0e1/ghc

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

commit 19ca2cab4b32ff2eaacb1fb3502849ad762af0e1
Author: David Feuer <david.feuer at gmail.com>
Date:   Thu Nov 2 17:30:59 2017 -0400

    Deserialize all function TypeReps
    
    Previously, we could only deserialize `TypeRep (a -> b)` if
    both `a` and `b` had kind `Type`. Now, we do it regardless of
    their runtime representations.
    
    Reviewers: austin, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: rwbarton, thomie
    
    Differential Revision: https://phabricator.haskell.org/D4137


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

19ca2cab4b32ff2eaacb1fb3502849ad762af0e1
 compiler/utils/Binary.hs | 19 ++++++++++++-------
 1 file changed, 12 insertions(+), 7 deletions(-)

diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index 1c0284a..a7bbfd5 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiWayIf #-}
 
 {-# OPTIONS_GHC -O -funbox-strict-fields #-}
 -- We always optimise this, otherwise performance of a non-optimised
@@ -82,7 +83,7 @@ import Data.Time
 import Type.Reflection
 import Type.Reflection.Unsafe
 import Data.Kind (Type)
-import GHC.Exts (RuntimeRep(..), VecCount(..), VecElem(..))
+import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..))
 #else
 import Data.Typeable
 #endif
@@ -748,14 +749,18 @@ getSomeTypeRep bh = do
                        ]
         3 -> do SomeTypeRep arg <- getSomeTypeRep bh
                 SomeTypeRep res <- getSomeTypeRep bh
-                case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of
-                  Just HRefl ->
-                      case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
-                        Just HRefl -> return $ SomeTypeRep $ Fun arg res
-                        Nothing -> failure "Kind mismatch" []
-                  _ -> failure "Kind mismatch" []
+                if
+                  | App argkcon _ <- typeRepKind arg
+                  , App reskcon _ <- typeRepKind res
+                  , Just HRefl <- argkcon `eqTypeRep` tYPErep
+                  , Just HRefl <- reskcon `eqTypeRep` tYPErep
+                  -> return $ SomeTypeRep $ Fun arg res
+                  | otherwise -> failure "Kind mismatch" []
         _ -> failure "Invalid SomeTypeRep" []
   where
+    tYPErep :: TypeRep TYPE
+    tYPErep = typeRep
+
     failure description info =
         fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ]
                       ++ map ("    "++) info