Add Binary instances for Typeable TypeReps (#131)
authorBen Gamari <ben@smart-cactus.org>
Sat, 25 Feb 2017 09:01:12 +0000 (09:01 +0000)
committerLennart Kolmodin <kolmodin@gmail.com>
Sat, 25 Feb 2017 09:01:12 +0000 (10:01 +0100)
src/Data/Binary/Class.hs
tests/QC.hs

index 65d737f..ea36101 100644 (file)
@@ -1,6 +1,9 @@
 {-# LANGUAGE CPP, FlexibleContexts #-}
 {-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE Trustworthy #-}
 
 #if __GLASGOW_HASKELL__ >= 706
 {-# LANGUAGE PolyKinds #-}
 #define HAS_FIXED_CONSTRUCTOR
 #endif
 
-#ifndef HAS_FIXED_CONSTRUCTOR
-{-# LANGUAGE ScopedTypeVariables #-}
-#endif
-
 -----------------------------------------------------------------------------
 -- |
 -- Module      : Data.Binary.Class
@@ -74,6 +73,14 @@ import qualified Data.ByteString.Builder.Prim as Prim
 import Data.List    (unfoldr, foldl')
 
 -- And needed for the instances:
+#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 qualified Data.ByteString as B
 #if MIN_VERSION_bytestring(0,10,4)
 import qualified Data.ByteString.Short as BS
@@ -819,3 +826,191 @@ instance Binary a => Binary (NE.NonEmpty a) where
   get = fmap NE.fromList get
   put = put . NE.toList
 #endif
+
+------------------------------------------------------------------------
+-- Typeable/Reflection
+
+#if MIN_VERSION_base(4,10,0)
+
+-- $typeable-instances
+--
+-- 'Binary' instances for GHC's "Type.Reflection", "Data.Typeable", and
+-- kind-system primitives are only provided with @base-4.10.0@ (shipped with GHC
+-- 8.2.1). In prior GHC releases some of these instances were provided by
+-- 'GHCi.TH.Binary' in the @ghci@ package.
+--
+-- These include instances for,
+--
+-- * 'VecCount'
+-- * 'VecElem'
+-- * 'RuntimeRep'
+-- * 'KindRep'
+-- * 'TypeLitSort'
+-- * 'TyCon'
+-- * 'TypeRep'
+-- * 'SomeTypeRep' (also known as 'Data.Typeable.TypeRep')
+--
+
+-- | @since 0.9.0.0. See #typeable-instances#
+instance Binary VecCount where
+    put = putWord8 . fromIntegral . fromEnum
+    get = toEnum . fromIntegral <$> getWord8
+
+-- | @since 0.9.0.0. See #typeable-instances#
+instance Binary VecElem where
+    put = putWord8 . fromIntegral . fromEnum
+    get = toEnum . fromIntegral <$> getWord8
+
+-- | @since 0.9.0.0. See #typeable-instances#
+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"
+
+-- | @since 0.9.0.0. See #typeable-instances#
+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
+
+-- | @since 0.9.0.0. See #typeable-instances#
+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"
+
+-- | @since 0.9.0.0. See #typeable-instances#
+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 SomeTypeRep where
+    put (SomeTypeRep rep) = putTypeRep rep
+    get = getSomeTypeRep
+#endif
+
index 650d32b..6577ffe 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, DataKinds, TypeSynonymInstances #-}
 module Main ( main ) where
 
 #if MIN_VERSION_base(4,8,0)
@@ -21,6 +21,7 @@ import           Data.ByteString.Short                (ShortByteString)
 #endif
 import           Data.Int
 import           Data.Ratio
+import           Data.Typeable
 import           System.IO.Unsafe
 
 #ifdef HAS_NATURAL
@@ -40,6 +41,7 @@ import           Arbitrary                            ()
 import           Data.Binary
 import           Data.Binary.Get
 import           Data.Binary.Put
+import qualified Data.Binary.Class as Class
 
 ------------------------------------------------------------------------
 
@@ -151,6 +153,36 @@ prop_Doublele = roundTripWith putDoublele getDoublele
 prop_Doublehost :: Double -> Property
 prop_Doublehost = roundTripWith putDoublehost getDoublehost
 
+#if MIN_VERSION_base(4,10,0)
+testTypeable :: Test
+testTypeable = testProperty "TypeRep" prop_TypeRep
+
+prop_TypeRep :: TypeRep -> Property
+prop_TypeRep = roundTripWith Class.put Class.get
+
+atomicTypeReps :: [TypeRep]
+atomicTypeReps =
+    [ typeRep (Proxy :: Proxy ())
+    , typeRep (Proxy :: Proxy String)
+    , typeRep (Proxy :: Proxy Int)
+    , typeRep (Proxy :: Proxy (,))
+    , typeRep (Proxy :: Proxy ((,) (Maybe Int)))
+    , typeRep (Proxy :: Proxy Maybe)
+    , typeRep (Proxy :: Proxy 'Nothing)
+    , typeRep (Proxy :: Proxy 'Left)
+    , typeRep (Proxy :: Proxy "Hello")
+    , typeRep (Proxy :: Proxy 42)
+    , typeRep (Proxy :: Proxy '[1,2,3,4])
+    , typeRep (Proxy :: Proxy ('Left Int))
+    , typeRep (Proxy :: Proxy (Either Int String))
+    ]
+
+instance Arbitrary TypeRep where
+    arbitrary = oneof (map pure atomicTypeReps)
+#else
+testTypeable :: Test
+testTypeable = testGroup "Skipping Typeable tests" []
+#endif
 
 -- done, partial and fail
 
@@ -676,4 +708,5 @@ tests =
             , testProperty "HasResolution -> MkFixed" $ p prop_fixed_resolution_constr
             ]
 #endif
+        , testTypeable
         ]