{-# LANGUAGE Unsafe #-}------------------------------------------------------------------------------- |-- Module : Data.Typeable.Internal-- Copyright : (c) The University of Glasgow, CWI 2001--2011-- License : BSD-style (see the file libraries/base/LICENSE)-- -- The representations of the types TyCon and TypeRep, and the-- function mkTyCon which is used by derived instances of Typeable to-- construct a TyCon.-------------------------------------------------------------------------------{-# LANGUAGE CPP
, NoImplicitPrelude
, OverlappingInstances
, ScopedTypeVariables
, FlexibleInstances
, MagicHash #-}#ifdef __GLASGOW_HASKELL__{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}#endifmoduleData.Typeable.Internal(TypeRep(..),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)whereimportGHC.BaseimportGHC.WordimportGHC.ShowimportGHC.Err(undefined)importData.MaybeimportData.ListimportGHC.NumimportGHC.RealimportGHC.IORefimportGHC.IOArrayimportGHC.MVarimportGHC.ST(ST)importGHC.STRef(STRef)importGHC.Ptr(Ptr,FunPtr)importGHC.StableimportGHC.Arr(Array,STArray)importData.IntimportGHC.Fingerprint.Typeimport{-# SOURCE #-}GHC.Fingerprint-- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable-- Better to break the loop here, because we want non-SOURCE imports-- of Data.Typeable as much as possible so we can optimise the derived-- instances.-- | A concrete representation of a (monomorphic) type. 'TypeRep'-- supports reasonably efficient equality.dataTypeRep=TypeRep{-# UNPACK #-}!FingerprintTyCon[TypeRep]-- Compare keys for equalityinstanceEqTypeRepwhere(TypeRepk1__)==(TypeRepk2__)=k1==k2instanceOrdTypeRepwhere(TypeRepk1__)<=(TypeRepk2__)=k1<=k2-- | An abstract representation of a type constructor. 'TyCon' objects can-- be built using 'mkTyCon'.dataTyCon=TyCon{tyConHash::{-# UNPACK #-}!Fingerprint,tyConPackage::String,tyConModule::String,tyConName::String}instanceEqTyConwhere(TyCont1___)==(TyCont2___)=t1==t2instanceOrdTyConwhere(TyConk1___)<=(TyConk2___)=k1<=k2----------------- Construction --------------------#include "MachDeps.h"-- mkTyCon is an internal function to make it easier for GHC to-- generate derived instances. GHC precomputes the MD5 hash for the-- TyCon and passes it as two separate 64-bit values to mkTyCon. The-- TyCon for a derived Typeable instance will end up being statically-- allocated.#if WORD_SIZE_IN_BITS < 64mkTyCon::Word64#->Word64#->String->String->String->TyCon#elsemkTyCon::Word#->Word#->String->String->String->TyCon#endifmkTyConhigh#low#pkgmodlname=TyCon(Fingerprint(W64#high#)(W64#low#))pkgmodlname-- | Applies a type constructor to a sequence of typesmkTyConApp::TyCon->[TypeRep]->TypeRepmkTyConApptc@(TyContc_k___)[]=TypeReptc_ktc[]-- optimisation: all derived Typeable instances-- end up here, and it helps generate smaller-- code for derived Typeable.mkTyConApptc@(TyContc_k___)args=TypeRep(fingerprintFingerprints(tc_k:arg_ks))tcargswherearg_ks=[k|TypeRepk__<-args]-- | A special case of 'mkTyConApp', which applies the function -- type constructor to a pair of types.mkFunTy::TypeRep->TypeRep->TypeRepmkFunTyfa=mkTyConAppfunTc[f,a]-- | Splits a type constructor applicationsplitTyConApp::TypeRep->(TyCon,[TypeRep])splitTyConApp(TypeRep_tctrs)=(tc,trs)-- | Applies a type to a function type. Returns: @'Just' u@ if the-- first argument represents a function of type @t -> u@ and the-- second argument represents a function of type @t@. Otherwise,-- returns 'Nothing'.funResultTy::TypeRep->TypeRep->MaybeTypeRepfunResultTytrFuntrArg=casesplitTyConApptrFunof(tc,[t1,t2])|tc==funTc&&t1==trArg->Justt2_->Nothing-- | Adds a TypeRep argument to a TypeRep.mkAppTy::TypeRep->TypeRep->TypeRepmkAppTy(TypeReptr_ktctrs)arg_tr=let(TypeReparg_k__)=arg_trinTypeRep(fingerprintFingerprints[tr_k,arg_k])tc(trs++[arg_tr])-- | Builds a 'TyCon' object representing a type constructor. An-- implementation of "Data.Typeable" should ensure that the following holds:---- > A==A' ^ B==B' ^ C==C' ==> mkTyCon A B C == mkTyCon A' B' C'----mkTyCon3::String-- ^ package name->String-- ^ module name->String-- ^ the name of the type constructor->TyCon-- ^ A unique 'TyCon' objectmkTyCon3pkgmodlname=TyCon(fingerprintString(unwords[pkg,modl,name]))pkgmodlname----------------- Observation ----------------------- | Observe the type constructor of a type representationtypeRepTyCon::TypeRep->TyContypeRepTyCon(TypeRep_tc_)=tc-- | Observe the argument types of a type representationtypeRepArgs::TypeRep->[TypeRep]typeRepArgs(TypeRep__args)=args-- | Observe string encoding of a type representation{-# DEPRECATED tyConString "renamed to tyConName; tyConModule and tyConPackage are also available." #-}tyConString::TyCon->StringtyConString=tyConName----------------------------------------------------------------- The Typeable class and friends---------------------------------------------------------------{- Note [Memoising typeOf]
~~~~~~~~~~~~~~~~~~~~~~~~~~
IMPORTANT: we don't want to recalculate the type-rep once per
call to the dummy argument. This is what went wrong in Trac #3245
So we help GHC by manually keeping the 'rep' *outside* the value
lambda, thus
typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
typeOfDefault = \_ -> rep
where
rep = typeOf1 (undefined :: t a) `mkAppTy`
typeOf (undefined :: a)
Notice the crucial use of scoped type variables here!
-}-- | The class 'Typeable' allows a concrete representation of a type to-- be calculated.classTypeableawheretypeOf::a->TypeRep-- ^ Takes a value of type @a@ and returns a concrete representation-- of that type. The /value/ of the argument should be ignored by-- any instance of 'Typeable', so that it is safe to pass 'undefined' as-- the argument.-- | Variant for unary type constructorsclassTypeable1twheretypeOf1::ta->TypeRep#ifdef __GLASGOW_HASKELL__-- | For defining a 'Typeable' instance from any 'Typeable1' instance.typeOfDefault::forallta.(Typeable1t,Typeablea)=>ta->TypeReptypeOfDefault=\_->repwhererep=typeOf1(undefined::ta)`mkAppTy`typeOf(undefined::a)-- Note [Memoising typeOf]#else-- | For defining a 'Typeable' instance from any 'Typeable1' instance.typeOfDefault::(Typeable1t,Typeablea)=>ta->TypeReptypeOfDefaultx=typeOf1x`mkAppTy`typeOf(argTypex)whereargType::ta->aargType=undefined#endif-- | Variant for binary type constructorsclassTypeable2twheretypeOf2::tab->TypeRep#ifdef __GLASGOW_HASKELL__-- | For defining a 'Typeable1' instance from any 'Typeable2' instance.typeOf1Default::foralltab.(Typeable2t,Typeablea)=>tab->TypeReptypeOf1Default=\_->repwhererep=typeOf2(undefined::tab)`mkAppTy`typeOf(undefined::a)-- Note [Memoising typeOf]#else-- | For defining a 'Typeable1' instance from any 'Typeable2' instance.typeOf1Default::(Typeable2t,Typeablea)=>tab->TypeReptypeOf1Defaultx=typeOf2x`mkAppTy`typeOf(argTypex)whereargType::tab->aargType=undefined#endif-- | Variant for 3-ary type constructorsclassTypeable3twheretypeOf3::tabc->TypeRep#ifdef __GLASGOW_HASKELL__-- | For defining a 'Typeable2' instance from any 'Typeable3' instance.typeOf2Default::foralltabc.(Typeable3t,Typeablea)=>tabc->TypeReptypeOf2Default=\_->repwhererep=typeOf3(undefined::tabc)`mkAppTy`typeOf(undefined::a)-- Note [Memoising typeOf]#else-- | For defining a 'Typeable2' instance from any 'Typeable3' instance.typeOf2Default::(Typeable3t,Typeablea)=>tabc->TypeReptypeOf2Defaultx=typeOf3x`mkAppTy`typeOf(argTypex)whereargType::tabc->aargType=undefined#endif-- | Variant for 4-ary type constructorsclassTypeable4twheretypeOf4::tabcd->TypeRep#ifdef __GLASGOW_HASKELL__-- | For defining a 'Typeable3' instance from any 'Typeable4' instance.typeOf3Default::foralltabcd.(Typeable4t,Typeablea)=>tabcd->TypeReptypeOf3Default=\_->repwhererep=typeOf4(undefined::tabcd)`mkAppTy`typeOf(undefined::a)-- Note [Memoising typeOf]#else-- | For defining a 'Typeable3' instance from any 'Typeable4' instance.typeOf3Default::(Typeable4t,Typeablea)=>tabcd->TypeReptypeOf3Defaultx=typeOf4x`mkAppTy`typeOf(argTypex)whereargType::tabcd->aargType=undefined#endif-- | Variant for 5-ary type constructorsclassTypeable5twheretypeOf5::tabcde->TypeRep#ifdef __GLASGOW_HASKELL__-- | For defining a 'Typeable4' instance from any 'Typeable5' instance.typeOf4Default::foralltabcde.(Typeable5t,Typeablea)=>tabcde->TypeReptypeOf4Default=\_->repwhererep=typeOf5(undefined::tabcde)`mkAppTy`typeOf(undefined::a)-- Note [Memoising typeOf]#else-- | For defining a 'Typeable4' instance from any 'Typeable5' instance.typeOf4Default::(Typeable5t,Typeablea)=>tabcde->TypeReptypeOf4Defaultx=typeOf5x`mkAppTy`typeOf(argTypex)whereargType::tabcde->aargType=undefined#endif-- | Variant for 6-ary type constructorsclassTypeable6twheretypeOf6::tabcdef->TypeRep#ifdef __GLASGOW_HASKELL__-- | For defining a 'Typeable5' instance from any 'Typeable6' instance.typeOf5Default::foralltabcdef.(Typeable6t,Typeablea)=>tabcdef->TypeReptypeOf5Default=\_->repwhererep=typeOf6(undefined::tabcdef)`mkAppTy`typeOf(undefined::a)-- Note [Memoising typeOf]#else-- | For defining a 'Typeable5' instance from any 'Typeable6' instance.typeOf5Default::(Typeable6t,Typeablea)=>tabcdef->TypeReptypeOf5Defaultx=typeOf6x`mkAppTy`typeOf(argTypex)whereargType::tabcdef->aargType=undefined#endif-- | Variant for 7-ary type constructorsclassTypeable7twheretypeOf7::tabcdefg->TypeRep#ifdef __GLASGOW_HASKELL__-- | For defining a 'Typeable6' instance from any 'Typeable7' instance.typeOf6Default::foralltabcdefg.(Typeable7t,Typeablea)=>tabcdefg->TypeReptypeOf6Default=\_->repwhererep=typeOf7(undefined::tabcdefg)`mkAppTy`typeOf(undefined::a)-- Note [Memoising typeOf]#else-- | For defining a 'Typeable6' instance from any 'Typeable7' instance.typeOf6Default::(Typeable7t,Typeablea)=>tabcdefg->TypeReptypeOf6Defaultx=typeOf7x`mkAppTy`typeOf(argTypex)whereargType::tabcdefg->aargType=undefined#endif#ifdef __GLASGOW_HASKELL__-- Given a @Typeable@/n/ instance for an /n/-ary type constructor,-- define the instances for partial applications.-- Programmers using non-GHC implementations must do this manually-- for each type constructor.-- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.)-- | One Typeable instance for all Typeable1 instancesinstance(Typeable1s,Typeablea)=>Typeable(sa)wheretypeOf=typeOfDefault-- | One Typeable1 instance for all Typeable2 instancesinstance(Typeable2s,Typeablea)=>Typeable1(sa)wheretypeOf1=typeOf1Default-- | One Typeable2 instance for all Typeable3 instancesinstance(Typeable3s,Typeablea)=>Typeable2(sa)wheretypeOf2=typeOf2Default-- | One Typeable3 instance for all Typeable4 instancesinstance(Typeable4s,Typeablea)=>Typeable3(sa)wheretypeOf3=typeOf3Default-- | One Typeable4 instance for all Typeable5 instancesinstance(Typeable5s,Typeablea)=>Typeable4(sa)wheretypeOf4=typeOf4Default-- | One Typeable5 instance for all Typeable6 instancesinstance(Typeable6s,Typeablea)=>Typeable5(sa)wheretypeOf5=typeOf5Default-- | One Typeable6 instance for all Typeable7 instancesinstance(Typeable7s,Typeablea)=>Typeable6(sa)wheretypeOf6=typeOf6Default#endif /* __GLASGOW_HASKELL__ */----------------- Showing TypeReps --------------------instanceShowTypeRepwhereshowsPrecp(TypeRep_tycontys)=casetysof[]->showsPrecptycon[x]|tycon==listTc->showChar'['.showsx.showChar']'[a,r]|tycon==funTc->showParen(p>8)$showsPrec9a.showString" -> ".showsPrec8rxs|isTupleTyContycon->showTuplexs|otherwise->showParen(p>9)$showsPrecptycon.showChar' '.showArgstysshowsTypeRep::TypeRep->ShowSshowsTypeRep=showsinstanceShowTyConwhereshowsPrec_t=showString(tyConNamet)isTupleTyCon::TyCon->BoolisTupleTyCon(TyCon___('(':',':_))=TrueisTupleTyCon_=False-- Some (Show.TypeRep) helpers:showArgs::Showa=>[a]->ShowSshowArgs[]=idshowArgs[a]=showsPrec10ashowArgs(a:as)=showsPrec10a.showString" ".showArgsasshowTuple::[TypeRep]->ShowSshowTupleargs=showChar'('.(foldr(.)id$intersperse(showChar',')$map(showsPrec10)args).showChar')'#if defined(__GLASGOW_HASKELL__)listTc::TyConlistTc=typeRepTyCon(typeOf[()])funTc::TyConfunTc=mkTyCon3"ghc-prim""GHC.Types""->"#endif----------------------------------------------------------------- Instances of the Typeable classes for Prelude types---------------------------------------------------------------#include "Typeable.h"INSTANCE_TYPEABLE0((),unitTc,"()")INSTANCE_TYPEABLE1([],listTc,"[]")INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")#if defined(__GLASGOW_HASKELL__){-
TODO: Deriving this instance fails with:
libraries/base/Data/Typeable.hs:589:1:
Can't make a derived instance of `Typeable2 (->)':
The last argument of the instance must be a data or newtype application
In the stand-alone deriving instance for `Typeable2 (->)'
-}instanceTypeable2(->)where{typeOf2_=mkTyConAppfunTc[]}#elseINSTANCE_TYPEABLE2((->),funTc,"->")#endifINSTANCE_TYPEABLE1(IO,ioTc,"IO")#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)-- Types defined in GHC.MVarINSTANCE_TYPEABLE1(MVar,mvarTc,"MVar")#endifINSTANCE_TYPEABLE2(Array,arrayTc,"Array")INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray")#ifdef __GLASGOW_HASKELL__-- Hugs has these too, but their Typeable<n> instances are defined-- elsewhere to keep this module within Haskell 98.-- This is important because every invocation of runhugs or ffihugs-- uses this module via Data.Dynamic.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")#endifINSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")----------------------------------------------------------- Generate Typeable instances for standard datatypes---------------------------------------------------------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")#endifINSTANCE_TYPEABLE0(Integer,integerTc,"Integer")INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")#ifndef __GLASGOW_HASKELL__INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")#endifINSTANCE_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__{-
TODO: This can't be derived currently:
libraries/base/Data/Typeable.hs:674:1:
Can't make a derived instance of `Typeable RealWorld':
The last argument of the instance must be a data or newtype application
In the stand-alone deriving instance for `Typeable RealWorld'
-}realWorldTc::TyCon;\realWorldTc=mkTyCon3"ghc-prim""GHC.Types""RealWorld";\instanceTypeableRealWorldwhere{typeOf_=mkTyConApprealWorldTc[]}#endif