739b4e8b2802a5df43b618756c737c9237568d1c
[packages/base.git] / Data / OldTypeable / Internal.hs
1 {-# LANGUAGE Unsafe #-}
2
3 -----------------------------------------------------------------------------
4 -- |
5 -- Module : Data.Typeable.Internal
6 -- Copyright : (c) The University of Glasgow, CWI 2001--2011
7 -- License : BSD-style (see the file libraries/base/LICENSE)
8 --
9 -- The representations of the types TyCon and TypeRep, and the
10 -- function mkTyCon which is used by derived instances of Typeable to
11 -- construct a TyCon.
12 --
13 -----------------------------------------------------------------------------
14
15 {-# LANGUAGE CPP
16 , NoImplicitPrelude
17 , OverlappingInstances
18 , ScopedTypeVariables
19 , FlexibleInstances
20 , MagicHash #-}
21 #ifdef __GLASGOW_HASKELL__
22 {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
23 #endif
24
25 module Data.OldTypeable.Internal {-# DEPRECATED "Use Data.Typeable.Internal instead" #-} ( -- deprecated in 7.8
26 TypeRep(..),
27 TyCon(..),
28 mkTyCon,
29 mkTyCon3,
30 mkTyConApp,
31 mkAppTy,
32 typeRepTyCon,
33 typeOfDefault,
34 typeOf1Default,
35 typeOf2Default,
36 typeOf3Default,
37 typeOf4Default,
38 typeOf5Default,
39 typeOf6Default,
40 Typeable(..),
41 Typeable1(..),
42 Typeable2(..),
43 Typeable3(..),
44 Typeable4(..),
45 Typeable5(..),
46 Typeable6(..),
47 Typeable7(..),
48 mkFunTy,
49 splitTyConApp,
50 funResultTy,
51 typeRepArgs,
52 showsTypeRep,
53 tyConString,
54 #if defined(__GLASGOW_HASKELL__)
55 listTc, funTc
56 #endif
57 ) where
58
59 import GHC.Base
60 import GHC.Word
61 import GHC.Show
62 import GHC.Err (undefined)
63 import Data.Maybe
64 import Data.List
65 import GHC.Num
66 import GHC.Real
67 import GHC.IORef
68 import GHC.IOArray
69 import GHC.MVar
70 import GHC.ST ( ST )
71 import GHC.STRef ( STRef )
72 import GHC.Ptr ( Ptr, FunPtr )
73 import GHC.Stable
74 import GHC.Arr ( Array, STArray )
75 import Data.Int
76
77 import GHC.Fingerprint.Type
78 import GHC.Fingerprint
79
80 -- | A concrete representation of a (monomorphic) type. 'TypeRep'
81 -- supports reasonably efficient equality.
82 data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [TypeRep]
83
84 -- Compare keys for equality
85 instance Eq TypeRep where
86 (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
87
88 instance Ord TypeRep where
89 (TypeRep k1 _ _) <= (TypeRep k2 _ _) = k1 <= k2
90
91 -- | An abstract representation of a type constructor. 'TyCon' objects can
92 -- be built using 'mkTyCon'.
93 data TyCon = TyCon {
94 tyConHash :: {-# UNPACK #-} !Fingerprint,
95 tyConPackage :: String,
96 tyConModule :: String,
97 tyConName :: String
98 }
99
100 instance Eq TyCon where
101 (TyCon t1 _ _ _) == (TyCon t2 _ _ _) = t1 == t2
102
103 instance Ord TyCon where
104 (TyCon k1 _ _ _) <= (TyCon k2 _ _ _) = k1 <= k2
105
106 ----------------- Construction --------------------
107
108 #include "MachDeps.h"
109
110 -- mkTyCon is an internal function to make it easier for GHC to
111 -- generate derived instances. GHC precomputes the MD5 hash for the
112 -- TyCon and passes it as two separate 64-bit values to mkTyCon. The
113 -- TyCon for a derived Typeable instance will end up being statically
114 -- allocated.
115
116 #if WORD_SIZE_IN_BITS < 64
117 mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon
118 #else
119 mkTyCon :: Word# -> Word# -> String -> String -> String -> TyCon
120 #endif
121 mkTyCon high# low# pkg modl name
122 = TyCon (Fingerprint (W64# high#) (W64# low#)) pkg modl name
123
124 -- | Applies a type constructor to a sequence of types
125 mkTyConApp :: TyCon -> [TypeRep] -> TypeRep
126 mkTyConApp tc@(TyCon tc_k _ _ _) []
127 = TypeRep tc_k tc [] -- optimisation: all derived Typeable instances
128 -- end up here, and it helps generate smaller
129 -- code for derived Typeable.
130 mkTyConApp tc@(TyCon tc_k _ _ _) args
131 = TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc args
132 where
133 arg_ks = [k | TypeRep k _ _ <- args]
134
135 -- | A special case of 'mkTyConApp', which applies the function
136 -- type constructor to a pair of types.
137 mkFunTy :: TypeRep -> TypeRep -> TypeRep
138 mkFunTy f a = mkTyConApp funTc [f,a]
139
140 -- | Splits a type constructor application
141 splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
142 splitTyConApp (TypeRep _ tc trs) = (tc,trs)
143
144 -- | Applies a type to a function type. Returns: @'Just' u@ if the
145 -- first argument represents a function of type @t -> u@ and the
146 -- second argument represents a function of type @t@. Otherwise,
147 -- returns 'Nothing'.
148 funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
149 funResultTy trFun trArg
150 = case splitTyConApp trFun of
151 (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2
152 _ -> Nothing
153
154 -- | Adds a TypeRep argument to a TypeRep.
155 mkAppTy :: TypeRep -> TypeRep -> TypeRep
156 mkAppTy (TypeRep _ tc trs) arg_tr = mkTyConApp tc (trs ++ [arg_tr])
157 -- Notice that we call mkTyConApp to construct the fingerprint from tc and
158 -- the arg fingerprints. Simply combining the current fingerprint with
159 -- the new one won't give the same answer, but of course we want to
160 -- ensure that a TypeRep of the same shape has the same fingerprint!
161 -- See Trac #5962
162
163 -- | Builds a 'TyCon' object representing a type constructor. An
164 -- implementation of "Data.Typeable" should ensure that the following holds:
165 --
166 -- > A==A' ^ B==B' ^ C==C' ==> mkTyCon A B C == mkTyCon A' B' C'
167 --
168
169 --
170 mkTyCon3 :: String -- ^ package name
171 -> String -- ^ module name
172 -> String -- ^ the name of the type constructor
173 -> TyCon -- ^ A unique 'TyCon' object
174 mkTyCon3 pkg modl name =
175 TyCon (fingerprintString (unwords [pkg, modl, name])) pkg modl name
176
177 ----------------- Observation ---------------------
178
179 -- | Observe the type constructor of a type representation
180 typeRepTyCon :: TypeRep -> TyCon
181 typeRepTyCon (TypeRep _ tc _) = tc
182
183 -- | Observe the argument types of a type representation
184 typeRepArgs :: TypeRep -> [TypeRep]
185 typeRepArgs (TypeRep _ _ args) = args
186
187 -- | Observe string encoding of a type representation
188 {-# DEPRECATED tyConString "renamed to tyConName; tyConModule and tyConPackage are also available." #-} -- deprecated in 7.4
189 tyConString :: TyCon -> String
190 tyConString = tyConName
191
192 -------------------------------------------------------------
193 --
194 -- The Typeable class and friends
195 --
196 -------------------------------------------------------------
197
198 {- Note [Memoising typeOf]
199 ~~~~~~~~~~~~~~~~~~~~~~~~~~
200 IMPORTANT: we don't want to recalculate the type-rep once per
201 call to the dummy argument. This is what went wrong in Trac #3245
202 So we help GHC by manually keeping the 'rep' *outside* the value
203 lambda, thus
204
205 typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
206 typeOfDefault = \_ -> rep
207 where
208 rep = typeOf1 (undefined :: t a) `mkAppTy`
209 typeOf (undefined :: a)
210
211 Notice the crucial use of scoped type variables here!
212 -}
213
214 -- | The class 'Typeable' allows a concrete representation of a type to
215 -- be calculated.
216 class Typeable a where
217 typeOf :: a -> TypeRep
218 -- ^ Takes a value of type @a@ and returns a concrete representation
219 -- of that type. The /value/ of the argument should be ignored by
220 -- any instance of 'Typeable', so that it is safe to pass 'undefined' as
221 -- the argument.
222
223 -- | Variant for unary type constructors
224 class Typeable1 t where
225 typeOf1 :: t a -> TypeRep
226
227 #ifdef __GLASGOW_HASKELL__
228 -- | For defining a 'Typeable' instance from any 'Typeable1' instance.
229 typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
230 typeOfDefault = \_ -> rep
231 where
232 rep = typeOf1 (undefined :: t a) `mkAppTy`
233 typeOf (undefined :: a)
234 -- Note [Memoising typeOf]
235 #else
236 -- | For defining a 'Typeable' instance from any 'Typeable1' instance.
237 typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep
238 typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x)
239 where
240 argType :: t a -> a
241 argType = undefined
242 #endif
243
244 -- | Variant for binary type constructors
245 class Typeable2 t where
246 typeOf2 :: t a b -> TypeRep
247
248 #ifdef __GLASGOW_HASKELL__
249 -- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
250 typeOf1Default :: forall t a b. (Typeable2 t, Typeable a) => t a b -> TypeRep
251 typeOf1Default = \_ -> rep
252 where
253 rep = typeOf2 (undefined :: t a b) `mkAppTy`
254 typeOf (undefined :: a)
255 -- Note [Memoising typeOf]
256 #else
257 -- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
258 typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep
259 typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x)
260 where
261 argType :: t a b -> a
262 argType = undefined
263 #endif
264
265 -- | Variant for 3-ary type constructors
266 class Typeable3 t where
267 typeOf3 :: t a b c -> TypeRep
268
269 #ifdef __GLASGOW_HASKELL__
270 -- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
271 typeOf2Default :: forall t a b c. (Typeable3 t, Typeable a) => t a b c -> TypeRep
272 typeOf2Default = \_ -> rep
273 where
274 rep = typeOf3 (undefined :: t a b c) `mkAppTy`
275 typeOf (undefined :: a)
276 -- Note [Memoising typeOf]
277 #else
278 -- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
279 typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep
280 typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x)
281 where
282 argType :: t a b c -> a
283 argType = undefined
284 #endif
285
286 -- | Variant for 4-ary type constructors
287 class Typeable4 t where
288 typeOf4 :: t a b c d -> TypeRep
289
290 #ifdef __GLASGOW_HASKELL__
291 -- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
292 typeOf3Default :: forall t a b c d. (Typeable4 t, Typeable a) => t a b c d -> TypeRep
293 typeOf3Default = \_ -> rep
294 where
295 rep = typeOf4 (undefined :: t a b c d) `mkAppTy`
296 typeOf (undefined :: a)
297 -- Note [Memoising typeOf]
298 #else
299 -- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
300 typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep
301 typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x)
302 where
303 argType :: t a b c d -> a
304 argType = undefined
305 #endif
306
307 -- | Variant for 5-ary type constructors
308 class Typeable5 t where
309 typeOf5 :: t a b c d e -> TypeRep
310
311 #ifdef __GLASGOW_HASKELL__
312 -- | For defining a 'Typeable4' instance from any 'Typeable5' instance.
313 typeOf4Default :: forall t a b c d e. (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
314 typeOf4Default = \_ -> rep
315 where
316 rep = typeOf5 (undefined :: t a b c d e) `mkAppTy`
317 typeOf (undefined :: a)
318 -- Note [Memoising typeOf]
319 #else
320 -- | For defining a 'Typeable4' instance from any 'Typeable5' instance.
321 typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
322 typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x)
323 where
324 argType :: t a b c d e -> a
325 argType = undefined
326 #endif
327
328 -- | Variant for 6-ary type constructors
329 class Typeable6 t where
330 typeOf6 :: t a b c d e f -> TypeRep
331
332 #ifdef __GLASGOW_HASKELL__
333 -- | For defining a 'Typeable5' instance from any 'Typeable6' instance.
334 typeOf5Default :: forall t a b c d e f. (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
335 typeOf5Default = \_ -> rep
336 where
337 rep = typeOf6 (undefined :: t a b c d e f) `mkAppTy`
338 typeOf (undefined :: a)
339 -- Note [Memoising typeOf]
340 #else
341 -- | For defining a 'Typeable5' instance from any 'Typeable6' instance.
342 typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
343 typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x)
344 where
345 argType :: t a b c d e f -> a
346 argType = undefined
347 #endif
348
349 -- | Variant for 7-ary type constructors
350 class Typeable7 t where
351 typeOf7 :: t a b c d e f g -> TypeRep
352
353 #ifdef __GLASGOW_HASKELL__
354 -- | For defining a 'Typeable6' instance from any 'Typeable7' instance.
355 typeOf6Default :: forall t a b c d e f g. (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
356 typeOf6Default = \_ -> rep
357 where
358 rep = typeOf7 (undefined :: t a b c d e f g) `mkAppTy`
359 typeOf (undefined :: a)
360 -- Note [Memoising typeOf]
361 #else
362 -- | For defining a 'Typeable6' instance from any 'Typeable7' instance.
363 typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
364 typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x)
365 where
366 argType :: t a b c d e f g -> a
367 argType = undefined
368 #endif
369
370 #ifdef __GLASGOW_HASKELL__
371 -- Given a @Typeable@/n/ instance for an /n/-ary type constructor,
372 -- define the instances for partial applications.
373 -- Programmers using non-GHC implementations must do this manually
374 -- for each type constructor.
375 -- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.)
376
377 -- | One Typeable instance for all Typeable1 instances
378 instance (Typeable1 s, Typeable a)
379 => Typeable (s a) where
380 typeOf = typeOfDefault
381
382 -- | One Typeable1 instance for all Typeable2 instances
383 instance (Typeable2 s, Typeable a)
384 => Typeable1 (s a) where
385 typeOf1 = typeOf1Default
386
387 -- | One Typeable2 instance for all Typeable3 instances
388 instance (Typeable3 s, Typeable a)
389 => Typeable2 (s a) where
390 typeOf2 = typeOf2Default
391
392 -- | One Typeable3 instance for all Typeable4 instances
393 instance (Typeable4 s, Typeable a)
394 => Typeable3 (s a) where
395 typeOf3 = typeOf3Default
396
397 -- | One Typeable4 instance for all Typeable5 instances
398 instance (Typeable5 s, Typeable a)
399 => Typeable4 (s a) where
400 typeOf4 = typeOf4Default
401
402 -- | One Typeable5 instance for all Typeable6 instances
403 instance (Typeable6 s, Typeable a)
404 => Typeable5 (s a) where
405 typeOf5 = typeOf5Default
406
407 -- | One Typeable6 instance for all Typeable7 instances
408 instance (Typeable7 s, Typeable a)
409 => Typeable6 (s a) where
410 typeOf6 = typeOf6Default
411
412 #endif /* __GLASGOW_HASKELL__ */
413
414 ----------------- Showing TypeReps --------------------
415
416 instance Show TypeRep where
417 showsPrec p (TypeRep _ tycon tys) =
418 case tys of
419 [] -> showsPrec p tycon
420 [x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
421 [a,r] | tycon == funTc -> showParen (p > 8) $
422 showsPrec 9 a .
423 showString " -> " .
424 showsPrec 8 r
425 xs | isTupleTyCon tycon -> showTuple xs
426 | otherwise ->
427 showParen (p > 9) $
428 showsPrec p tycon .
429 showChar ' ' .
430 showArgs tys
431
432 showsTypeRep :: TypeRep -> ShowS
433 showsTypeRep = shows
434
435 instance Show TyCon where
436 showsPrec _ t = showString (tyConName t)
437
438 isTupleTyCon :: TyCon -> Bool
439 isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True
440 isTupleTyCon _ = False
441
442 -- Some (Show.TypeRep) helpers:
443
444 showArgs :: Show a => [a] -> ShowS
445 showArgs [] = id
446 showArgs [a] = showsPrec 10 a
447 showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
448
449 showTuple :: [TypeRep] -> ShowS
450 showTuple args = showChar '('
451 . (foldr (.) id $ intersperse (showChar ',')
452 $ map (showsPrec 10) args)
453 . showChar ')'
454
455 #if defined(__GLASGOW_HASKELL__)
456 listTc :: TyCon
457 listTc = typeRepTyCon (typeOf [()])
458
459 funTc :: TyCon
460 funTc = mkTyCon3 "ghc-prim" "GHC.Types" "->"
461 #endif
462
463 -------------------------------------------------------------
464 --
465 -- Instances of the Typeable classes for Prelude types
466 --
467 -------------------------------------------------------------
468
469 #include "OldTypeable.h"
470
471 INSTANCE_TYPEABLE0((),unitTc,"()")
472 INSTANCE_TYPEABLE1([],listTc,"[]")
473 INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
474 INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
475 #if defined(__GLASGOW_HASKELL__)
476 {-
477 TODO: Deriving this instance fails with:
478 libraries/base/Data/Typeable.hs:589:1:
479 Can't make a derived instance of `Typeable2 (->)':
480 The last argument of the instance must be a data or newtype application
481 In the stand-alone deriving instance for `Typeable2 (->)'
482 -}
483 instance Typeable2 (->) where { typeOf2 _ = mkTyConApp funTc [] }
484 #else
485 INSTANCE_TYPEABLE2((->),funTc,"->")
486 #endif
487 INSTANCE_TYPEABLE1(IO,ioTc,"IO")
488
489 #if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
490 -- Types defined in GHC.MVar
491 INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
492 #endif
493
494 INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
495 INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray")
496
497 #ifdef __GLASGOW_HASKELL__
498 -- Hugs has these too, but their Typeable<n> instances are defined
499 -- elsewhere to keep this module within Haskell 98.
500 -- This is important because every invocation of runhugs or ffihugs
501 -- uses this module via Data.Dynamic.
502 INSTANCE_TYPEABLE2(ST,stTc,"ST")
503 INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")
504 INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray")
505 #endif
506
507 INSTANCE_TYPEABLE2((,),pairTc,"(,)")
508 INSTANCE_TYPEABLE3((,,),tup3Tc,"(,,)")
509 INSTANCE_TYPEABLE4((,,,),tup4Tc,"(,,,)")
510 INSTANCE_TYPEABLE5((,,,,),tup5Tc,"(,,,,)")
511 INSTANCE_TYPEABLE6((,,,,,),tup6Tc,"(,,,,,)")
512 INSTANCE_TYPEABLE7((,,,,,,),tup7Tc,"(,,,,,,)")
513
514 INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
515 INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")
516 #ifndef __GLASGOW_HASKELL__
517 INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
518 #endif
519 INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
520 INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")
521
522 -------------------------------------------------------
523 --
524 -- Generate Typeable instances for standard datatypes
525 --
526 -------------------------------------------------------
527
528 INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
529 INSTANCE_TYPEABLE0(Char,charTc,"Char")
530 INSTANCE_TYPEABLE0(Float,floatTc,"Float")
531 INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
532 INSTANCE_TYPEABLE0(Int,intTc,"Int")
533 INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
534 INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
535 INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
536 #ifndef __GLASGOW_HASKELL__
537 INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
538 #endif
539
540 INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
541 INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
542 INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
543 INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
544
545 INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )
546 INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
547 INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
548 INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
549
550 INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
551 INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
552
553 #ifdef __GLASGOW_HASKELL__
554 {-
555 TODO: This can't be derived currently:
556 libraries/base/Data/Typeable.hs:674:1:
557 Can't make a derived instance of `Typeable RealWorld':
558 The last argument of the instance must be a data or newtype application
559 In the stand-alone deriving instance for `Typeable RealWorld'
560 -}
561 realWorldTc :: TyCon; \
562 realWorldTc = mkTyCon3 "ghc-prim" "GHC.Types" "RealWorld"; \
563 instance Typeable RealWorld where { typeOf _ = mkTyConApp realWorldTc [] }
564
565 #endif