[project @ 2003-11-23 12:23:49 by ralf]
[ghc.git] / libraries / base / Data / Typeable.hs
1 {-# OPTIONS -fno-implicit-prelude #-}
2 -----------------------------------------------------------------------------
3 -- |
4 -- Module : Data.Typeable
5 -- Copyright : (c) The University of Glasgow 2001
6 -- License : BSD-style (see the file libraries/base/LICENSE)
7 --
8 -- Maintainer : libraries@haskell.org
9 -- Stability : experimental
10 -- Portability : portable
11 --
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.
20 --
21 -----------------------------------------------------------------------------
22
23 module Data.Typeable
24 (
25
26 -- * The Typeable class
27 Typeable( typeOf ), -- :: a -> TypeRep
28
29 -- * Type-safe cast
30 cast, -- :: (Typeable a, Typeable b) => a -> Maybe b
31 castss, -- a cast for kind "* -> *"
32 castarr, -- another convenient variation
33
34 -- * Type representations
35 TypeRep, -- abstract, instance of: Eq, Show, Typeable
36 TyCon, -- abstract, instance of: Eq, Show, Typeable
37
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
43
44 -- * Observation of type representations
45 typerepTyCon, -- :: TypeRep -> TyCon
46 typerepArgs, -- :: TypeRep -> [TypeRep]
47 tyconString -- :: TyCon -> String
48
49
50 ) where
51
52
53 import qualified Data.HashTable as HT
54 import Data.Maybe
55 import Data.Either
56 import Data.Int
57 import Data.Word
58 import Data.List( foldl )
59
60 #ifdef __GLASGOW_HASKELL__
61 import GHC.Base
62 import GHC.Show
63 import GHC.Err
64 import GHC.Num
65 import GHC.Float
66 import GHC.Real( rem, Ratio )
67 import GHC.IOBase
68 import GHC.Ptr -- So we can give Typeable instance for Ptr
69 import GHC.Stable -- So we can give Typeable instance for StablePtr
70 #endif
71
72 #ifdef __HUGS__
73 import Hugs.Prelude
74 import Hugs.IO
75 import Hugs.IORef
76 import Hugs.IOExts
77 #endif
78
79 #ifdef __GLASGOW_HASKELL__
80 unsafeCoerce :: a -> b
81 unsafeCoerce = unsafeCoerce#
82 #endif
83
84 #ifdef __NHC__
85 import NonStdUnsafeCoerce (unsafeCoerce)
86 import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
87 #else
88 #include "Typeable.h"
89 #endif
90
91
92 #ifndef __HUGS__
93 -------------------------------------------------------------
94 --
95 -- Type representations
96 --
97 -------------------------------------------------------------
98
99
100 -- | A concrete representation of a (monomorphic) type. 'TypeRep'
101 -- supports reasonably efficient equality.
102 data TypeRep = TypeRep !Key TyCon [TypeRep]
103
104 -- Compare keys for equality
105 instance Eq TypeRep where
106 (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
107
108 -- | An abstract representation of a type constructor. 'TyCon' objects can
109 -- be built using 'mkTyCon'.
110 data TyCon = TyCon !Key String
111
112 instance Eq TyCon where
113 (TyCon t1 _) == (TyCon t2 _) = t1 == t2
114
115 #endif
116
117 --
118 -- let fTy = mkTyCon "Foo" in show (mkAppTy (mkTyCon ",,")
119 -- [fTy,fTy,fTy])
120 --
121 -- returns "(Foo,Foo,Foo)"
122 --
123 -- The TypeRep Show instance promises to print tuple types
124 -- correctly. Tuple type constructors are specified by a
125 -- sequence of commas, e.g., (mkTyCon ",,,,") returns
126 -- the 5-tuple tycon.
127
128 ----------------- Construction --------------------
129
130 -- | Applies a type constructor to a sequence of types
131 mkAppTy :: TyCon -> [TypeRep] -> TypeRep
132 mkAppTy tc@(TyCon tc_k _) args
133 = TypeRep (appKeys tc_k arg_ks) tc args
134 where
135 arg_ks = [k | TypeRep k _ _ <- args]
136
137 funTc :: TyCon
138 funTc = mkTyCon "->"
139
140 -- | A special case of 'mkAppTy', which applies the function
141 -- type constructor to a pair of types.
142 mkFunTy :: TypeRep -> TypeRep -> TypeRep
143 mkFunTy f a = mkAppTy funTc [f,a]
144
145 -- | Applies a type to a function type. Returns: @'Just' u@ if the
146 -- first argument represents a function of type @t -> u@ and the
147 -- second argument represents a function of type @t@. Otherwise,
148 -- returns 'Nothing'.
149 applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
150 applyTy (TypeRep _ tc [t1,t2]) t3
151 | tc == funTc && t1 == t3 = Just t2
152 applyTy _ _ = Nothing
153
154 -- If we enforce the restriction that there is only one
155 -- @TyCon@ for a type & it is shared among all its uses,
156 -- we can map them onto Ints very simply. The benefit is,
157 -- of course, that @TyCon@s can then be compared efficiently.
158
159 -- Provided the implementor of other @Typeable@ instances
160 -- takes care of making all the @TyCon@s CAFs (toplevel constants),
161 -- this will work.
162
163 -- If this constraint does turn out to be a sore thumb, changing
164 -- the Eq instance for TyCons is trivial.
165
166 -- | Builds a 'TyCon' object representing a type constructor. An
167 -- implementation of "Data.Typeable" should ensure that the following holds:
168 --
169 -- > mkTyCon "a" == mkTyCon "a"
170 --
171
172 mkTyCon :: String -- ^ the name of the type constructor (should be unique
173 -- in the program, so it might be wise to use the
174 -- fully qualified name).
175 -> TyCon -- ^ A unique 'TyCon' object
176 mkTyCon str = TyCon (mkTyConKey str) str
177
178
179
180 ----------------- Observation ---------------------
181
182
183 -- | Observe the type constructor of a type representation
184 typerepTyCon :: TypeRep -> TyCon
185 typerepTyCon (TypeRep _ tc _) = tc
186
187
188 -- | Observe the argument types of a type representation
189 typerepArgs :: TypeRep -> [TypeRep]
190 typerepArgs (TypeRep _ _ args) = args
191
192
193 -- | Observe string encoding of a type representation
194 tyconString :: TyCon -> String
195 tyconString (TyCon _ str) = str
196
197
198 ----------------- Showing TypeReps --------------------
199
200 instance Show TypeRep where
201 showsPrec p (TypeRep _ tycon tys) =
202 case tys of
203 [] -> showsPrec p tycon
204 [x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
205 [a,r] | tycon == funTc -> showParen (p > 8) $
206 showsPrec 9 a . showString " -> " . showsPrec 8 r
207 xs | isTupleTyCon tycon -> showTuple tycon xs
208 | otherwise ->
209 showParen (p > 9) $
210 showsPrec p tycon .
211 showChar ' ' .
212 showArgs tys
213
214 instance Show TyCon where
215 showsPrec _ (TyCon _ s) = showString s
216
217 isTupleTyCon :: TyCon -> Bool
218 isTupleTyCon (TyCon _ (',':_)) = True
219 isTupleTyCon _ = False
220
221 -- Some (Show.TypeRep) helpers:
222
223 showArgs :: Show a => [a] -> ShowS
224 showArgs [] = id
225 showArgs [a] = showsPrec 10 a
226 showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
227
228 showTuple :: TyCon -> [TypeRep] -> ShowS
229 showTuple (TyCon _ str) args = showChar '(' . go str args
230 where
231 go [] [a] = showsPrec 10 a . showChar ')'
232 go _ [] = showChar ')' -- a failure condition, really.
233 go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
234 go _ _ = showChar ')'
235
236
237 -------------------------------------------------------------
238 --
239 -- The Typeable class
240 --
241 -------------------------------------------------------------
242
243 -- | The class 'Typeable' allows a concrete representation of a type to
244 -- be calculated.
245 class Typeable a where
246 typeOf :: a -> TypeRep
247 -- ^ Takes a value of type @a@ and returns a concrete representation
248 -- of that type. The /value/ of the argument should be ignored by
249 -- any instance of 'Typeable', so that it is safe to pass 'undefined' as
250 -- the argument.
251
252
253 -------------------------------------------------------------
254 --
255 -- Type-safe cast
256 --
257 -------------------------------------------------------------
258
259 -- | The type-safe cast operation
260 cast :: (Typeable a, Typeable b) => a -> Maybe b
261 cast x = r
262 where
263 r = if typeOf x == typeOf (fromJust r)
264 then Just $ unsafeCoerce x
265 else Nothing
266
267
268 -- | A convenient variation for kind \"* -> *\"
269 castss :: (Typeable a, Typeable b) => t a -> Maybe (t b)
270 castss x = r
271 where
272 r = if typeOf (get x) == typeOf (get (fromJust r))
273 then Just $ unsafeCoerce x
274 else Nothing
275 get :: t c -> c
276 get = undefined
277
278
279 -- | Another variation
280 castarr :: (Typeable a, Typeable b, Typeable c, Typeable d)
281 => (a -> t b) -> Maybe (c -> t d)
282 castarr x = r
283 where
284 r = if typeOf (get x) == typeOf (get (fromJust r))
285 then Just $ unsafeCoerce x
286 else Nothing
287 get :: (e -> t f) -> (e, f)
288 get = undefined
289
290 {-
291
292 The variations castss and castarr are arguably not really needed.
293 Let's discuss castss in some detail. To get rid of castss, we can
294 require "Typeable (t a)" and "Typeable (t b)" rather than just
295 "Typeable a" and "Typeable b". In that case, the ordinary cast would
296 work. Eventually, all kinds of library instances should become
297 Typeable. (There is another potential use of variations as those given
298 above. It allows quantification on type constructors.
299
300 -}
301
302
303 -------------------------------------------------------------
304 --
305 -- Instances of the Typeable class for Prelude types
306 --
307 -------------------------------------------------------------
308
309 listTc :: TyCon
310 listTc = mkTyCon "[]"
311
312 instance Typeable a => Typeable [a] where
313 typeOf ls = mkAppTy listTc [typeOf ((undefined :: [a] -> a) ls)]
314 -- In GHC we can say
315 -- typeOf (undefined :: a)
316 -- using scoped type variables, but we use the
317 -- more verbose form here, for compatibility with Hugs
318
319 unitTc :: TyCon
320 unitTc = mkTyCon "()"
321
322 instance Typeable () where
323 typeOf _ = mkAppTy unitTc []
324
325 tup2Tc :: TyCon
326 tup2Tc = mkTyCon ","
327
328 instance (Typeable a, Typeable b) => Typeable (a,b) where
329 typeOf tu = mkAppTy tup2Tc [typeOf ((undefined :: (a,b) -> a) tu),
330 typeOf ((undefined :: (a,b) -> b) tu)]
331
332 tup3Tc :: TyCon
333 tup3Tc = mkTyCon ",,"
334
335 instance ( Typeable a , Typeable b , Typeable c) => Typeable (a,b,c) where
336 typeOf tu = mkAppTy tup3Tc [typeOf ((undefined :: (a,b,c) -> a) tu),
337 typeOf ((undefined :: (a,b,c) -> b) tu),
338 typeOf ((undefined :: (a,b,c) -> c) tu)]
339
340 tup4Tc :: TyCon
341 tup4Tc = mkTyCon ",,,"
342
343 instance ( Typeable a
344 , Typeable b
345 , Typeable c
346 , Typeable d) => Typeable (a,b,c,d) where
347 typeOf tu = mkAppTy tup4Tc [typeOf ((undefined :: (a,b,c,d) -> a) tu),
348 typeOf ((undefined :: (a,b,c,d) -> b) tu),
349 typeOf ((undefined :: (a,b,c,d) -> c) tu),
350 typeOf ((undefined :: (a,b,c,d) -> d) tu)]
351 tup5Tc :: TyCon
352 tup5Tc = mkTyCon ",,,,"
353
354 instance ( Typeable a
355 , Typeable b
356 , Typeable c
357 , Typeable d
358 , Typeable e) => Typeable (a,b,c,d,e) where
359 typeOf tu = mkAppTy tup5Tc [typeOf ((undefined :: (a,b,c,d,e) -> a) tu),
360 typeOf ((undefined :: (a,b,c,d,e) -> b) tu),
361 typeOf ((undefined :: (a,b,c,d,e) -> c) tu),
362 typeOf ((undefined :: (a,b,c,d,e) -> d) tu),
363 typeOf ((undefined :: (a,b,c,d,e) -> e) tu)]
364
365 instance (Typeable a, Typeable b) => Typeable (a -> b) where
366 typeOf f = mkFunTy (typeOf ((undefined :: (a -> b) -> a) f))
367 (typeOf ((undefined :: (a -> b) -> b) f))
368
369
370
371 -------------------------------------------------------
372 --
373 -- Generate Typeable instances for standard datatypes
374 --
375 -------------------------------------------------------
376
377 #ifndef __NHC__
378 INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
379 INSTANCE_TYPEABLE0(Char,charTc,"Char")
380 INSTANCE_TYPEABLE0(Float,floatTc,"Float")
381 INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
382 INSTANCE_TYPEABLE0(Int,intTc,"Int")
383 INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
384 INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
385 INSTANCE_TYPEABLE2(Either,eitherTc,"Either")
386 INSTANCE_TYPEABLE1(IO,ioTc,"IO")
387 INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
388 INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
389 INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
390 INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
391 INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
392
393 INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
394 INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
395 INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
396 INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
397
398 INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )
399 INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
400 INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
401 INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
402
403 INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
404 INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
405
406 INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef")
407 #endif
408
409
410
411 ---------------------------------------------
412 --
413 -- Internals
414 --
415 ---------------------------------------------
416
417 #ifndef __HUGS__
418 newtype Key = Key Int deriving( Eq )
419 #endif
420
421 data KeyPr = KeyPr !Key !Key deriving( Eq )
422
423 hashKP :: KeyPr -> Int32
424 hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime
425
426 data Cache = Cache { next_key :: !(IORef Key),
427 tc_tbl :: !(HT.HashTable String Key),
428 ap_tbl :: !(HT.HashTable KeyPr Key) }
429
430 {-# NOINLINE cache #-}
431 cache :: Cache
432 cache = unsafePerformIO $ do
433 empty_tc_tbl <- HT.new (==) HT.hashString
434 empty_ap_tbl <- HT.new (==) hashKP
435 key_loc <- newIORef (Key 1)
436 return (Cache { next_key = key_loc,
437 tc_tbl = empty_tc_tbl,
438 ap_tbl = empty_ap_tbl })
439
440 newKey :: IORef Key -> IO Key
441 #ifdef __GLASGOW_HASKELL__
442 newKey kloc = do i <- genSym; return (Key i)
443 #else
444 newKey kloc = do { k@(Key i) <- readIORef kloc ;
445 writeIORef kloc (Key (i+1)) ;
446 return k }
447 #endif
448
449 #ifdef __GLASGOW_HASKELL__
450 -- In GHC we use the RTS's genSym function to get a new unique,
451 -- because in GHCi we might have two copies of the Data.Typeable
452 -- library running (one in the compiler and one in the running
453 -- program), and we need to make sure they don't share any keys.
454 --
455 -- This is really a hack. A better solution would be to centralise the
456 -- whole mutable state used by this module, i.e. both hashtables. But
457 -- the current solution solves the immediate problem, which is that
458 -- dynamics generated in one world with one type were erroneously
459 -- being recognised by the other world as having a different type.
460 foreign import ccall unsafe "genSymZh"
461 genSym :: IO Int
462 #endif
463
464 mkTyConKey :: String -> Key
465 mkTyConKey str
466 = unsafePerformIO $ do
467 let Cache {next_key = kloc, tc_tbl = tbl} = cache
468 mb_k <- HT.lookup tbl str
469 case mb_k of
470 Just k -> return k
471 Nothing -> do { k <- newKey kloc ;
472 HT.insert tbl str k ;
473 return k }
474
475 appKey :: Key -> Key -> Key
476 appKey k1 k2
477 = unsafePerformIO $ do
478 let Cache {next_key = kloc, ap_tbl = tbl} = cache
479 mb_k <- HT.lookup tbl kpr
480 case mb_k of
481 Just k -> return k
482 Nothing -> do { k <- newKey kloc ;
483 HT.insert tbl kpr k ;
484 return k }
485 where
486 kpr = KeyPr k1 k2
487
488 appKeys :: Key -> [Key] -> Key
489 appKeys k ks = foldl appKey k ks