{-# OPTIONS_GHC -fno-implicit-prelude -fallow-overlapping-instances #-} -- The -fallow-overlapping-instances flag allows the user to over-ride -- the instances for Typeable given here. In particular, we provide an instance -- instance ... => Typeable (s a) -- But a user might want to say -- instance ... => Typeable (MyType a b) ----------------------------------------------------------------------------- -- | -- Module : Data.Typeable -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable -- -- The 'Typeable' class reifies types to some extent by associating type -- representations to types. These type representations can be compared, -- and one can in turn define a type-safe cast operation. To this end, -- an unsafe cast is guarded by a test for type (representation) -- equivalence. The module "Data.Dynamic" uses Typeable for an -- implementation of dynamics. The module "Data.Generics" uses Typeable -- and type-safe cast (but not dynamics) to support the \"Scrap your -- boilerplate\" style of generic programming. -- ----------------------------------------------------------------------------- module Data.Typeable ( -- * The Typeable class Typeable( typeOf ), -- :: a -> TypeRep -- * Type-safe cast cast, -- :: (Typeable a, Typeable b) => a -> Maybe b gcast, -- a generalisation of cast -- * Type representations TypeRep, -- abstract, instance of: Eq, Show, Typeable TyCon, -- abstract, instance of: Eq, Show, Typeable -- * Construction of type representations mkTyCon, -- :: String -> TyCon mkTyConApp, -- :: TyCon -> [TypeRep] -> TypeRep mkAppTy, -- :: TypeRep -> TypeRep -> TypeRep mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep -- * Observation of type representations splitTyConApp, -- :: TypeRep -> (TyCon, [TypeRep]) funResultTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep typeRepTyCon, -- :: TypeRep -> TyCon typeRepArgs, -- :: TypeRep -> [TypeRep] tyConString, -- :: TyCon -> String -- * The other Typeable classes -- | /Note:/ The general instances are provided for GHC only. Typeable1( typeOf1 ), -- :: t a -> TypeRep Typeable2( typeOf2 ), -- :: t a b -> TypeRep Typeable3( typeOf3 ), -- :: t a b c -> TypeRep Typeable4( typeOf4 ), -- :: t a b c d -> TypeRep Typeable5( typeOf5 ), -- :: t a b c d e -> TypeRep Typeable6( typeOf6 ), -- :: t a b c d e f -> TypeRep Typeable7( typeOf7 ), -- :: t a b c d e f g -> TypeRep gcast1, -- :: ... => c (t a) -> Maybe (c (t' a)) gcast2, -- :: ... => c (t a b) -> Maybe (c (t' a b)) -- * Default instances -- | /Note:/ These are not needed by GHC, for which these instances -- are generated by general instance declarations. typeOfDefault, -- :: (Typeable1 t, Typeable a) => t a -> TypeRep typeOf1Default, -- :: (Typeable2 t, Typeable a) => t a b -> TypeRep typeOf2Default, -- :: (Typeable3 t, Typeable a) => t a b c -> TypeRep typeOf3Default, -- :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep typeOf4Default, -- :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep typeOf5Default, -- :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep typeOf6Default -- :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep ) where import qualified Data.HashTable as HT import Data.Maybe import Data.Either import Data.Int import Data.Word import Data.List( foldl ) import Hugs.Prelude ( Key(..), TypeRep(..), TyCon(..), Ratio, Exception, ArithException, IOException, ArrayException, AsyncException, Handle, Ptr, FunPtr, ForeignPtr, StablePtr ) import Hugs.IORef ( IORef, newIORef, readIORef, writeIORef ) import Hugs.IOExts ( unsafePerformIO, unsafeCoerce ) -- For the Typeable instance import Hugs.Array ( Array ) import Hugs.ConcBase ( MVar ) -- -- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,") -- [fTy,fTy,fTy]) -- -- returns "(Foo,Foo,Foo)" -- -- The TypeRep Show instance promises to print tuple types -- correctly. Tuple type constructors are specified by a -- sequence of commas, e.g., (mkTyCon ",,,,") returns -- the 5-tuple tycon. ----------------- Construction -------------------- -- | Applies a type constructor to a sequence of types mkTyConApp :: TyCon -> [TypeRep] -> TypeRep mkTyConApp tc@(TyCon tc_k _) args = TypeRep (appKeys 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 tr_k tc trs) arg_tr = let (TypeRep arg_k _ _) = arg_tr in TypeRep (appKey tr_k arg_k) tc (trs++[arg_tr]) -- If we enforce the restriction that there is only one -- @TyCon@ for a type & it is shared among all its uses, -- we can map them onto Ints very simply. The benefit is, -- of course, that @TyCon@s can then be compared efficiently. -- Provided the implementor of other @Typeable@ instances -- takes care of making all the @TyCon@s CAFs (toplevel constants), -- this will work. -- If this constraint does turn out to be a sore thumb, changing -- the Eq instance for TyCons is trivial. -- | Builds a 'TyCon' object representing a type constructor. An -- implementation of "Data.Typeable" should ensure that the following holds: -- -- > mkTyCon "a" == mkTyCon "a" -- mkTyCon :: String -- ^ the name of the type constructor (should be unique -- in the program, so it might be wise to use the -- fully qualified name). -> TyCon -- ^ A unique 'TyCon' object mkTyCon str = TyCon (mkTyConKey str) str ----------------- 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 tyConString :: TyCon -> String tyConString (TyCon _ str) = str ----------------- 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 tycon xs | otherwise -> showParen (p > 9) $ showsPrec p tycon . showChar ' ' . showArgs tys instance Show TyCon where showsPrec _ (TyCon _ s) = showString s 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 :: TyCon -> [TypeRep] -> ShowS showTuple (TyCon _ str) args = showChar '(' . go str args where go [] [a] = showsPrec 10 a . showChar ')' go _ [] = showChar ')' -- a failure condition, really. go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as go _ _ = showChar ')' ------------------------------------------------------------- -- -- The Typeable class and friends -- ------------------------------------------------------------- -- | 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 :: (Typeable1 t, Typeable a) => t a -> TypeRep typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x) where argType :: t a -> a argType = undefined -- | Variant for binary type constructors class Typeable2 t where typeOf2 :: t a b -> TypeRep -- | For defining a 'Typeable1' instance from any 'Typeable2' instance. 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 -- | 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 :: (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 -- | 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 :: (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 -- | 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 :: (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 -- | 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 :: (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 -- | 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 :: (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 ------------------------------------------------------------- -- -- Type-safe cast -- ------------------------------------------------------------- -- | The type-safe cast operation cast :: (Typeable a, Typeable b) => a -> Maybe b cast x = r where r = if typeOf x == typeOf (fromJust r) then Just $ unsafeCoerce x else Nothing -- | A flexible variation parameterised in a type constructor gcast :: (Typeable a, Typeable b) => c a -> Maybe (c b) gcast x = r where r = if typeOf (getArg x) == typeOf (getArg (fromJust r)) then Just $ unsafeCoerce x else Nothing getArg :: c x -> x getArg = undefined -- | Cast for * -> * gcast1 :: (Typeable1 t, Typeable1 t') => c (t a) -> Maybe (c (t' a)) gcast1 x = r where r = if typeOf1 (getArg x) == typeOf1 (getArg (fromJust r)) then Just $ unsafeCoerce x else Nothing getArg :: c x -> x getArg = undefined -- | Cast for * -> * -> * gcast2 :: (Typeable2 t, Typeable2 t') => c (t a b) -> Maybe (c (t' a b)) gcast2 x = r where r = if typeOf2 (getArg x) == typeOf2 (getArg (fromJust r)) then Just $ unsafeCoerce x else Nothing getArg :: c x -> x getArg = undefined ------------------------------------------------------------- -- -- Instances of the Typeable classes for Prelude types -- ------------------------------------------------------------- unitTc = mkTyCon "()"; instance Typeable () where { typeOf _ = mkTyConApp unitTc [] } listTc = mkTyCon "[]"; instance Typeable1 [] where { typeOf1 _ = mkTyConApp listTc [] }; instance Typeable a => Typeable ([] a) where { typeOf = typeOfDefault } maybeTc = mkTyCon "Maybe"; instance Typeable1 Maybe where { typeOf1 _ = mkTyConApp maybeTc [] }; instance Typeable a => Typeable (Maybe a) where { typeOf = typeOfDefault } ratioTc = mkTyCon "Ratio"; instance Typeable1 Ratio where { typeOf1 _ = mkTyConApp ratioTc [] }; instance Typeable a => Typeable (Ratio a) where { typeOf = typeOfDefault } eitherTc = mkTyCon "Either"; instance Typeable2 Either where { typeOf2 _ = mkTyConApp eitherTc [] }; instance Typeable a => Typeable1 (Either a) where { typeOf1 = typeOf1Default }; instance (Typeable a, Typeable b) => Typeable (Either a b) where { typeOf = typeOfDefault } funTc = mkTyCon "->"; instance Typeable2 (->) where { typeOf2 _ = mkTyConApp funTc [] }; instance Typeable a => Typeable1 ((->) a) where { typeOf1 = typeOf1Default }; instance (Typeable a, Typeable b) => Typeable ((->) a b) where { typeOf = typeOfDefault } ioTc = mkTyCon "IO"; instance Typeable1 IO where { typeOf1 _ = mkTyConApp ioTc [] }; instance Typeable a => Typeable (IO a) where { typeOf = typeOfDefault } -- Types defined in GHC.IOBase mvarTc = mkTyCon "MVar"; instance Typeable1 MVar where { typeOf1 _ = mkTyConApp mvarTc [] }; instance Typeable a => Typeable (MVar a) where { typeOf = typeOfDefault } exceptionTc = mkTyCon "Exception"; instance Typeable Exception where { typeOf _ = mkTyConApp exceptionTc [] } ioExceptionTc = mkTyCon "IOException"; instance Typeable IOException where { typeOf _ = mkTyConApp ioExceptionTc [] } arithExceptionTc = mkTyCon "ArithException"; instance Typeable ArithException where { typeOf _ = mkTyConApp arithExceptionTc [] } arrayExceptionTc = mkTyCon "ArrayException"; instance Typeable ArrayException where { typeOf _ = mkTyConApp arrayExceptionTc [] } asyncExceptionTc = mkTyCon "AsyncException"; instance Typeable AsyncException where { typeOf _ = mkTyConApp asyncExceptionTc [] } -- Types defined in GHC.Arr arrayTc = mkTyCon "Array"; instance Typeable2 Array where { typeOf2 _ = mkTyConApp arrayTc [] }; instance Typeable a => Typeable1 (Array a) where { typeOf1 = typeOf1Default }; instance (Typeable a, Typeable b) => Typeable (Array a b) where { typeOf = typeOfDefault } pairTc = mkTyCon ","; instance Typeable2 (,) where { typeOf2 _ = mkTyConApp pairTc [] }; instance Typeable a => Typeable1 ((,) a) where { typeOf1 = typeOf1Default }; instance (Typeable a, Typeable b) => Typeable ((,) a b) where { typeOf = typeOfDefault } tup3Tc = mkTyCon ",,"; instance Typeable3 (,,) where { typeOf3 _ = mkTyConApp tup3Tc [] }; instance Typeable a => Typeable2 ((,,) a) where { typeOf2 = typeOf2Default }; instance (Typeable a, Typeable b) => Typeable1 ((,,) a b) where { typeOf1 = typeOf1Default }; instance (Typeable a, Typeable b, Typeable c) => Typeable ((,,) a b c) where { typeOf = typeOfDefault } tup4Tc :: TyCon tup4Tc = mkTyCon ",,," instance Typeable4 (,,,) where typeOf4 tu = mkTyConApp tup4Tc [] tup5Tc :: TyCon tup5Tc = mkTyCon ",,,," instance Typeable5 (,,,,) where typeOf5 tu = mkTyConApp tup5Tc [] tup6Tc :: TyCon tup6Tc = mkTyCon ",,,,," instance Typeable6 (,,,,,) where typeOf6 tu = mkTyConApp tup6Tc [] tup7Tc :: TyCon tup7Tc = mkTyCon ",,,,,," instance Typeable7 (,,,,,,) where typeOf7 tu = mkTyConApp tup7Tc [] ptrTc = mkTyCon "Ptr"; instance Typeable1 Ptr where { typeOf1 _ = mkTyConApp ptrTc [] }; instance Typeable a => Typeable (Ptr a) where { typeOf = typeOfDefault } funPtrTc = mkTyCon "FunPtr"; instance Typeable1 FunPtr where { typeOf1 _ = mkTyConApp funPtrTc [] }; instance Typeable a => Typeable (FunPtr a) where { typeOf = typeOfDefault } foreignPtrTc = mkTyCon "ForeignPtr"; instance Typeable1 ForeignPtr where { typeOf1 _ = mkTyConApp foreignPtrTc [] }; instance Typeable a => Typeable (ForeignPtr a) where { typeOf = typeOfDefault } stablePtrTc = mkTyCon "StablePtr"; instance Typeable1 StablePtr where { typeOf1 _ = mkTyConApp stablePtrTc [] }; instance Typeable a => Typeable (StablePtr a) where { typeOf = typeOfDefault } iORefTc = mkTyCon "IORef"; instance Typeable1 IORef where { typeOf1 _ = mkTyConApp iORefTc [] }; instance Typeable a => Typeable (IORef a) where { typeOf = typeOfDefault } ------------------------------------------------------- -- -- Generate Typeable instances for standard datatypes -- ------------------------------------------------------- boolTc = mkTyCon "Bool"; instance Typeable Bool where { typeOf _ = mkTyConApp boolTc [] } charTc = mkTyCon "Char"; instance Typeable Char where { typeOf _ = mkTyConApp charTc [] } floatTc = mkTyCon "Float"; instance Typeable Float where { typeOf _ = mkTyConApp floatTc [] } doubleTc = mkTyCon "Double"; instance Typeable Double where { typeOf _ = mkTyConApp doubleTc [] } intTc = mkTyCon "Int"; instance Typeable Int where { typeOf _ = mkTyConApp intTc [] } wordTc = mkTyCon "Word"; instance Typeable Word where { typeOf _ = mkTyConApp wordTc [] } integerTc = mkTyCon "Integer"; instance Typeable Integer where { typeOf _ = mkTyConApp integerTc [] } orderingTc = mkTyCon "Ordering"; instance Typeable Ordering where { typeOf _ = mkTyConApp orderingTc [] } handleTc = mkTyCon "Handle"; instance Typeable Handle where { typeOf _ = mkTyConApp handleTc [] } int8Tc = mkTyCon "Int8"; instance Typeable Int8 where { typeOf _ = mkTyConApp int8Tc [] } int16Tc = mkTyCon "Int16"; instance Typeable Int16 where { typeOf _ = mkTyConApp int16Tc [] } int32Tc = mkTyCon "Int32"; instance Typeable Int32 where { typeOf _ = mkTyConApp int32Tc [] } int64Tc = mkTyCon "Int64"; instance Typeable Int64 where { typeOf _ = mkTyConApp int64Tc [] } word8Tc = mkTyCon "Word8"; instance Typeable Word8 where { typeOf _ = mkTyConApp word8Tc [] } word16Tc = mkTyCon "Word16"; instance Typeable Word16 where { typeOf _ = mkTyConApp word16Tc [] } word32Tc = mkTyCon "Word32"; instance Typeable Word32 where { typeOf _ = mkTyConApp word32Tc [] } word64Tc = mkTyCon "Word64"; instance Typeable Word64 where { typeOf _ = mkTyConApp word64Tc [] } tyconTc = mkTyCon "TyCon"; instance Typeable TyCon where { typeOf _ = mkTyConApp tyconTc [] } typeRepTc = mkTyCon "TypeRep"; instance Typeable TypeRep where { typeOf _ = mkTyConApp typeRepTc [] } --------------------------------------------- -- -- Internals -- --------------------------------------------- data KeyPr = KeyPr !Key !Key deriving( Eq ) hashKP :: KeyPr -> Int32 hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime data Cache = Cache { next_key :: !(IORef Key), -- Not used by GHC (calls genSym instead) tc_tbl :: !(HT.HashTable String Key), ap_tbl :: !(HT.HashTable KeyPr Key) } {-# NOINLINE cache #-} cache :: Cache cache = unsafePerformIO $ do empty_tc_tbl <- HT.new (==) HT.hashString empty_ap_tbl <- HT.new (==) hashKP key_loc <- newIORef (Key 1) let ret = Cache { next_key = key_loc, tc_tbl = empty_tc_tbl, ap_tbl = empty_ap_tbl } return ret newKey :: IORef Key -> IO Key newKey kloc = do { k@(Key i) <- readIORef kloc ; writeIORef kloc (Key (i+1)) ; return k } mkTyConKey :: String -> Key mkTyConKey str = unsafePerformIO $ do let Cache {next_key = kloc, tc_tbl = tbl} = cache mb_k <- HT.lookup tbl str case mb_k of Just k -> return k Nothing -> do { k <- newKey kloc ; HT.insert tbl str k ; return k } appKey :: Key -> Key -> Key appKey k1 k2 = unsafePerformIO $ do let Cache {next_key = kloc, ap_tbl = tbl} = cache mb_k <- HT.lookup tbl kpr case mb_k of Just k -> return k Nothing -> do { k <- newKey kloc ; HT.insert tbl kpr k ; return k } where kpr = KeyPr k1 k2 appKeys :: Key -> [Key] -> Key appKeys k ks = foldl appKey k ks
(HTML for this module was generated on 2009-01-04. About the conversion tool.)