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