[commit: ghc] wip/ttypeable-builtin-kindreps: Move Typeable Binary instances to binary package (f296dda)
git at git.haskell.org
git at git.haskell.org
Sun Feb 26 20:29:15 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/ttypeable-builtin-kindreps
Link : http://ghc.haskell.org/trac/ghc/changeset/f296ddaefb139dd8fa144e2ebed90e8107d2d7bb/ghc
>---------------------------------------------------------------
commit f296ddaefb139dd8fa144e2ebed90e8107d2d7bb
Author: Ben Gamari <ben at smart-cactus.org>
Date: Wed Feb 8 23:00:46 2017 -0500
Move Typeable Binary instances to binary package
>---------------------------------------------------------------
f296ddaefb139dd8fa144e2ebed90e8107d2d7bb
libraries/binary | 2 +-
libraries/ghci/GHCi/TH/Binary.hs | 177 ++-------------------------------------
2 files changed, 9 insertions(+), 170 deletions(-)
diff --git a/libraries/binary b/libraries/binary
index af1d17c..3985dae 160000
--- a/libraries/binary
+++ b/libraries/binary
@@ -1 +1 @@
-Subproject commit af1d17c27867f644886fcbc4703eb3e48792f3e7
+Subproject commit 3985daec78aac24be1dd26ad0949b5dd2733443d
diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs
index fcff168..ae6bc9f 100644
--- a/libraries/ghci/GHCi/TH/Binary.hs
+++ b/libraries/ghci/GHCi/TH/Binary.hs
@@ -10,18 +10,12 @@ module GHCi.TH.Binary () where
import Data.Binary
import qualified Data.ByteString as B
-#if MIN_VERSION_base(4,10,0)
-import Type.Reflection
-import Type.Reflection.Unsafe
-import Data.Kind (Type)
-import GHC.Exts (RuntimeRep(..), VecCount, VecElem)
-#else
-import Data.Typeable
-#endif
import GHC.Serialized
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
-
+#if !MIN_VERSION_base(4,10,0)
+import Data.Typeable
+#endif
-- Put these in a separate module because they take ages to compile
instance Binary TH.Loc
@@ -79,163 +73,12 @@ instance Binary TH.PatSynArgs
-- We need Binary TypeRep for serializing annotations
-#if MIN_VERSION_base(4,10,0)
-instance Binary VecCount where
- put = putWord8 . fromIntegral . fromEnum
- get = toEnum . fromIntegral <$> getWord8
-
-instance Binary VecElem where
- put = putWord8 . fromIntegral . fromEnum
- get = toEnum . fromIntegral <$> getWord8
-
-instance Binary RuntimeRep where
- put (VecRep a b) = putWord8 0 >> put a >> put b
- put (TupleRep reps) = putWord8 1 >> put reps
- put (SumRep reps) = putWord8 2 >> put reps
- put LiftedRep = putWord8 3
- put UnliftedRep = putWord8 4
- put IntRep = putWord8 5
- put WordRep = putWord8 6
- put Int64Rep = putWord8 7
- put Word64Rep = putWord8 8
- put AddrRep = putWord8 9
- put FloatRep = putWord8 10
- put DoubleRep = putWord8 11
-
- get = do
- tag <- getWord8
- case tag of
- 0 -> VecRep <$> get <*> get
- 1 -> TupleRep <$> get
- 2 -> SumRep <$> get
- 3 -> pure LiftedRep
- 4 -> pure UnliftedRep
- 5 -> pure IntRep
- 6 -> pure WordRep
- 7 -> pure Int64Rep
- 8 -> pure Word64Rep
- 9 -> pure AddrRep
- 10 -> pure FloatRep
- 11 -> pure DoubleRep
- _ -> fail "GHCi.TH.Binary.putRuntimeRep: invalid tag"
-
-instance Binary TyCon where
- put tc = do
- put (tyConPackage tc)
- put (tyConModule tc)
- put (tyConName tc)
- put (tyConKindArgs tc)
- put (tyConKindRep tc)
- get = mkTyCon <$> get <*> get <*> get <*> get <*> get
-
-instance Binary KindRep where
- put (KindRepTyConApp tc k) = putWord8 0 >> put tc >> put k
- put (KindRepVar bndr) = putWord8 1 >> put bndr
- put (KindRepApp a b) = putWord8 2 >> put a >> put b
- put (KindRepFun a b) = putWord8 3 >> put a >> put b
- put (KindRepTYPE r) = putWord8 4 >> put r
- put (KindRepTypeLit sort r) = putWord8 5 >> put sort >> put r
- put _ = fail "GHCi.TH.Binary.putKindRep: Impossible"
-
- get = do
- tag <- getWord8
- case tag of
- 0 -> KindRepTyConApp <$> get <*> get
- 1 -> KindRepVar <$> get
- 2 -> KindRepApp <$> get <*> get
- 3 -> KindRepFun <$> get <*> get
- 4 -> KindRepTYPE <$> get
- 5 -> KindRepTypeLit <$> get <*> get
- _ -> fail "GHCi.TH.Binary.putKindRep: invalid tag"
-
-instance Binary TypeLitSort where
- put TypeLitSymbol = putWord8 0
- put TypeLitNat = putWord8 1
- get = do
- tag <- getWord8
- case tag of
- 0 -> pure TypeLitSymbol
- 1 -> pure TypeLitNat
- _ -> fail "GHCi.TH.Binary.putTypeLitSort: invalid tag"
-
-putTypeRep :: TypeRep a -> Put
--- Special handling for TYPE, (->), and RuntimeRep due to recursive kind
--- relations.
--- See Note [Mutually recursive representations of primitive types]
-putTypeRep rep -- Handle Type specially since it's so common
- | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)
- = put (0 :: Word8)
-putTypeRep (Con' con ks) = do
- put (1 :: Word8)
- put con
- put ks
-putTypeRep (App f x) = do
- put (2 :: Word8)
- putTypeRep f
- putTypeRep x
-putTypeRep (Fun arg res) = do
- put (3 :: Word8)
- putTypeRep arg
- putTypeRep res
-putTypeRep _ = fail "GHCi.TH.Binary.putTypeRep: Impossible"
-
-getSomeTypeRep :: Get SomeTypeRep
-getSomeTypeRep = do
- tag <- get :: Get Word8
- case tag of
- 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)
- 1 -> do con <- get :: Get TyCon
- ks <- get :: Get [SomeTypeRep]
- return $ SomeTypeRep $ mkTrCon con ks
- 2 -> do SomeTypeRep f <- getSomeTypeRep
- SomeTypeRep x <- getSomeTypeRep
- case typeRepKind f of
- Fun arg res ->
- case arg `eqTypeRep` typeRepKind x of
- Just HRefl -> do
- case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
- Just HRefl -> return $ SomeTypeRep $ mkTrApp f x
- _ -> failure "Kind mismatch" []
- _ -> failure "Kind mismatch"
- [ "Found argument of kind: " ++ show (typeRepKind x)
- , "Where the constructor: " ++ show f
- , "Expects an argument of kind: " ++ show arg
- ]
- _ -> failure "Applied non-arrow type"
- [ "Applied type: " ++ show f
- , "To argument: " ++ show x
- ]
- 3 -> do SomeTypeRep arg <- getSomeTypeRep
- SomeTypeRep res <- getSomeTypeRep
- 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" []
- Nothing -> failure "Kind mismatch" []
- _ -> failure "Invalid SomeTypeRep" []
- where
- failure description info =
- fail $ unlines $ [ "GHCi.TH.Binary.getSomeTypeRep: "++description ]
- ++ map (" "++) info
-
-instance Typeable a => Binary (TypeRep (a :: k)) where
- put = putTypeRep
- get = do
- SomeTypeRep rep <- getSomeTypeRep
- case rep `eqTypeRep` expected of
- Just HRefl -> pure rep
- Nothing -> fail $ unlines
- [ "GHCi.TH.Binary: Type mismatch"
- , " Deserialized type: " ++ show rep
- , " Expected type: " ++ show expected
- ]
- where expected = typeRep :: TypeRep a
+instance Binary Serialized where
+ put (Serialized tyrep wds) = put tyrep >> put (B.pack wds)
+ get = Serialized <$> get <*> (B.unpack <$> get)
-instance Binary SomeTypeRep where
- put (SomeTypeRep rep) = putTypeRep rep
- get = getSomeTypeRep
-#else
+-- Typeable and related instances live in binary since GHC 8.2
+#if !MIN_VERSION_base(4,10,0)
instance Binary TyCon where
put tc = put (tyConPackage tc) >> put (tyConModule tc) >> put (tyConName tc)
get = mkTyCon3 <$> get <*> get <*> get
@@ -246,7 +89,3 @@ instance Binary TypeRep where
(ty_con, child_type_reps) <- get
return (mkTyConApp ty_con child_type_reps)
#endif
-
-instance Binary Serialized where
- put (Serialized tyrep wds) = put tyrep >> put (B.pack wds)
- get = Serialized <$> get <*> (B.unpack <$> get)
More information about the ghc-commits
mailing list