diff options
Diffstat (limited to 'libraries/base/Data/OldTypeable/Internal.hs')
| -rw-r--r-- | libraries/base/Data/OldTypeable/Internal.hs | 475 |
1 files changed, 475 insertions, 0 deletions
diff --git a/libraries/base/Data/OldTypeable/Internal.hs b/libraries/base/Data/OldTypeable/Internal.hs new file mode 100644 index 0000000000..2b02930466 --- /dev/null +++ b/libraries/base/Data/OldTypeable/Internal.hs @@ -0,0 +1,475 @@ +{-# 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. +-- +-- /Since: 4.7.0.0/ +----------------------------------------------------------------------------- + +{-# LANGUAGE CPP + , NoImplicitPrelude + , OverlappingInstances + , ScopedTypeVariables + , FlexibleInstances + , MagicHash + , DeriveDataTypeable + , StandaloneDeriving #-} + +module Data.OldTypeable.Internal {-# DEPRECATED "Use Data.Typeable.Internal instead" #-} ( -- deprecated in 7.8 + 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, + listTc, funTc + ) where + +import GHC.Base +import GHC.Word +import GHC.Show +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 + +-- | A concrete representation of a (monomorphic) type. 'TypeRep' +-- supports reasonably efficient equality. +data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [TypeRep] + +-- Compare keys for equality +instance Eq TypeRep where + (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2 + +instance Ord TypeRep where + (TypeRep k1 _ _) <= (TypeRep k2 _ _) = k1 <= k2 + +-- | An abstract representation of a type constructor. 'TyCon' objects can +-- be built using 'mkTyCon'. +data TyCon = TyCon { + tyConHash :: {-# UNPACK #-} !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 + +----------------- 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 < 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 + +-- | Applies a type constructor to a sequence of types +mkTyConApp :: TyCon -> [TypeRep] -> TypeRep +mkTyConApp tc@(TyCon tc_k _ _ _) [] + = TypeRep tc_k tc [] -- optimisation: all derived Typeable instances + -- end up here, and it helps generate smaller + -- code for derived Typeable. +mkTyConApp tc@(TyCon tc_k _ _ _) args + = TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc args + where + arg_ks = [k | TypeRep k _ _ <- args] + +-- | A special case of 'mkTyConApp', which applies the function +-- type constructor to a pair of types. +mkFunTy :: TypeRep -> TypeRep -> TypeRep +mkFunTy f a = mkTyConApp funTc [f,a] + +-- | Splits a type constructor application +splitTyConApp :: TypeRep -> (TyCon,[TypeRep]) +splitTyConApp (TypeRep _ tc trs) = (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 -> Maybe TypeRep +funResultTy trFun trArg + = case splitTyConApp trFun of + (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2 + _ -> Nothing + +-- | Adds a TypeRep argument to a TypeRep. +mkAppTy :: TypeRep -> TypeRep -> TypeRep +mkAppTy (TypeRep _ tc trs) arg_tr = mkTyConApp tc (trs ++ [arg_tr]) + -- Notice that we call mkTyConApp to construct the fingerprint from tc and + -- the arg fingerprints. Simply combining the current fingerprint with + -- the new one won't give the same answer, but of course we want to + -- ensure that a TypeRep of the same shape has the same fingerprint! + -- See Trac #5962 + +-- | 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' object +mkTyCon3 pkg modl name = + TyCon (fingerprintString (unwords [pkg, modl, name])) pkg modl name + +----------------- Observation --------------------- + +-- | Observe the type constructor of a type representation +typeRepTyCon :: TypeRep -> TyCon +typeRepTyCon (TypeRep _ tc _) = tc + +-- | Observe the argument types of a type representation +typeRepArgs :: TypeRep -> [TypeRep] +typeRepArgs (TypeRep _ _ args) = args + +-- | Observe string encoding of a type representation +{-# DEPRECATED tyConString "renamed to tyConName; tyConModule and tyConPackage are also available." #-} -- deprecated in 7.4 +tyConString :: TyCon -> String +tyConString = 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. +class Typeable a where + typeOf :: 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 constructors +class Typeable1 t where + typeOf1 :: t a -> TypeRep + +-- | For defining a 'Typeable' instance from any 'Typeable1' instance. +typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep +typeOfDefault = \_ -> rep + where + rep = typeOf1 (undefined :: t a) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] + +-- | Variant for binary type constructors +class Typeable2 t where + typeOf2 :: t a b -> TypeRep + +-- | For defining a 'Typeable1' instance from any 'Typeable2' instance. +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) + -- Note [Memoising typeOf] + +-- | Variant for 3-ary type constructors +class Typeable3 t where + typeOf3 :: t a b c -> TypeRep + +-- | For defining a 'Typeable2' instance from any 'Typeable3' instance. +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) + -- Note [Memoising typeOf] + +-- | Variant for 4-ary type constructors +class Typeable4 t where + typeOf4 :: t a b c d -> TypeRep + +-- | For defining a 'Typeable3' instance from any 'Typeable4' instance. +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) + -- Note [Memoising typeOf] + +-- | Variant for 5-ary type constructors +class Typeable5 t where + typeOf5 :: t a b c d e -> TypeRep + +-- | For defining a 'Typeable4' instance from any 'Typeable5' instance. +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) + -- Note [Memoising typeOf] + +-- | Variant for 6-ary type constructors +class Typeable6 t where + typeOf6 :: t a b c d e f -> TypeRep + +-- | For defining a 'Typeable5' instance from any 'Typeable6' instance. +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) + -- Note [Memoising typeOf] + +-- | Variant for 7-ary type constructors +class Typeable7 t where + typeOf7 :: t a b c d e f g -> TypeRep + +-- | For defining a 'Typeable6' instance from any 'Typeable7' instance. +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) + -- Note [Memoising typeOf] + +-- 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 instances +instance (Typeable1 s, Typeable a) + => Typeable (s a) where + typeOf = typeOfDefault + +-- | One Typeable1 instance for all Typeable2 instances +instance (Typeable2 s, Typeable a) + => Typeable1 (s a) where + typeOf1 = typeOf1Default + +-- | One Typeable2 instance for all Typeable3 instances +instance (Typeable3 s, Typeable a) + => Typeable2 (s a) where + typeOf2 = typeOf2Default + +-- | One Typeable3 instance for all Typeable4 instances +instance (Typeable4 s, Typeable a) + => Typeable3 (s a) where + typeOf3 = typeOf3Default + +-- | One Typeable4 instance for all Typeable5 instances +instance (Typeable5 s, Typeable a) + => Typeable4 (s a) where + typeOf4 = typeOf4Default + +-- | One Typeable5 instance for all Typeable6 instances +instance (Typeable6 s, Typeable a) + => Typeable5 (s a) where + typeOf5 = typeOf5Default + +-- | One Typeable6 instance for all Typeable7 instances +instance (Typeable7 s, Typeable a) + => Typeable6 (s a) where + typeOf6 = typeOf6Default + +----------------- Showing TypeReps -------------------- + +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 + +-- Some (Show.TypeRep) helpers: + +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 ')' + +listTc :: TyCon +listTc = typeRepTyCon (typeOf [()]) + +funTc :: TyCon +funTc = mkTyCon3 "ghc-prim" "GHC.Types" "->" + +------------------------------------------------------------- +-- +-- Instances of the Typeable classes for Prelude types +-- +------------------------------------------------------------- + +#include "OldTypeable.h" + +INSTANCE_TYPEABLE0((),unitTc,"()") +INSTANCE_TYPEABLE1([],listTc,"[]") +INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe") +INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio") + +{- +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 (->)' +-} +instance Typeable2 (->) where { typeOf2 _ = mkTyConApp funTc [] } + +INSTANCE_TYPEABLE1(IO,ioTc,"IO") + +-- Types defined in GHC.MVar +INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" ) + +INSTANCE_TYPEABLE2(Array,arrayTc,"Array") +INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray") + +INSTANCE_TYPEABLE2(ST,stTc,"ST") +INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef") +INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray") + +INSTANCE_TYPEABLE2((,),pairTc,"(,)") +INSTANCE_TYPEABLE3((,,),tup3Tc,"(,,)") +INSTANCE_TYPEABLE4((,,,),tup4Tc,"(,,,)") +INSTANCE_TYPEABLE5((,,,,),tup5Tc,"(,,,,)") +INSTANCE_TYPEABLE6((,,,,,),tup6Tc,"(,,,,,)") +INSTANCE_TYPEABLE7((,,,,,,),tup7Tc,"(,,,,,,)") + +INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr") +INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr") +INSTANCE_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") +INSTANCE_TYPEABLE0(Word,wordTc,"Word" ) +INSTANCE_TYPEABLE0(Integer,integerTc,"Integer") +INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering") + +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") + +{- +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"; \ +instance Typeable RealWorld where { typeOf _ = mkTyConApp realWorldTc [] } |