plugins-1.0: src/AltData/Typeable.hs
{-# OPTIONS -fglasgow-exts #-}
--
-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
-- USA
--
-- Based on:
--
-- |
-- 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 AltData.Typeable
#if __GLASGOW_HASKELL__ >= 603
(
-- * 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 GHC.Base
import GHC.Show
import GHC.Err
import GHC.Num
import GHC.Float
import GHC.Real( rem, Ratio )
import GHC.IOBase
import GHC.Ptr -- So we can give Typeable instance for Ptr
import GHC.Stable -- So we can give Typeable instance for StablePtr
unsafeCoerce :: a -> b
unsafeCoerce = unsafeCoerce#
#include "Typeable.h"
-------------------------------------------------------------
--
-- Type representations
--
-------------------------------------------------------------
-- | A concrete representation of a (monomorphic) type. 'TypeRep'
-- supports reasonably efficient equality.
--
-- equality of keys doesn't work for dynamically loaded code, so we
-- revert back to canonical type names.
--
-- could use packed strings here.
--
data TypeRep = TypeRep !Key TyCon [TypeRep]
-- Compare keys for equality
instance Eq TypeRep where
(TypeRep _ t1 a1) == (TypeRep _ t2 a2) = t1 == t2 && a1 == a2
-- | An abstract representation of a type constructor. 'TyCon' objects can
-- be built using 'mkTyCon'.
data TyCon = TyCon !Key String
instance Eq TyCon where
(TyCon _ s1) == (TyCon _ s2) = s1 == s2
--
-- 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
-- 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
-------------------------------------------------------------
--
-- 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
--
-------------------------------------------------------------
INSTANCE_TYPEABLE1([],listTc,"[]")
INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
INSTANCE_TYPEABLE2(Either,eitherTc,"Either")
INSTANCE_TYPEABLE2((->),funTc,"->")
INSTANCE_TYPEABLE1(IO,ioTc,"IO")
INSTANCE_TYPEABLE0((),unitTc,"()")
INSTANCE_TYPEABLE2((,),pairTc,",")
INSTANCE_TYPEABLE3((,,),tup3Tc,",,")
tup4Tc :: TyCon
tup4Tc = mkTyCon ",,,"
instance Typeable4 (,,,) where
typeOf4 _ = mkTyConApp tup4Tc []
tup5Tc :: TyCon
tup5Tc = mkTyCon ",,,,"
instance Typeable5 (,,,,) where
typeOf5 _ = mkTyConApp tup5Tc []
tup6Tc :: TyCon
tup6Tc = mkTyCon ",,,,,"
instance Typeable6 (,,,,,) where
typeOf6 _ = mkTyConApp tup6Tc []
tup7Tc :: TyCon
tup7Tc = mkTyCon ",,,,,"
instance Typeable7 (,,,,,,) where
typeOf7 _ = mkTyConApp tup7Tc []
INSTANCE_TYPEABLE1(Ptr,ptrTc,"Foreign.Ptr.Ptr")
INSTANCE_TYPEABLE1(StablePtr,stableptrTc,"Foreign.StablePtr.StablePtr")
INSTANCE_TYPEABLE1(IORef,iorefTc,"Data.IORef.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(Integer,integerTc,"Integer")
INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
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")
INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
#else /* GHC < 6.3 */
(
-- * The Typeable class
Typeable( typeOf ), -- :: a -> TypeRep
-- * Type-safe cast
cast, -- :: (Typeable a, Typeable b) => a -> Maybe b
castss, -- a cast for kind "* -> *"
castarr, -- another convenient variation
-- * Type representations
TypeRep, -- abstract, instance of: Eq, Show, Typeable
TyCon, -- abstract, instance of: Eq, Show, Typeable
-- * Construction of type representations
mkTyCon, -- :: String -> TyCon
mkAppTy, -- :: TyCon -> [TypeRep] -> TypeRep
mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep
applyTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep
-- * Observation of type representations
typerepTyCon, -- :: TypeRep -> TyCon
typerepArgs, -- :: TypeRep -> [TypeRep]
tyconString -- :: TyCon -> String
) where
import qualified Data.HashTable as HT
import Data.Maybe
import Data.Either
import Data.Int
import Data.Word
import Data.List( foldl )
import GHC.Base
import GHC.Show
import GHC.Err
import GHC.Num
import GHC.Float
import GHC.Real( rem, Ratio )
import GHC.IOBase
import GHC.Ptr -- So we can give Typeable instance for Ptr
import GHC.Stable -- So we can give Typeable instance for StablePtr
unsafeCoerce :: a -> b
unsafeCoerce = unsafeCoerce#
#include "Typeable.h"
-------------------------------------------------------------
--
-- Type representations
--
-------------------------------------------------------------
-- | A concrete representation of a (monomorphic) type. 'TypeRep'
-- supports reasonably efficient equality.
data TypeRep = TypeRep !Key TyCon [TypeRep]
-- Compare keys for equality
instance Eq TypeRep where
(TypeRep _ t1 a1) == (TypeRep _ t2 a2) = t1 == t2 && a1 == a2
-- | An abstract representation of a type constructor. 'TyCon' objects can
-- be built using 'mkTyCon'.
data TyCon = TyCon !Key String
instance Eq TyCon where
(TyCon _ s1) == (TyCon _ s2) = s1 == s2
--
-- let fTy = mkTyCon "Foo" in show (mkAppTy (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
mkAppTy :: TyCon -> [TypeRep] -> TypeRep
mkAppTy tc@(TyCon tc_k _) args
= TypeRep (appKeys tc_k arg_ks) tc args
where
arg_ks = [k | TypeRep k _ _ <- args]
funTc :: TyCon
funTc = mkTyCon "->"
-- | A special case of 'mkAppTy', which applies the function
-- type constructor to a pair of types.
mkFunTy :: TypeRep -> TypeRep -> TypeRep
mkFunTy f a = mkAppTy funTc [f,a]
-- | 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'.
applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
applyTy (TypeRep _ tc [t1,t2]) t3
| tc == funTc && t1 == t3 = Just t2
applyTy _ _ = Nothing
-- 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
--
-------------------------------------------------------------
-- | 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.
-------------------------------------------------------------
--
-- 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 convenient variation for kind "* -> *"
castss :: (Typeable a, Typeable b) => t a -> Maybe (t b)
castss x = r
where
r = if typeOf (get x) == typeOf (get (fromJust r))
then Just $ unsafeCoerce x
else Nothing
get :: t c -> c
get = undefined
-- | Another variation
castarr :: (Typeable a, Typeable b, Typeable c, Typeable d)
=> (a -> t b) -> Maybe (c -> t d)
castarr x = r
where
r = if typeOf (get x) == typeOf (get (fromJust r))
then Just $ unsafeCoerce x
else Nothing
get :: (e -> t f) -> (e, f)
get = undefined
{-
The variations castss and castarr are arguably not really needed.
Let's discuss castss in some detail. To get rid of castss, we can
require "Typeable (t a)" and "Typeable (t b)" rather than just
"Typeable a" and "Typeable b". In that case, the ordinary cast would
work. Eventually, all kinds of library instances should become
Typeable. (There is another potential use of variations as those given
above. It allows quantification on type constructors.
-}
-------------------------------------------------------------
--
-- Instances of the Typeable class for Prelude types
--
-------------------------------------------------------------
listTc :: TyCon
listTc = mkTyCon "[]"
instance Typeable a => Typeable [a] where
typeOf ls = mkAppTy listTc [typeOf ((undefined :: [a] -> a) ls)]
-- In GHC we can say
-- typeOf (undefined :: a)
-- using scoped type variables, but we use the
-- more verbose form here, for compatibility with Hugs
unitTc :: TyCon
unitTc = mkTyCon "()"
instance Typeable () where
typeOf _ = mkAppTy unitTc []
tup2Tc :: TyCon
tup2Tc = mkTyCon ","
instance (Typeable a, Typeable b) => Typeable (a,b) where
typeOf tu = mkAppTy tup2Tc [typeOf ((undefined :: (a,b) -> a) tu),
typeOf ((undefined :: (a,b) -> b) tu)]
tup3Tc :: TyCon
tup3Tc = mkTyCon ",,"
instance ( Typeable a , Typeable b , Typeable c) => Typeable (a,b,c) where
typeOf tu = mkAppTy tup3Tc [typeOf ((undefined :: (a,b,c) -> a) tu),
typeOf ((undefined :: (a,b,c) -> b) tu),
typeOf ((undefined :: (a,b,c) -> c) tu)]
tup4Tc :: TyCon
tup4Tc = mkTyCon ",,,"
instance ( Typeable a
, Typeable b
, Typeable c
, Typeable d) => Typeable (a,b,c,d) where
typeOf tu = mkAppTy tup4Tc [typeOf ((undefined :: (a,b,c,d) -> a) tu),
typeOf ((undefined :: (a,b,c,d) -> b) tu),
typeOf ((undefined :: (a,b,c,d) -> c) tu),
typeOf ((undefined :: (a,b,c,d) -> d) tu)]
tup5Tc :: TyCon
tup5Tc = mkTyCon ",,,,"
instance ( Typeable a
, Typeable b
, Typeable c
, Typeable d
, Typeable e) => Typeable (a,b,c,d,e) where
typeOf tu = mkAppTy tup5Tc [typeOf ((undefined :: (a,b,c,d,e) -> a) tu),
typeOf ((undefined :: (a,b,c,d,e) -> b) tu),
typeOf ((undefined :: (a,b,c,d,e) -> c) tu),
typeOf ((undefined :: (a,b,c,d,e) -> d) tu),
typeOf ((undefined :: (a,b,c,d,e) -> e) tu)]
instance (Typeable a, Typeable b) => Typeable (a -> b) where
typeOf f = mkFunTy (typeOf ((undefined :: (a -> b) -> a) f))
(typeOf ((undefined :: (a -> b) -> b) f))
-------------------------------------------------------
--
-- 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(Integer,integerTc,"Integer")
INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
INSTANCE_TYPEABLE2(Either,eitherTc,"Either")
INSTANCE_TYPEABLE1(IO,ioTc,"IO")
INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
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")
INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef")
#endif /* GHC < 6.3 */
---------------------------------------------
--
-- Internals
--
---------------------------------------------
newtype Key = Key Int deriving( Eq )
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),
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)
return (Cache { next_key = key_loc,
tc_tbl = empty_tc_tbl,
ap_tbl = empty_ap_tbl })
newKey :: IORef Key -> IO Key
newKey _ = do i <- genSym; return (Key i)
-- In GHC we use the RTS's genSym function to get a new unique,
-- because in GHCi we might have two copies of the Data.Typeable
-- library running (one in the compiler and one in the running
-- program), and we need to make sure they don't share any keys.
--
-- This is really a hack. A better solution would be to centralise the
-- whole mutable state used by this module, i.e. both hashtables. But
-- the current solution solves the immediate problem, which is that
-- dynamics generated in one world with one type were erroneously
-- being recognised by the other world as having a different type.
--
-- dons: SimonM says we need to unify the hashes by storing them in a
-- variable in the rts.
--
foreign import ccall unsafe "genSymZh"
genSym :: IO Int
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