module Data.ConcreteTypeRep (
ConcreteTypeRep,
cTypeOf,
toTypeRep,
fromTypeRep,
) where
import Data.Typeable
#ifdef NEW_TYPEREP
import Data.Typeable.Internal
import GHC.Fingerprint.Type
#endif
import Data.Hashable
import Data.Binary
import System.IO.Unsafe
import Control.Applicative((<$>))
newtype ConcreteTypeRep = CTR { unCTR :: TypeRep } deriving(Eq, Typeable)
cTypeOf :: Typeable a => a -> ConcreteTypeRep
cTypeOf = fromTypeRep . typeOf
toTypeRep :: ConcreteTypeRep -> TypeRep
toTypeRep = unCTR
fromTypeRep :: TypeRep -> ConcreteTypeRep
fromTypeRep = CTR
instance Show ConcreteTypeRep where
showsPrec i = showsPrec i . unCTR
instance Hashable ConcreteTypeRep where
#ifdef NEW_TYPEREP
hashWithSalt salt (CTR (TypeRep (Fingerprint w1 w2) _ _)) = salt `hashWithSalt` w1 `hashWithSalt` w2
#else
hashWithSalt salt ctr = hashWithSalt salt (unsafePerformIO . typeRepKey . toTypeRep $ ctr)
#endif
toTyConRep :: TyCon -> TyConRep
fromTyConRep :: TyConRep -> TyCon
#ifdef NEW_TYPEREP
type TyConRep = (String, String, String)
toTyConRep (TyCon _ pack mod name) = (pack, mod, name)
fromTyConRep (pack, mod, name) = mkTyCon3 pack mod name
#else
type TyConRep = String
toTyConRep = tyConString
fromTyConRep = mkTyCon
#endif
newtype SerialRep = SR (TyConRep, [SerialRep]) deriving(Binary)
toSerial :: ConcreteTypeRep -> SerialRep
toSerial (CTR t) =
case splitTyConApp t of
(con, args) -> SR (toTyConRep con, map (toSerial . CTR) args)
fromSerial :: SerialRep -> ConcreteTypeRep
fromSerial (SR (con, args)) = CTR $ mkTyConApp (fromTyConRep con) (map (unCTR . fromSerial) args)
instance Binary ConcreteTypeRep where
put = put . toSerial
get = fromSerial <$> get