module Data.Typeable.Internal (
Proxy (..),
TypeRep(..),
Fingerprint(..),
typeOf, typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7,
Typeable1, Typeable2, Typeable3, Typeable4, Typeable5, Typeable6, Typeable7,
TyCon(..),
typeRep,
mkTyCon,
mkTyCon3,
mkTyConApp,
mkAppTy,
typeRepTyCon,
Typeable(..),
mkFunTy,
splitTyConApp,
funResultTy,
typeRepArgs,
showsTypeRep,
tyConString,
listTc, funTc
) where
import GHC.Base
import GHC.Word
import GHC.Show
import GHC.Read ( Read )
import Data.Proxy
import GHC.Num
import GHC.Real
import GHC.ST ( ST, STret )
import GHC.STRef ( STRef )
import GHC.Ptr ( Ptr, FunPtr )
import GHC.Arr ( Array, STArray, Ix )
import GHC.TypeLits ( Nat, Symbol, KnownNat, KnownSymbol, natVal', symbolVal' )
import Data.Type.Coercion
import Data.Type.Equality
import Text.ParserCombinators.ReadP ( ReadP )
import Text.Read.Lex ( Lexeme, Number )
import Text.ParserCombinators.ReadPrec ( ReadPrec )
import GHC.Float ( FFFormat, RealFloat, Floating )
import Data.Bits ( Bits, FiniteBits )
import GHC.Enum ( Bounded, Enum )
import GHC.Fingerprint.Type
import GHC.Fingerprint
data TypeRep = TypeRep !Fingerprint TyCon [TypeRep]
instance Eq TypeRep where
(TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
instance Ord TypeRep where
(TypeRep k1 _ _) <= (TypeRep k2 _ _) = k1 <= k2
data TyCon = TyCon {
tyConHash :: !Fingerprint,
tyConPackage :: String,
tyConModule :: String,
tyConName :: String
}
instance Eq TyCon where
(TyCon t1 _ _ _) == (TyCon t2 _ _ _) = t1 == t2
instance Ord TyCon where
(TyCon k1 _ _ _) <= (TyCon k2 _ _ _) = k1 <= k2
#include "MachDeps.h"
#if WORD_SIZE_IN_BITS < 64
mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon
#else
mkTyCon :: Word# -> Word# -> String -> String -> String -> TyCon
#endif
mkTyCon high# low# pkg modl name
= TyCon (Fingerprint (W64# high#) (W64# low#)) pkg modl name
mkTyConApp :: TyCon -> [TypeRep] -> TypeRep
mkTyConApp tc@(TyCon tc_k _ _ _) []
= TypeRep tc_k tc []
mkTyConApp tc@(TyCon tc_k _ _ _) args
= TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc args
where
arg_ks = [k | TypeRep k _ _ <- args]
mkFunTy :: TypeRep -> TypeRep -> TypeRep
mkFunTy f a = mkTyConApp funTc [f,a]
splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
splitTyConApp (TypeRep _ tc trs) = (tc,trs)
funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
funResultTy trFun trArg
= case splitTyConApp trFun of
(tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2
_ -> Nothing
mkAppTy :: TypeRep -> TypeRep -> TypeRep
mkAppTy (TypeRep _ tc trs) arg_tr = mkTyConApp tc (trs ++ [arg_tr])
mkTyCon3 :: String
-> String
-> String
-> TyCon
mkTyCon3 pkg modl name =
TyCon (fingerprintString (pkg ++ (' ':modl) ++ (' ':name))) pkg modl name
typeRepTyCon :: TypeRep -> TyCon
typeRepTyCon (TypeRep _ tc _) = tc
typeRepArgs :: TypeRep -> [TypeRep]
typeRepArgs (TypeRep _ _ args) = args
tyConString :: TyCon -> String
tyConString = tyConName
class Typeable a where
typeRep# :: Proxy# a -> TypeRep
typeRep :: forall proxy a. Typeable a => proxy a -> TypeRep
typeRep _ = typeRep# (proxy# :: Proxy# a)
typeOf :: forall a. Typeable a => a -> TypeRep
typeOf _ = typeRep (Proxy :: Proxy a)
typeOf1 :: forall t (a :: *). Typeable t => t a -> TypeRep
typeOf1 _ = typeRep (Proxy :: Proxy t)
typeOf2 :: forall t (a :: *) (b :: *). Typeable t => t a b -> TypeRep
typeOf2 _ = typeRep (Proxy :: Proxy t)
typeOf3 :: forall t (a :: *) (b :: *) (c :: *). Typeable t
=> t a b c -> TypeRep
typeOf3 _ = typeRep (Proxy :: Proxy t)
typeOf4 :: forall t (a :: *) (b :: *) (c :: *) (d :: *). Typeable t
=> t a b c d -> TypeRep
typeOf4 _ = typeRep (Proxy :: Proxy t)
typeOf5 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *). Typeable t
=> t a b c d e -> TypeRep
typeOf5 _ = typeRep (Proxy :: Proxy t)
typeOf6 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *).
Typeable t => t a b c d e f -> TypeRep
typeOf6 _ = typeRep (Proxy :: Proxy t)
typeOf7 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *)
(g :: *). Typeable t => t a b c d e f g -> TypeRep
typeOf7 _ = typeRep (Proxy :: Proxy t)
type Typeable1 (a :: * -> *) = Typeable a
type Typeable2 (a :: * -> * -> *) = Typeable a
type Typeable3 (a :: * -> * -> * -> *) = Typeable a
type Typeable4 (a :: * -> * -> * -> * -> *) = Typeable a
type Typeable5 (a :: * -> * -> * -> * -> * -> *) = Typeable a
type Typeable6 (a :: * -> * -> * -> * -> * -> * -> *) = Typeable a
type Typeable7 (a :: * -> * -> * -> * -> * -> * -> * -> *) = Typeable a
instance (Typeable s, Typeable a) => Typeable (s a) where
typeRep# = \_ -> rep
where !ty1 = typeRep# (proxy# :: Proxy# s)
!ty2 = typeRep# (proxy# :: Proxy# a)
!rep = ty1 `mkAppTy` ty2
instance Show TypeRep where
showsPrec p (TypeRep _ tycon tys) =
case tys of
[] -> showsPrec p tycon
[x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
[a,r] | tycon == funTc -> showParen (p > 8) $
showsPrec 9 a .
showString " -> " .
showsPrec 8 r
xs | isTupleTyCon tycon -> showTuple xs
| otherwise ->
showParen (p > 9) $
showsPrec p tycon .
showChar ' ' .
showArgs (showChar ' ') tys
showsTypeRep :: TypeRep -> ShowS
showsTypeRep = shows
instance Show TyCon where
showsPrec _ t = showString (tyConName t)
isTupleTyCon :: TyCon -> Bool
isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True
isTupleTyCon _ = False
showArgs :: Show a => ShowS -> [a] -> ShowS
showArgs _ [] = id
showArgs _ [a] = showsPrec 10 a
showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as
showTuple :: [TypeRep] -> ShowS
showTuple args = showChar '('
. showArgs (showChar ',') args
. showChar ')'
listTc :: TyCon
listTc = typeRepTyCon (typeOf [()])
funTc :: TyCon
funTc = typeRepTyCon (typeRep (Proxy :: Proxy (->)))
deriving instance Typeable ()
deriving instance Typeable []
deriving instance Typeable Maybe
deriving instance Typeable Ratio
deriving instance Typeable (->)
deriving instance Typeable IO
deriving instance Typeable Array
deriving instance Typeable ST
deriving instance Typeable STret
deriving instance Typeable STRef
deriving instance Typeable STArray
deriving instance Typeable (,)
deriving instance Typeable (,,)
deriving instance Typeable (,,,)
deriving instance Typeable (,,,,)
deriving instance Typeable (,,,,,)
deriving instance Typeable (,,,,,,)
deriving instance Typeable Ptr
deriving instance Typeable FunPtr
deriving instance Typeable Bool
deriving instance Typeable Char
deriving instance Typeable Float
deriving instance Typeable Double
deriving instance Typeable Int
deriving instance Typeable Word
deriving instance Typeable Integer
deriving instance Typeable Ordering
deriving instance Typeable Word8
deriving instance Typeable Word16
deriving instance Typeable Word32
deriving instance Typeable Word64
deriving instance Typeable TyCon
deriving instance Typeable TypeRep
deriving instance Typeable Fingerprint
deriving instance Typeable RealWorld
deriving instance Typeable Proxy
deriving instance Typeable KProxy
deriving instance Typeable (:~:)
deriving instance Typeable Coercion
deriving instance Typeable ReadP
deriving instance Typeable Lexeme
deriving instance Typeable Number
deriving instance Typeable ReadPrec
deriving instance Typeable FFFormat
deriving instance Typeable (~)
deriving instance Typeable Coercible
deriving instance Typeable TestEquality
deriving instance Typeable TestCoercion
deriving instance Typeable Eq
deriving instance Typeable Ord
deriving instance Typeable Bits
deriving instance Typeable FiniteBits
deriving instance Typeable Num
deriving instance Typeable Real
deriving instance Typeable Integral
deriving instance Typeable Fractional
deriving instance Typeable RealFrac
deriving instance Typeable Floating
deriving instance Typeable RealFloat
deriving instance Typeable Bounded
deriving instance Typeable Enum
deriving instance Typeable Ix
deriving instance Typeable Show
deriving instance Typeable Read
deriving instance Typeable Alternative
deriving instance Typeable Applicative
deriving instance Typeable Functor
deriving instance Typeable Monad
deriving instance Typeable MonadPlus
deriving instance Typeable Monoid
deriving instance Typeable Typeable
instance KnownNat n => Typeable (n :: Nat) where
typeRep# = \_ -> rep
where
rep = mkTyConApp tc []
tc = TyCon
{ tyConHash = fingerprintString (mk pack modu nm)
, tyConPackage = pack
, tyConModule = modu
, tyConName = nm
}
pack = "base"
modu = "GHC.TypeLits"
nm = show (natVal' (proxy# :: Proxy# n))
mk a b c = a ++ " " ++ b ++ " " ++ c
instance KnownSymbol s => Typeable (s :: Symbol) where
typeRep# = \_ -> rep
where
rep = mkTyConApp tc []
tc = TyCon
{ tyConHash = fingerprintString (mk pack modu nm)
, tyConPackage = pack
, tyConModule = modu
, tyConName = nm
}
pack = "base"
modu = "GHC.TypeLits"
nm = show (symbolVal' (proxy# :: Proxy# s))
mk a b c = a ++ " " ++ b ++ " " ++ c