Add comments about the {-# INCOHERENT #-} for Typeable (f a)
[ghc.git] / libraries / base / Data / Typeable / Internal.hs
1 {-# LANGUAGE Unsafe #-}
2 {-# LANGUAGE BangPatterns #-}
3
4 -----------------------------------------------------------------------------
5 -- |
6 -- Module : Data.Typeable.Internal
7 -- Copyright : (c) The University of Glasgow, CWI 2001--2011
8 -- License : BSD-style (see the file libraries/base/LICENSE)
9 --
10 -- The representations of the types TyCon and TypeRep, and the
11 -- function mkTyCon which is used by derived instances of Typeable to
12 -- construct a TyCon.
13 --
14 -----------------------------------------------------------------------------
15
16 {-# LANGUAGE CPP
17 , NoImplicitPrelude
18 , OverlappingInstances
19 , ScopedTypeVariables
20 , FlexibleInstances
21 , MagicHash
22 , KindSignatures
23 , PolyKinds
24 , ConstraintKinds
25 , DeriveDataTypeable
26 , DataKinds
27 , UndecidableInstances
28 , StandaloneDeriving #-}
29
30 module Data.Typeable.Internal (
31 Proxy (..),
32 TypeRep(..),
33 Fingerprint(..),
34 typeOf, typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7,
35 Typeable1, Typeable2, Typeable3, Typeable4, Typeable5, Typeable6, Typeable7,
36 TyCon(..),
37 typeRep,
38 mkTyCon,
39 mkTyCon3,
40 mkTyConApp,
41 mkAppTy,
42 typeRepTyCon,
43 Typeable(..),
44 mkFunTy,
45 splitTyConApp,
46 funResultTy,
47 typeRepArgs,
48 showsTypeRep,
49 tyConString,
50 listTc, funTc
51 ) where
52
53 import GHC.Base
54 import GHC.Word
55 import GHC.Show
56 import GHC.Read ( Read )
57 import Data.Maybe
58 import Data.Proxy
59 import GHC.Num
60 import GHC.Real
61 -- import GHC.IORef
62 -- import GHC.IOArray
63 -- import GHC.MVar
64 import GHC.ST ( ST, STret )
65 import GHC.STRef ( STRef )
66 import GHC.Ptr ( Ptr, FunPtr )
67 -- import GHC.Stable
68 import GHC.Arr ( Array, STArray, Ix )
69 import GHC.TypeLits ( Nat, Symbol, KnownNat, KnownSymbol, natVal', symbolVal' )
70 import Data.Type.Coercion
71 import Data.Type.Equality
72 import Text.ParserCombinators.ReadP ( ReadP )
73 import Text.Read.Lex ( Lexeme, Number )
74 import Text.ParserCombinators.ReadPrec ( ReadPrec )
75 import GHC.Float ( FFFormat, RealFloat, Floating )
76 import Data.Bits ( Bits, FiniteBits )
77 import GHC.Enum ( Bounded, Enum )
78 import Control.Monad ( MonadPlus )
79 -- import Data.Int
80
81 import GHC.Fingerprint.Type
82 import {-# SOURCE #-} GHC.Fingerprint
83 -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable
84 -- Better to break the loop here, because we want non-SOURCE imports
85 -- of Data.Typeable as much as possible so we can optimise the derived
86 -- instances.
87
88 -- | A concrete representation of a (monomorphic) type. 'TypeRep'
89 -- supports reasonably efficient equality.
90 data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [TypeRep]
91
92 -- Compare keys for equality
93 instance Eq TypeRep where
94 (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
95
96 instance Ord TypeRep where
97 (TypeRep k1 _ _) <= (TypeRep k2 _ _) = k1 <= k2
98
99 -- | An abstract representation of a type constructor. 'TyCon' objects can
100 -- be built using 'mkTyCon'.
101 data TyCon = TyCon {
102 tyConHash :: {-# UNPACK #-} !Fingerprint,
103 tyConPackage :: String, -- ^ /Since: 4.5.0.0/
104 tyConModule :: String, -- ^ /Since: 4.5.0.0/
105 tyConName :: String -- ^ /Since: 4.5.0.0/
106 }
107
108 instance Eq TyCon where
109 (TyCon t1 _ _ _) == (TyCon t2 _ _ _) = t1 == t2
110
111 instance Ord TyCon where
112 (TyCon k1 _ _ _) <= (TyCon k2 _ _ _) = k1 <= k2
113
114 ----------------- Construction --------------------
115
116 #include "MachDeps.h"
117
118 -- mkTyCon is an internal function to make it easier for GHC to
119 -- generate derived instances. GHC precomputes the MD5 hash for the
120 -- TyCon and passes it as two separate 64-bit values to mkTyCon. The
121 -- TyCon for a derived Typeable instance will end up being statically
122 -- allocated.
123
124 #if WORD_SIZE_IN_BITS < 64
125 mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon
126 #else
127 mkTyCon :: Word# -> Word# -> String -> String -> String -> TyCon
128 #endif
129 mkTyCon high# low# pkg modl name
130 = TyCon (Fingerprint (W64# high#) (W64# low#)) pkg modl name
131
132 -- | Applies a type constructor to a sequence of types
133 mkTyConApp :: TyCon -> [TypeRep] -> TypeRep
134 mkTyConApp tc@(TyCon tc_k _ _ _) []
135 = TypeRep tc_k tc [] -- optimisation: all derived Typeable instances
136 -- end up here, and it helps generate smaller
137 -- code for derived Typeable.
138 mkTyConApp tc@(TyCon tc_k _ _ _) args
139 = TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc args
140 where
141 arg_ks = [k | TypeRep k _ _ <- args]
142
143 -- | A special case of 'mkTyConApp', which applies the function
144 -- type constructor to a pair of types.
145 mkFunTy :: TypeRep -> TypeRep -> TypeRep
146 mkFunTy f a = mkTyConApp funTc [f,a]
147
148 -- | Splits a type constructor application
149 splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
150 splitTyConApp (TypeRep _ tc trs) = (tc,trs)
151
152 -- | Applies a type to a function type. Returns: @'Just' u@ if the
153 -- first argument represents a function of type @t -> u@ and the
154 -- second argument represents a function of type @t@. Otherwise,
155 -- returns 'Nothing'.
156 funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
157 funResultTy trFun trArg
158 = case splitTyConApp trFun of
159 (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2
160 _ -> Nothing
161
162 -- | Adds a TypeRep argument to a TypeRep.
163 mkAppTy :: TypeRep -> TypeRep -> TypeRep
164 mkAppTy (TypeRep _ tc trs) arg_tr = mkTyConApp tc (trs ++ [arg_tr])
165 -- Notice that we call mkTyConApp to construct the fingerprint from tc and
166 -- the arg fingerprints. Simply combining the current fingerprint with
167 -- the new one won't give the same answer, but of course we want to
168 -- ensure that a TypeRep of the same shape has the same fingerprint!
169 -- See Trac #5962
170
171 -- | Builds a 'TyCon' object representing a type constructor. An
172 -- implementation of "Data.Typeable" should ensure that the following holds:
173 --
174 -- > A==A' ^ B==B' ^ C==C' ==> mkTyCon A B C == mkTyCon A' B' C'
175 --
176
177 --
178 mkTyCon3 :: String -- ^ package name
179 -> String -- ^ module name
180 -> String -- ^ the name of the type constructor
181 -> TyCon -- ^ A unique 'TyCon' object
182 mkTyCon3 pkg modl name =
183 TyCon (fingerprintString (pkg ++ (' ':modl) ++ (' ':name))) pkg modl name
184
185 ----------------- Observation ---------------------
186
187 -- | Observe the type constructor of a type representation
188 typeRepTyCon :: TypeRep -> TyCon
189 typeRepTyCon (TypeRep _ tc _) = tc
190
191 -- | Observe the argument types of a type representation
192 typeRepArgs :: TypeRep -> [TypeRep]
193 typeRepArgs (TypeRep _ _ args) = args
194
195 -- | Observe string encoding of a type representation
196 {-# DEPRECATED tyConString "renamed to 'tyConName'; 'tyConModule' and 'tyConPackage' are also available." #-} -- deprecated in 7.4
197 tyConString :: TyCon -> String
198 tyConString = tyConName
199
200 -------------------------------------------------------------
201 --
202 -- The Typeable class and friends
203 --
204 -------------------------------------------------------------
205
206 -- | The class 'Typeable' allows a concrete representation of a type to
207 -- be calculated.
208 class Typeable a where
209 typeRep# :: Proxy# a -> TypeRep
210
211 -- | Takes a value of type @a@ and returns a concrete representation
212 -- of that type.
213 --
214 -- /Since: 4.7.0.0/
215 typeRep :: forall proxy a. Typeable a => proxy a -> TypeRep
216 typeRep _ = typeRep# (proxy# :: Proxy# a)
217 {-# INLINE typeRep #-}
218
219 -- Keeping backwards-compatibility
220 typeOf :: forall a. Typeable a => a -> TypeRep
221 typeOf _ = typeRep (Proxy :: Proxy a)
222
223 typeOf1 :: forall t (a :: *). Typeable t => t a -> TypeRep
224 typeOf1 _ = typeRep (Proxy :: Proxy t)
225
226 typeOf2 :: forall t (a :: *) (b :: *). Typeable t => t a b -> TypeRep
227 typeOf2 _ = typeRep (Proxy :: Proxy t)
228
229 typeOf3 :: forall t (a :: *) (b :: *) (c :: *). Typeable t
230 => t a b c -> TypeRep
231 typeOf3 _ = typeRep (Proxy :: Proxy t)
232
233 typeOf4 :: forall t (a :: *) (b :: *) (c :: *) (d :: *). Typeable t
234 => t a b c d -> TypeRep
235 typeOf4 _ = typeRep (Proxy :: Proxy t)
236
237 typeOf5 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *). Typeable t
238 => t a b c d e -> TypeRep
239 typeOf5 _ = typeRep (Proxy :: Proxy t)
240
241 typeOf6 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *).
242 Typeable t => t a b c d e f -> TypeRep
243 typeOf6 _ = typeRep (Proxy :: Proxy t)
244
245 typeOf7 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *)
246 (g :: *). Typeable t => t a b c d e f g -> TypeRep
247 typeOf7 _ = typeRep (Proxy :: Proxy t)
248
249 type Typeable1 (a :: * -> *) = Typeable a
250 type Typeable2 (a :: * -> * -> *) = Typeable a
251 type Typeable3 (a :: * -> * -> * -> *) = Typeable a
252 type Typeable4 (a :: * -> * -> * -> * -> *) = Typeable a
253 type Typeable5 (a :: * -> * -> * -> * -> * -> *) = Typeable a
254 type Typeable6 (a :: * -> * -> * -> * -> * -> * -> *) = Typeable a
255 type Typeable7 (a :: * -> * -> * -> * -> * -> * -> * -> *) = Typeable a
256
257 {-# DEPRECATED Typeable1 "renamed to 'Typeable'" #-} -- deprecated in 7.8
258 {-# DEPRECATED Typeable2 "renamed to 'Typeable'" #-} -- deprecated in 7.8
259 {-# DEPRECATED Typeable3 "renamed to 'Typeable'" #-} -- deprecated in 7.8
260 {-# DEPRECATED Typeable4 "renamed to 'Typeable'" #-} -- deprecated in 7.8
261 {-# DEPRECATED Typeable5 "renamed to 'Typeable'" #-} -- deprecated in 7.8
262 {-# DEPRECATED Typeable6 "renamed to 'Typeable'" #-} -- deprecated in 7.8
263 {-# DEPRECATED Typeable7 "renamed to 'Typeable'" #-} -- deprecated in 7.8
264
265 -- | Kind-polymorphic Typeable instance for type application
266 instance {-# INCOHERENT #-} (Typeable s, Typeable a) => Typeable (s a) where
267 -- See Note [The apparent incoherence of Typable]
268 typeRep# = \_ -> rep -- Note [Memoising typeOf]
269 where !ty1 = typeRep# (proxy# :: Proxy# s)
270 !ty2 = typeRep# (proxy# :: Proxy# a)
271 !rep = ty1 `mkAppTy` ty2
272
273
274 {- Note [The apparent incoherence of Typable] See Trac #9242
275 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
276 The reason we have INCOHERENT here is because we also have instances
277 instance Typeable (x::Nat)
278 instance Typeable (y::Symbol)
279 If we have
280 [Wanted] Typeable (a :: Nat)
281
282 we should pick the (x::Nat) instance, even though the instance
283 matching rules would worry that 'a' might later be instantiated to
284 (f b), for some f and b. But we type theorists know that there are no
285 type constructors f of kind blah -> Nat, so this can never happen and
286 it's safe to pick the second instance.
287
288 Note [Memoising typeOf]
289 ~~~~~~~~~~~~~~~~~~~~~~~
290 See #3245, #9203
291
292 IMPORTANT: we don't want to recalculate the TypeRep once per call with
293 the proxy argument. This is what went wrong in #3245 and #9203. So we
294 help GHC by manually keeping the 'rep' *outside* the lambda.
295 -}
296
297 ----------------- Showing TypeReps --------------------
298
299 instance Show TypeRep where
300 showsPrec p (TypeRep _ tycon tys) =
301 case tys of
302 [] -> showsPrec p tycon
303 [x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
304 [a,r] | tycon == funTc -> showParen (p > 8) $
305 showsPrec 9 a .
306 showString " -> " .
307 showsPrec 8 r
308 xs | isTupleTyCon tycon -> showTuple xs
309 | otherwise ->
310 showParen (p > 9) $
311 showsPrec p tycon .
312 showChar ' ' .
313 showArgs (showChar ' ') tys
314
315 showsTypeRep :: TypeRep -> ShowS
316 showsTypeRep = shows
317
318 instance Show TyCon where
319 showsPrec _ t = showString (tyConName t)
320
321 isTupleTyCon :: TyCon -> Bool
322 isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True
323 isTupleTyCon _ = False
324
325 -- Some (Show.TypeRep) helpers:
326
327 showArgs :: Show a => ShowS -> [a] -> ShowS
328 showArgs _ [] = id
329 showArgs _ [a] = showsPrec 10 a
330 showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as
331
332 showTuple :: [TypeRep] -> ShowS
333 showTuple args = showChar '('
334 . showArgs (showChar ',') args
335 . showChar ')'
336
337 listTc :: TyCon
338 listTc = typeRepTyCon (typeOf [()])
339
340 funTc :: TyCon
341 funTc = typeRepTyCon (typeRep (Proxy :: Proxy (->)))
342
343 -------------------------------------------------------------
344 --
345 -- Instances of the Typeable classes for Prelude types
346 --
347 -------------------------------------------------------------
348
349 deriving instance Typeable ()
350 deriving instance Typeable []
351 deriving instance Typeable Maybe
352 deriving instance Typeable Ratio
353 deriving instance Typeable (->)
354 deriving instance Typeable IO
355
356 deriving instance Typeable Array
357
358 deriving instance Typeable ST
359 deriving instance Typeable STret
360 deriving instance Typeable STRef
361 deriving instance Typeable STArray
362
363 deriving instance Typeable (,)
364 deriving instance Typeable (,,)
365 deriving instance Typeable (,,,)
366 deriving instance Typeable (,,,,)
367 deriving instance Typeable (,,,,,)
368 deriving instance Typeable (,,,,,,)
369
370 deriving instance Typeable Ptr
371 deriving instance Typeable FunPtr
372
373 -------------------------------------------------------
374 --
375 -- Generate Typeable instances for standard datatypes
376 --
377 -------------------------------------------------------
378
379 deriving instance Typeable Bool
380 deriving instance Typeable Char
381 deriving instance Typeable Float
382 deriving instance Typeable Double
383 deriving instance Typeable Int
384 deriving instance Typeable Word
385 deriving instance Typeable Integer
386 deriving instance Typeable Ordering
387
388 deriving instance Typeable Word8
389 deriving instance Typeable Word16
390 deriving instance Typeable Word32
391 deriving instance Typeable Word64
392
393 deriving instance Typeable TyCon
394 deriving instance Typeable TypeRep
395 deriving instance Typeable Fingerprint
396
397 deriving instance Typeable RealWorld
398 deriving instance Typeable Proxy
399 deriving instance Typeable KProxy
400 deriving instance Typeable (:~:)
401 deriving instance Typeable Coercion
402
403 deriving instance Typeable ReadP
404 deriving instance Typeable Lexeme
405 deriving instance Typeable Number
406 deriving instance Typeable ReadPrec
407
408 deriving instance Typeable FFFormat
409
410 -------------------------------------------------------
411 --
412 -- Generate Typeable instances for standard classes
413 --
414 -------------------------------------------------------
415
416 deriving instance Typeable (~)
417 deriving instance Typeable Coercible
418 deriving instance Typeable TestEquality
419 deriving instance Typeable TestCoercion
420
421 deriving instance Typeable Eq
422 deriving instance Typeable Ord
423
424 deriving instance Typeable Bits
425 deriving instance Typeable FiniteBits
426 deriving instance Typeable Num
427 deriving instance Typeable Real
428 deriving instance Typeable Integral
429 deriving instance Typeable Fractional
430 deriving instance Typeable RealFrac
431 deriving instance Typeable Floating
432 deriving instance Typeable RealFloat
433
434 deriving instance Typeable Bounded
435 deriving instance Typeable Enum
436 deriving instance Typeable Ix
437
438 deriving instance Typeable Show
439 deriving instance Typeable Read
440
441 deriving instance Typeable Functor
442 deriving instance Typeable Monad
443 deriving instance Typeable MonadPlus
444
445 deriving instance Typeable Typeable
446
447
448
449 --------------------------------------------------------------------------------
450 -- Instances for type literals
451
452 {- Note [Potential Collisions in `Nat` and `Symbol` instances]
453
454 Kinds resulting from lifted types have finitely many type-constructors.
455 This is not the case for `Nat` and `Symbol`, which both contain *infinitely*
456 many type constructors (e.g., `Nat` has 0, 1, 2, 3, etc.). One might think
457 that this would increase the chance of hash-collisions in the type but this
458 is not the case because the fingerprint stored in a `TypeRep` identifies
459 the whole *type* and not just the type constructor. This is why the chance
460 of collisions for `Nat` and `Symbol` is not any worse than it is for other
461 lifted types with infinitely many inhabitants. Indeed, `Nat` is
462 isomorphic to (lifted) `[()]` and `Symbol` is isomorphic to `[Char]`.
463 -}
464
465 instance KnownNat n => Typeable (n :: Nat) where
466 -- See Note [The apparent incoherence of Typable]
467 -- See #9203 for an explanation of why this is written as `\_ -> rep`.
468 typeRep# = \_ -> rep
469 where
470 rep = mkTyConApp tc []
471 tc = TyCon
472 { tyConHash = fingerprintString (mk pack modu nm)
473 , tyConPackage = pack
474 , tyConModule = modu
475 , tyConName = nm
476 }
477 pack = "base"
478 modu = "GHC.TypeLits"
479 nm = show (natVal' (proxy# :: Proxy# n))
480 mk a b c = a ++ " " ++ b ++ " " ++ c
481
482
483 instance KnownSymbol s => Typeable (s :: Symbol) where
484 -- See Note [The apparent incoherence of Typable]
485 -- See #9203 for an explanation of why this is written as `\_ -> rep`.
486 typeRep# = \_ -> rep
487 where
488 rep = mkTyConApp tc []
489 tc = TyCon
490 { tyConHash = fingerprintString (mk pack modu nm)
491 , tyConPackage = pack
492 , tyConModule = modu
493 , tyConName = nm
494 }
495 pack = "base"
496 modu = "GHC.TypeLits"
497 nm = show (symbolVal' (proxy# :: Proxy# s))
498 mk a b c = a ++ " " ++ b ++ " " ++ c
499