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
30 cast, -- :: (Typeable a, Typeable b) => a -> Maybe b
31 castss, -- a cast for kind "* -> *"
32 castarr, -- another convenient variation
34 -- * Type representations
35 TypeRep, -- abstract, instance of: Eq, Show, Typeable
36 TyCon, -- abstract, instance of: Eq, Show, Typeable
38 -- * Construction of type representations
39 mkTyCon, -- :: String -> TyCon
40 mkAppTy, -- :: TyCon -> [TypeRep] -> TypeRep
41 mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep
42 applyTy -- :: TypeRep -> TypeRep -> Maybe TypeRep
47 import qualified Data.HashTable as HT
52 import Data.List( foldl )
54 #ifdef __GLASGOW_HASKELL__
60 import GHC.Real( rem, Ratio )
62 import GHC.Ptr -- So we can give Typeable instance for Ptr
63 import GHC.Stable -- So we can give Typeable instance for StablePtr
73 #ifdef __GLASGOW_HASKELL__
74 unsafeCoerce :: a -> b
75 unsafeCoerce = unsafeCoerce#
79 import NonStdUnsafeCoerce (unsafeCoerce)
80 import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
87 -------------------------------------------------------------
89 -- Type representations
91 -------------------------------------------------------------
94 -- | A concrete representation of a (monomorphic) type. 'TypeRep'
95 -- supports reasonably efficient equality.
96 data TypeRep = TypeRep !Key TyCon [TypeRep]
98 -- Compare keys for equality
99 instance Eq TypeRep where
100 (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
102 -- | An abstract representation of a type constructor. 'TyCon' objects can
103 -- be built using 'mkTyCon'.
104 data TyCon = TyCon !Key String
106 instance Eq TyCon where
107 (TyCon t1 _) == (TyCon t2 _) = t1 == t2
112 -- let fTy = mkTyCon "Foo" in show (mkAppTy (mkTyCon ",,")
115 -- returns "(Foo,Foo,Foo)"
117 -- The TypeRep Show instance promises to print tuple types
118 -- correctly. Tuple type constructors are specified by a
119 -- sequence of commas, e.g., (mkTyCon ",,,,") returns
120 -- the 5-tuple tycon.
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 -------------------------------------------------------------
233 -------------------------------------------------------------
235 -- | The type-safe cast operation
236 cast :: (Typeable a, Typeable b) => a -> Maybe b
239 r = if typeOf x == typeOf (fromJust r)
240 then Just $ unsafeCoerce x
244 -- | A convenient variation for kind "* -> *"
245 castss :: (Typeable a, Typeable b) => t a -> Maybe (t b)
248 r = if typeOf (get x) == typeOf (get (fromJust r))
249 then Just $ unsafeCoerce x
255 -- | Another variation
256 castarr :: (Typeable a, Typeable b, Typeable c, Typeable d)
257 => (a -> t b) -> Maybe (c -> t d)
260 r = if typeOf (get x) == typeOf (get (fromJust r))
261 then Just $ unsafeCoerce x
263 get :: (e -> t f) -> (e, f)
268 The variations castss and castarr are arguably not really needed.
269 Let's discuss castss in some detail. To get rid of castss, we can
270 require "Typeable (t a)" and "Typeable (t b)" rather than just
271 "Typeable a" and "Typeable b". In that case, the ordinary cast would
272 work. Eventually, all kinds of library instances should become
273 Typeable. (There is another potential use of variations as those given
274 above. It allows quantification on type constructors.
279 -------------------------------------------------------------
281 -- Instances of the Typeable class for Prelude types
283 -------------------------------------------------------------
286 listTc = mkTyCon "[]"
288 instance Typeable a => Typeable [a] where
289 typeOf ls = mkAppTy listTc [typeOf ((undefined :: [a] -> a) ls)]
291 -- typeOf (undefined :: a)
292 -- using scoped type variables, but we use the
293 -- more verbose form here, for compatibility with Hugs
296 unitTc = mkTyCon "()"
298 instance Typeable () where
299 typeOf _ = mkAppTy unitTc []
304 instance (Typeable a, Typeable b) => Typeable (a,b) where
305 typeOf tu = mkAppTy tup2Tc [typeOf ((undefined :: (a,b) -> a) tu),
306 typeOf ((undefined :: (a,b) -> b) tu)]
309 tup3Tc = mkTyCon ",,"
311 instance ( Typeable a , Typeable b , Typeable c) => Typeable (a,b,c) where
312 typeOf tu = mkAppTy tup3Tc [typeOf ((undefined :: (a,b,c) -> a) tu),
313 typeOf ((undefined :: (a,b,c) -> b) tu),
314 typeOf ((undefined :: (a,b,c) -> c) tu)]
317 tup4Tc = mkTyCon ",,,"
319 instance ( Typeable a
322 , Typeable d) => Typeable (a,b,c,d) where
323 typeOf tu = mkAppTy tup4Tc [typeOf ((undefined :: (a,b,c,d) -> a) tu),
324 typeOf ((undefined :: (a,b,c,d) -> b) tu),
325 typeOf ((undefined :: (a,b,c,d) -> c) tu),
326 typeOf ((undefined :: (a,b,c,d) -> d) tu)]
328 tup5Tc = mkTyCon ",,,,"
330 instance ( Typeable a
334 , Typeable e) => Typeable (a,b,c,d,e) where
335 typeOf tu = mkAppTy tup5Tc [typeOf ((undefined :: (a,b,c,d,e) -> a) tu),
336 typeOf ((undefined :: (a,b,c,d,e) -> b) tu),
337 typeOf ((undefined :: (a,b,c,d,e) -> c) tu),
338 typeOf ((undefined :: (a,b,c,d,e) -> d) tu),
339 typeOf ((undefined :: (a,b,c,d,e) -> e) tu)]
341 instance (Typeable a, Typeable b) => Typeable (a -> b) where
342 typeOf f = mkFunTy (typeOf ((undefined :: (a -> b) -> a) f))
343 (typeOf ((undefined :: (a -> b) -> b) f))
347 -------------------------------------------------------
349 -- Generate Typeable instances for standard datatypes
351 -------------------------------------------------------
354 INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
355 INSTANCE_TYPEABLE0(Char,charTc,"Char")
356 INSTANCE_TYPEABLE0(Float,floatTc,"Float")
357 INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
358 INSTANCE_TYPEABLE0(Int,intTc,"Int")
359 INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
360 INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
361 INSTANCE_TYPEABLE2(Either,eitherTc,"Either")
362 INSTANCE_TYPEABLE1(IO,ioTc,"IO")
363 INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
364 INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
365 INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
366 INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
367 INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
369 INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
370 INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
371 INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
372 INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
374 INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )
375 INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
376 INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
377 INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
379 INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
380 INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
382 INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef")
387 ---------------------------------------------
391 ---------------------------------------------
394 newtype Key = Key Int deriving( Eq )
397 data KeyPr = KeyPr !Key !Key deriving( Eq )
399 hashKP :: KeyPr -> Int32
400 hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime
402 data Cache = Cache { next_key :: !(IORef Key),
403 tc_tbl :: !(HT.HashTable String Key),
404 ap_tbl :: !(HT.HashTable KeyPr Key) }
406 {-# NOINLINE cache #-}
408 cache = unsafePerformIO $ do
409 empty_tc_tbl <- HT.new (==) HT.hashString
410 empty_ap_tbl <- HT.new (==) hashKP
411 key_loc <- newIORef (Key 1)
412 return (Cache { next_key = key_loc,
413 tc_tbl = empty_tc_tbl,
414 ap_tbl = empty_ap_tbl })
416 newKey :: IORef Key -> IO Key
417 #ifdef __GLASGOW_HASKELL__
418 newKey kloc = do i <- genSym; return (Key i)
420 newKey kloc = do { k@(Key i) <- readIORef kloc ;
421 writeIORef kloc (Key (i+1)) ;
425 #ifdef __GLASGOW_HASKELL__
426 -- In GHC we use the RTS's genSym function to get a new unique,
427 -- because in GHCi we might have two copies of the Data.Typeable
428 -- library running (one in the compiler and one in the running
429 -- program), and we need to make sure they don't share any keys.
431 -- This is really a hack. A better solution would be to centralise the
432 -- whole mutable state used by this module, i.e. both hashtables. But
433 -- the current solution solves the immediate problem, which is that
434 -- dynamics generated in one world with one type were erroneously
435 -- being recognised by the other world as having a different type.
436 foreign import ccall unsafe "genSymZh"
440 mkTyConKey :: String -> Key
442 = unsafePerformIO $ do
443 let Cache {next_key = kloc, tc_tbl = tbl} = cache
444 mb_k <- HT.lookup tbl str
447 Nothing -> do { k <- newKey kloc ;
448 HT.insert tbl str k ;
451 appKey :: Key -> Key -> Key
453 = unsafePerformIO $ do
454 let Cache {next_key = kloc, ap_tbl = tbl} = cache
455 mb_k <- HT.lookup tbl kpr
458 Nothing -> do { k <- newKey kloc ;
459 HT.insert tbl kpr k ;
464 appKeys :: Key -> [Key] -> Key
465 appKeys k ks = foldl appKey k ks