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