{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, CPP, ViewPatterns #-}
module Data.ConcreteTypeRep (
ConcreteTypeRep,
cTypeOf,
toTypeRep,
fromTypeRep,
) where
#if MIN_VERSION_base(4,10,0)
import Type.Reflection (SomeTypeRep(..))
import Type.Reflection.Unsafe (mkTyCon, mkTrCon, tyConKindArgs, tyConKindRep, KindRep)
#endif
import Data.Typeable
import Data.Hashable
import Data.Binary
import GHC.Fingerprint
newtype ConcreteTypeRep = CTR { ConcreteTypeRep -> TypeRep
unCTR :: TypeRep }
deriving (ConcreteTypeRep -> ConcreteTypeRep -> Bool
(ConcreteTypeRep -> ConcreteTypeRep -> Bool)
-> (ConcreteTypeRep -> ConcreteTypeRep -> Bool)
-> Eq ConcreteTypeRep
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConcreteTypeRep -> ConcreteTypeRep -> Bool
== :: ConcreteTypeRep -> ConcreteTypeRep -> Bool
$c/= :: ConcreteTypeRep -> ConcreteTypeRep -> Bool
/= :: ConcreteTypeRep -> ConcreteTypeRep -> Bool
Eq, Typeable)
cTypeOf :: Typeable a => a -> ConcreteTypeRep
cTypeOf :: forall a. Typeable a => a -> ConcreteTypeRep
cTypeOf = TypeRep -> ConcreteTypeRep
fromTypeRep (TypeRep -> ConcreteTypeRep)
-> (a -> TypeRep) -> a -> ConcreteTypeRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf
toTypeRep :: ConcreteTypeRep -> TypeRep
toTypeRep :: ConcreteTypeRep -> TypeRep
toTypeRep = ConcreteTypeRep -> TypeRep
unCTR
fromTypeRep :: TypeRep -> ConcreteTypeRep
fromTypeRep :: TypeRep -> ConcreteTypeRep
fromTypeRep = TypeRep -> ConcreteTypeRep
CTR
instance Show ConcreteTypeRep where
showsPrec :: Int -> ConcreteTypeRep -> ShowS
showsPrec Int
i = Int -> TypeRep -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
i (TypeRep -> ShowS)
-> (ConcreteTypeRep -> TypeRep) -> ConcreteTypeRep -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConcreteTypeRep -> TypeRep
unCTR
instance Hashable ConcreteTypeRep where
hashWithSalt :: Int -> ConcreteTypeRep -> Int
hashWithSalt Int
salt (CTR (TypeRep -> Fingerprint
typeRepFingerprint -> Fingerprint Word64
w1 Word64
w2)) = Int
salt Int -> Word64 -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word64
w1 Int -> Word64 -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word64
w2
#if MIN_VERSION_base(4,10,0)
type TyConRep = (String, String, String, Int, KindRep)
#else
type TyConRep = (String, String, String)
#endif
toTyConRep :: TyCon -> TyConRep
fromTyConRep :: TyConRep -> TyCon
#if MIN_VERSION_base(4,10,0)
toTyConRep :: TyCon -> TyConRep
toTyConRep TyCon
tc = (TyCon -> String
tyConPackage TyCon
tc, TyCon -> String
tyConModule TyCon
tc, TyCon -> String
tyConName TyCon
tc, TyCon -> Int
tyConKindArgs TyCon
tc, TyCon -> KindRep
tyConKindRep TyCon
tc)
#else
toTyConRep tc = (tyConPackage tc, tyConModule tc, tyConName tc)
#endif
#if MIN_VERSION_base(4,10,0)
fromTyConRep :: TyConRep -> TyCon
fromTyConRep (String
pack, String
mod', String
name, Int
ka, KindRep
kr) = String -> String -> String -> Int -> KindRep -> TyCon
mkTyCon String
pack String
mod' String
name Int
ka KindRep
kr
#else
fromTyConRep (pack, mod', name) = mkTyCon3 pack mod' name
#endif
newtype SerialRep = SR (TyConRep, [SerialRep])
deriving (Get SerialRep
[SerialRep] -> Put
SerialRep -> Put
(SerialRep -> Put)
-> Get SerialRep -> ([SerialRep] -> Put) -> Binary SerialRep
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: SerialRep -> Put
put :: SerialRep -> Put
$cget :: Get SerialRep
get :: Get SerialRep
$cputList :: [SerialRep] -> Put
putList :: [SerialRep] -> Put
Binary)
toSerial :: ConcreteTypeRep -> SerialRep
toSerial :: ConcreteTypeRep -> SerialRep
toSerial (CTR TypeRep
t) =
case TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
t of
(TyCon
con, [TypeRep]
args) -> (TyConRep, [SerialRep]) -> SerialRep
SR (TyCon -> TyConRep
toTyConRep TyCon
con, (TypeRep -> SerialRep) -> [TypeRep] -> [SerialRep]
forall a b. (a -> b) -> [a] -> [b]
map (ConcreteTypeRep -> SerialRep
toSerial (ConcreteTypeRep -> SerialRep)
-> (TypeRep -> ConcreteTypeRep) -> TypeRep -> SerialRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> ConcreteTypeRep
CTR) [TypeRep]
args)
fromSerial :: SerialRep -> ConcreteTypeRep
#if MIN_VERSION_base(4,10,0)
fromSerial :: SerialRep -> ConcreteTypeRep
fromSerial (SR (TyConRep
con, [SerialRep]
args)) = TypeRep -> ConcreteTypeRep
CTR (TypeRep -> ConcreteTypeRep)
-> (TypeRep Any -> TypeRep) -> TypeRep Any -> ConcreteTypeRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep Any -> TypeRep
forall k (a :: k). TypeRep a -> TypeRep
SomeTypeRep (TypeRep Any -> ConcreteTypeRep) -> TypeRep Any -> ConcreteTypeRep
forall a b. (a -> b) -> a -> b
$ TyCon -> [TypeRep] -> TypeRep Any
forall k (a :: k). TyCon -> [TypeRep] -> TypeRep a
mkTrCon (TyConRep -> TyCon
fromTyConRep TyConRep
con) ((SerialRep -> TypeRep) -> [SerialRep] -> [TypeRep]
forall a b. (a -> b) -> [a] -> [b]
map (ConcreteTypeRep -> TypeRep
unCTR (ConcreteTypeRep -> TypeRep)
-> (SerialRep -> ConcreteTypeRep) -> SerialRep -> TypeRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SerialRep -> ConcreteTypeRep
fromSerial) [SerialRep]
args)
#else
fromSerial (SR (con, args)) = CTR $ mkTyConApp (fromTyConRep con) (map (unCTR . fromSerial) args)
#endif
instance Binary ConcreteTypeRep where
put :: ConcreteTypeRep -> Put
put = SerialRep -> Put
forall t. Binary t => t -> Put
put (SerialRep -> Put)
-> (ConcreteTypeRep -> SerialRep) -> ConcreteTypeRep -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConcreteTypeRep -> SerialRep
toSerial
get :: Get ConcreteTypeRep
get = SerialRep -> ConcreteTypeRep
fromSerial (SerialRep -> ConcreteTypeRep)
-> Get SerialRep -> Get ConcreteTypeRep
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get SerialRep
forall t. Binary t => Get t
get