#ifdef __GLASGOW_HASKELL__
#endif
module Data.Typeable.Internal (
TypeRep(..),
Fingerprint(..),
TyCon(..),
mkTyCon,
mkTyCon3,
mkTyConApp,
mkAppTy,
typeRepTyCon,
typeOfDefault,
typeOf1Default,
typeOf2Default,
typeOf3Default,
typeOf4Default,
typeOf5Default,
typeOf6Default,
Typeable(..),
Typeable1(..),
Typeable2(..),
Typeable3(..),
Typeable4(..),
Typeable5(..),
Typeable6(..),
Typeable7(..),
mkFunTy,
splitTyConApp,
funResultTy,
typeRepArgs,
showsTypeRep,
tyConString,
#if defined(__GLASGOW_HASKELL__)
listTc, funTc
#endif
) where
import GHC.Base
import GHC.Word
import GHC.Show
import GHC.Err (undefined)
import Data.Maybe
import Data.List
import GHC.Num
import GHC.Real
import GHC.IORef
import GHC.IOArray
import GHC.MVar
import GHC.ST ( ST )
import GHC.STRef ( STRef )
import GHC.Ptr ( Ptr, FunPtr )
import GHC.Stable
import GHC.Arr ( Array, STArray )
import Data.Int
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 (unwords [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
typeOf :: a -> TypeRep
class Typeable1 t where
typeOf1 :: t a -> TypeRep
#ifdef __GLASGOW_HASKELL__
typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
typeOfDefault = \_ -> rep
where
rep = typeOf1 (undefined :: t a) `mkAppTy`
typeOf (undefined :: a)
#else
typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep
typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x)
where
argType :: t a -> a
argType = undefined
#endif
class Typeable2 t where
typeOf2 :: t a b -> TypeRep
#ifdef __GLASGOW_HASKELL__
typeOf1Default :: forall t a b. (Typeable2 t, Typeable a) => t a b -> TypeRep
typeOf1Default = \_ -> rep
where
rep = typeOf2 (undefined :: t a b) `mkAppTy`
typeOf (undefined :: a)
#else
typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep
typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x)
where
argType :: t a b -> a
argType = undefined
#endif
class Typeable3 t where
typeOf3 :: t a b c -> TypeRep
#ifdef __GLASGOW_HASKELL__
typeOf2Default :: forall t a b c. (Typeable3 t, Typeable a) => t a b c -> TypeRep
typeOf2Default = \_ -> rep
where
rep = typeOf3 (undefined :: t a b c) `mkAppTy`
typeOf (undefined :: a)
#else
typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep
typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x)
where
argType :: t a b c -> a
argType = undefined
#endif
class Typeable4 t where
typeOf4 :: t a b c d -> TypeRep
#ifdef __GLASGOW_HASKELL__
typeOf3Default :: forall t a b c d. (Typeable4 t, Typeable a) => t a b c d -> TypeRep
typeOf3Default = \_ -> rep
where
rep = typeOf4 (undefined :: t a b c d) `mkAppTy`
typeOf (undefined :: a)
#else
typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep
typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x)
where
argType :: t a b c d -> a
argType = undefined
#endif
class Typeable5 t where
typeOf5 :: t a b c d e -> TypeRep
#ifdef __GLASGOW_HASKELL__
typeOf4Default :: forall t a b c d e. (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
typeOf4Default = \_ -> rep
where
rep = typeOf5 (undefined :: t a b c d e) `mkAppTy`
typeOf (undefined :: a)
#else
typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x)
where
argType :: t a b c d e -> a
argType = undefined
#endif
class Typeable6 t where
typeOf6 :: t a b c d e f -> TypeRep
#ifdef __GLASGOW_HASKELL__
typeOf5Default :: forall t a b c d e f. (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
typeOf5Default = \_ -> rep
where
rep = typeOf6 (undefined :: t a b c d e f) `mkAppTy`
typeOf (undefined :: a)
#else
typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x)
where
argType :: t a b c d e f -> a
argType = undefined
#endif
class Typeable7 t where
typeOf7 :: t a b c d e f g -> TypeRep
#ifdef __GLASGOW_HASKELL__
typeOf6Default :: forall t a b c d e f g. (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
typeOf6Default = \_ -> rep
where
rep = typeOf7 (undefined :: t a b c d e f g) `mkAppTy`
typeOf (undefined :: a)
#else
typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x)
where
argType :: t a b c d e f g -> a
argType = undefined
#endif
#ifdef __GLASGOW_HASKELL__
instance (Typeable1 s, Typeable a)
=> Typeable (s a) where
typeOf = typeOfDefault
instance (Typeable2 s, Typeable a)
=> Typeable1 (s a) where
typeOf1 = typeOf1Default
instance (Typeable3 s, Typeable a)
=> Typeable2 (s a) where
typeOf2 = typeOf2Default
instance (Typeable4 s, Typeable a)
=> Typeable3 (s a) where
typeOf3 = typeOf3Default
instance (Typeable5 s, Typeable a)
=> Typeable4 (s a) where
typeOf4 = typeOf4Default
instance (Typeable6 s, Typeable a)
=> Typeable5 (s a) where
typeOf5 = typeOf5Default
instance (Typeable7 s, Typeable a)
=> Typeable6 (s a) where
typeOf6 = typeOf6Default
#endif /* __GLASGOW_HASKELL__ */
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 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 => [a] -> ShowS
showArgs [] = id
showArgs [a] = showsPrec 10 a
showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
showTuple :: [TypeRep] -> ShowS
showTuple args = showChar '('
. (foldr (.) id $ intersperse (showChar ',')
$ map (showsPrec 10) args)
. showChar ')'
#if defined(__GLASGOW_HASKELL__)
listTc :: TyCon
listTc = typeRepTyCon (typeOf [()])
funTc :: TyCon
funTc = mkTyCon3 "ghc-prim" "GHC.Types" "->"
#endif
#include "Typeable.h"
INSTANCE_TYPEABLE0((),unitTc,"()")
INSTANCE_TYPEABLE1([],listTc,"[]")
INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
#if defined(__GLASGOW_HASKELL__)
instance Typeable2 (->) where { typeOf2 _ = mkTyConApp funTc [] }
#else
INSTANCE_TYPEABLE2((->),funTc,"->")
#endif
INSTANCE_TYPEABLE1(IO,ioTc,"IO")
#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
#endif
INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray")
#ifdef __GLASGOW_HASKELL__
INSTANCE_TYPEABLE2(ST,stTc,"ST")
INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")
INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray")
#endif
#ifndef __NHC__
INSTANCE_TYPEABLE2((,),pairTc,"(,)")
INSTANCE_TYPEABLE3((,,),tup3Tc,"(,,)")
INSTANCE_TYPEABLE4((,,,),tup4Tc,"(,,,)")
INSTANCE_TYPEABLE5((,,,,),tup5Tc,"(,,,,)")
INSTANCE_TYPEABLE6((,,,,,),tup6Tc,"(,,,,,)")
INSTANCE_TYPEABLE7((,,,,,,),tup7Tc,"(,,,,,,)")
#endif /* __NHC__ */
INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")
#ifndef __GLASGOW_HASKELL__
INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
#endif
INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")
INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
INSTANCE_TYPEABLE0(Char,charTc,"Char")
INSTANCE_TYPEABLE0(Float,floatTc,"Float")
INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
INSTANCE_TYPEABLE0(Int,intTc,"Int")
#ifndef __NHC__
INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
#endif
INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
#ifndef __GLASGOW_HASKELL__
INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
#endif
INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )
INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
#ifdef __GLASGOW_HASKELL__
realWorldTc :: TyCon; \
realWorldTc = mkTyCon3 "ghc-prim" "GHC.Types" "RealWorld"; \
instance Typeable RealWorld where { typeOf _ = mkTyConApp realWorldTc [] }
#endif
RetroSearch is an open source project built by @garambo | Open a GitHub Issue
Search and Browse the WWW like it's 1997 | Search results from DuckDuckGo
HTML:
3.2
| Encoding:
UTF-8
| Version:
0.7.4