1 {-# OPTIONS -fno-implicit-prelude #-}
2 -----------------------------------------------------------------------------
4 -- Module : Data.Typeable
5 -- Copyright : (c) The University of Glasgow 2001
6 -- License : BSD-style (see the file libraries/base/LICENSE)
8 -- Maintainer : libraries@haskell.org
9 -- Stability : experimental
10 -- Portability : portable
12 -- The Typeable class reifies types to some extent by associating type
13 -- representations to types. These type representations can be compared,
14 -- and one can in turn define a type-safe cast operation. To this end,
15 -- an unsafe cast is guarded by a test for type (representation)
16 -- equivalence. The module Data.Dynamic uses Typeable for an
17 -- implementation of dynamics. The module Data.Generics uses Typeable
18 -- and type-safe cast (but not dynamics) to support the "Scrap your
19 -- boilerplate" style of generic programming.
21 -----------------------------------------------------------------------------
26 -- * The Typeable class
27 Typeable( typeOf ), -- :: a -> TypeRep
29 -- * Type-safe cast and other clients
30 cast, -- :: (Typeable a, Typeable b) => a -> Maybe b
31 sameType, -- two type values are the same
33 -- * Type representations
34 TypeRep, -- abstract, instance of: Eq, Show, Typeable
35 TyCon, -- abstract, instance of: Eq, Show, Typeable
37 -- * Construction of type representations
38 mkTyCon, -- :: String -> TyCon
39 mkAppTy, -- :: TyCon -> [TypeRep] -> TypeRep
40 mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep
41 applyTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep
44 -- let fTy = mkTyCon "Foo" in show (mkAppTy (mkTyCon ",,")
47 -- returns "(Foo,Foo,Foo)"
49 -- The TypeRep Show instance promises to print tuple types
50 -- correctly. Tuple type constructors are specified by a
51 -- sequence of commas, e.g., (mkTyCon ",,,,") returns
57 import qualified Data.HashTable as HT
63 import Data.List( foldl )
65 #ifdef __GLASGOW_HASKELL__
71 import GHC.Real( rem, Ratio )
73 import GHC.Ptr -- So we can give Typeable instance for Ptr
74 import GHC.Stable -- So we can give Typeable instance for StablePtr
84 #ifdef __GLASGOW_HASKELL__
85 unsafeCoerce :: a -> b
86 unsafeCoerce = unsafeCoerce#
90 import NonStdUnsafeCoerce (unsafeCoerce)
91 import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
98 -------------------------------------------------------------
100 -- Type representations
102 -------------------------------------------------------------
104 -- | A concrete representation of a (monomorphic) type. 'TypeRep'
105 -- supports reasonably efficient equality.
106 data TypeRep = TypeRep !Key TyCon [TypeRep]
108 -- Compare keys for equality
109 instance Eq TypeRep where
110 (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
112 -- | An abstract representation of a type constructor. 'TyCon' objects can
113 -- be built using 'mkTyCon'.
114 data TyCon = TyCon !Key String
116 instance Eq TyCon where
117 (TyCon t1 _) == (TyCon t2 _) = t1 == t2
122 ----------------- Construction --------------------
124 -- | Applies a type constructor to a sequence of types
125 mkAppTy :: TyCon -> [TypeRep] -> TypeRep
126 mkAppTy tc@(TyCon tc_k _) args
127 = TypeRep (appKeys tc_k arg_ks) tc args
129 arg_ks = [k | TypeRep k _ _ <- args]
134 -- | A special case of 'mkAppTy', which applies the function
135 -- type constructor to a pair of types.
136 mkFunTy :: TypeRep -> TypeRep -> TypeRep
137 mkFunTy f a = mkAppTy funTc [f,a]
139 -- | Applies a type to a function type. Returns: @'Just' u@ if the
140 -- first argument represents a function of type @t -> u@ and the
141 -- second argument represents a function of type @t@. Otherwise,
142 -- returns 'Nothing'.
143 applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
144 applyTy (TypeRep _ tc [t1,t2]) t3
145 | tc == funTc && t1 == t3 = Just t2
146 applyTy _ _ = Nothing
148 -- If we enforce the restriction that there is only one
149 -- @TyCon@ for a type & it is shared among all its uses,
150 -- we can map them onto Ints very simply. The benefit is,
151 -- of course, that @TyCon@s can then be compared efficiently.
153 -- Provided the implementor of other @Typeable@ instances
154 -- takes care of making all the @TyCon@s CAFs (toplevel constants),
157 -- If this constraint does turn out to be a sore thumb, changing
158 -- the Eq instance for TyCons is trivial.
160 -- | Builds a 'TyCon' object representing a type constructor. An
161 -- implementation of "Data.Typeable" should ensure that the following holds:
163 -- > mkTyCon "a" == mkTyCon "a"
166 mkTyCon :: String -- ^ the name of the type constructor (should be unique
167 -- in the program, so it might be wise to use the
168 -- fully qualified name).
169 -> TyCon -- ^ A unique 'TyCon' object
170 mkTyCon str = TyCon (mkTyConKey str) str
174 ----------------- Showing TypeReps --------------------
176 instance Show TypeRep where
177 showsPrec p (TypeRep _ tycon tys) =
179 [] -> showsPrec p tycon
180 [x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
181 [a,r] | tycon == funTc -> showParen (p > 8) $
182 showsPrec 9 a . showString " -> " . showsPrec 8 r
183 xs | isTupleTyCon tycon -> showTuple tycon xs
190 instance Show TyCon where
191 showsPrec _ (TyCon _ s) = showString s
193 isTupleTyCon :: TyCon -> Bool
194 isTupleTyCon (TyCon _ (',':_)) = True
195 isTupleTyCon _ = False
197 -- Some (Show.TypeRep) helpers:
199 showArgs :: Show a => [a] -> ShowS
201 showArgs [a] = showsPrec 10 a
202 showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
204 showTuple :: TyCon -> [TypeRep] -> ShowS
205 showTuple (TyCon _ str) args = showChar '(' . go str args
207 go [] [a] = showsPrec 10 a . showChar ')'
208 go _ [] = showChar ')' -- a failure condition, really.
209 go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
210 go _ _ = showChar ')'
213 -------------------------------------------------------------
215 -- The Typeable class
217 -------------------------------------------------------------
219 -- | The class 'Typeable' allows a concrete representation of a type to
221 class Typeable a where
222 typeOf :: a -> TypeRep
223 -- ^ Takes a value of type @a@ and returns a concrete representation
224 -- of that type. The /value/ of the argument should be ignored by
225 -- any instance of 'Typeable', so that it is safe to pass 'undefined' as
229 -------------------------------------------------------------
231 -- Type-safe cast and other clients
233 -------------------------------------------------------------
235 -- | The type-safe cast operation
236 cast :: (Typeable a, Typeable b) => a -> Maybe b
239 r = if typeOf x == typeOf (fromJust r) then
240 Just (unsafeCoerce x)
245 -- | Test for type equivalence
246 sameType :: (Typeable a, Typeable b) => TypeVal a -> TypeVal b -> Bool
247 sameType (_::a->()) (_::b->()) = typeOf (undefined::a) ==
248 typeOf (undefined::b)
251 -------------------------------------------------------------
253 -- Instances of the Typeable class for Prelude types
255 -------------------------------------------------------------
258 listTc = mkTyCon "[]"
260 instance Typeable a => Typeable [a] where
261 typeOf ls = mkAppTy listTc [typeOf ((undefined :: [a] -> a) ls)]
263 -- typeOf (undefined :: a)
264 -- using scoped type variables, but we use the
265 -- more verbose form here, for compatibility with Hugs
268 unitTc = mkTyCon "()"
270 instance Typeable () where
271 typeOf _ = mkAppTy unitTc []
276 instance (Typeable a, Typeable b) => Typeable (a,b) where
277 typeOf tu = mkAppTy tup2Tc [typeOf ((undefined :: (a,b) -> a) tu),
278 typeOf ((undefined :: (a,b) -> b) tu)]
281 tup3Tc = mkTyCon ",,"
283 instance ( Typeable a , Typeable b , Typeable c) => Typeable (a,b,c) where
284 typeOf tu = mkAppTy tup3Tc [typeOf ((undefined :: (a,b,c) -> a) tu),
285 typeOf ((undefined :: (a,b,c) -> b) tu),
286 typeOf ((undefined :: (a,b,c) -> c) tu)]
289 tup4Tc = mkTyCon ",,,"
291 instance ( Typeable a
294 , Typeable d) => Typeable (a,b,c,d) where
295 typeOf tu = mkAppTy tup4Tc [typeOf ((undefined :: (a,b,c,d) -> a) tu),
296 typeOf ((undefined :: (a,b,c,d) -> b) tu),
297 typeOf ((undefined :: (a,b,c,d) -> c) tu),
298 typeOf ((undefined :: (a,b,c,d) -> d) tu)]
300 tup5Tc = mkTyCon ",,,,"
302 instance ( Typeable a
306 , Typeable e) => Typeable (a,b,c,d,e) where
307 typeOf tu = mkAppTy tup5Tc [typeOf ((undefined :: (a,b,c,d,e) -> a) tu),
308 typeOf ((undefined :: (a,b,c,d,e) -> b) tu),
309 typeOf ((undefined :: (a,b,c,d,e) -> c) tu),
310 typeOf ((undefined :: (a,b,c,d,e) -> d) tu),
311 typeOf ((undefined :: (a,b,c,d,e) -> e) tu)]
313 instance (Typeable a, Typeable b) => Typeable (a -> b) where
314 typeOf f = mkFunTy (typeOf ((undefined :: (a -> b) -> a) f))
315 (typeOf ((undefined :: (a -> b) -> b) f))
318 -------------------------------------------------------
320 -- Generate Typeable instances for standard datatypes
322 -------------------------------------------------------
325 INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
326 INSTANCE_TYPEABLE0(Char,charTc,"Char")
327 INSTANCE_TYPEABLE0(Float,floatTc,"Float")
328 INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
329 INSTANCE_TYPEABLE0(Int,intTc,"Int")
330 INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
331 INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
332 INSTANCE_TYPEABLE2(Either,eitherTc,"Either")
333 INSTANCE_TYPEABLE1(IO,ioTc,"IO")
334 INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
335 INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
336 INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
337 INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
338 INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
340 INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
341 INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
342 INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
343 INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
345 INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )
346 INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
347 INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
348 INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
350 INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
351 INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
353 INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef")
357 ---------------------------------------------
361 ---------------------------------------------
364 newtype Key = Key Int deriving( Eq )
367 data KeyPr = KeyPr !Key !Key deriving( Eq )
369 hashKP :: KeyPr -> Int32
370 hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime
372 data Cache = Cache { next_key :: !(IORef Key),
373 tc_tbl :: !(HT.HashTable String Key),
374 ap_tbl :: !(HT.HashTable KeyPr Key) }
376 {-# NOINLINE cache #-}
378 cache = unsafePerformIO $ do
379 empty_tc_tbl <- HT.new (==) HT.hashString
380 empty_ap_tbl <- HT.new (==) hashKP
381 key_loc <- newIORef (Key 1)
382 return (Cache { next_key = key_loc,
383 tc_tbl = empty_tc_tbl,
384 ap_tbl = empty_ap_tbl })
386 newKey :: IORef Key -> IO Key
387 newKey kloc = do { k@(Key i) <- readIORef kloc ;
388 writeIORef kloc (Key (i+1)) ;
391 mkTyConKey :: String -> Key
393 = unsafePerformIO $ do
394 let Cache {next_key = kloc, tc_tbl = tbl} = cache
395 mb_k <- HT.lookup tbl str
398 Nothing -> do { k <- newKey kloc ;
399 HT.insert tbl str k ;
402 appKey :: Key -> Key -> Key
404 = unsafePerformIO $ do
405 let Cache {next_key = kloc, ap_tbl = tbl} = cache
406 mb_k <- HT.lookup tbl kpr
409 Nothing -> do { k <- newKey kloc ;
410 HT.insert tbl kpr k ;
415 appKeys :: Key -> [Key] -> Key
416 appKeys k ks = foldl appKey k ks