93b64ef9e94d24fdc5557badf4a9e845e0709154
[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 typeRep# = \_ -> rep -- Note [Memoising typeOf]
268 where !ty1 = typeRep# (proxy# :: Proxy# s)
269 !ty2 = typeRep# (proxy# :: Proxy# a)
270 !rep = ty1 `mkAppTy` ty2
271
272 {- Note [Memoising typeOf]
273 ~~~~~~~~~~~~~~~~~~~~~~~~~~
274 See #3245, #9203
275
276 IMPORTANT: we don't want to recalculate the TypeRep once per call with
277 the proxy argument. This is what went wrong in #3245 and #9203. So we
278 help GHC by manually keeping the 'rep' *outside* the lambda.
279 -}
280
281 ----------------- Showing TypeReps --------------------
282
283 instance Show TypeRep where
284 showsPrec p (TypeRep _ tycon tys) =
285 case tys of
286 [] -> showsPrec p tycon
287 [x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
288 [a,r] | tycon == funTc -> showParen (p > 8) $
289 showsPrec 9 a .
290 showString " -> " .
291 showsPrec 8 r
292 xs | isTupleTyCon tycon -> showTuple xs
293 | otherwise ->
294 showParen (p > 9) $
295 showsPrec p tycon .
296 showChar ' ' .
297 showArgs (showChar ' ') tys
298
299 showsTypeRep :: TypeRep -> ShowS
300 showsTypeRep = shows
301
302 instance Show TyCon where
303 showsPrec _ t = showString (tyConName t)
304
305 isTupleTyCon :: TyCon -> Bool
306 isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True
307 isTupleTyCon _ = False
308
309 -- Some (Show.TypeRep) helpers:
310
311 showArgs :: Show a => ShowS -> [a] -> ShowS
312 showArgs _ [] = id
313 showArgs _ [a] = showsPrec 10 a
314 showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as
315
316 showTuple :: [TypeRep] -> ShowS
317 showTuple args = showChar '('
318 . showArgs (showChar ',') args
319 . showChar ')'
320
321 listTc :: TyCon
322 listTc = typeRepTyCon (typeOf [()])
323
324 funTc :: TyCon
325 funTc = typeRepTyCon (typeRep (Proxy :: Proxy (->)))
326
327 -------------------------------------------------------------
328 --
329 -- Instances of the Typeable classes for Prelude types
330 --
331 -------------------------------------------------------------
332
333 deriving instance Typeable ()
334 deriving instance Typeable []
335 deriving instance Typeable Maybe
336 deriving instance Typeable Ratio
337 deriving instance Typeable (->)
338 deriving instance Typeable IO
339
340 deriving instance Typeable Array
341
342 deriving instance Typeable ST
343 deriving instance Typeable STret
344 deriving instance Typeable STRef
345 deriving instance Typeable STArray
346
347 deriving instance Typeable (,)
348 deriving instance Typeable (,,)
349 deriving instance Typeable (,,,)
350 deriving instance Typeable (,,,,)
351 deriving instance Typeable (,,,,,)
352 deriving instance Typeable (,,,,,,)
353
354 deriving instance Typeable Ptr
355 deriving instance Typeable FunPtr
356
357 -------------------------------------------------------
358 --
359 -- Generate Typeable instances for standard datatypes
360 --
361 -------------------------------------------------------
362
363 deriving instance Typeable Bool
364 deriving instance Typeable Char
365 deriving instance Typeable Float
366 deriving instance Typeable Double
367 deriving instance Typeable Int
368 deriving instance Typeable Word
369 deriving instance Typeable Integer
370 deriving instance Typeable Ordering
371
372 deriving instance Typeable Word8
373 deriving instance Typeable Word16
374 deriving instance Typeable Word32
375 deriving instance Typeable Word64
376
377 deriving instance Typeable TyCon
378 deriving instance Typeable TypeRep
379 deriving instance Typeable Fingerprint
380
381 deriving instance Typeable RealWorld
382 deriving instance Typeable Proxy
383 deriving instance Typeable KProxy
384 deriving instance Typeable (:~:)
385 deriving instance Typeable Coercion
386
387 deriving instance Typeable ReadP
388 deriving instance Typeable Lexeme
389 deriving instance Typeable Number
390 deriving instance Typeable ReadPrec
391
392 deriving instance Typeable FFFormat
393
394 -------------------------------------------------------
395 --
396 -- Generate Typeable instances for standard classes
397 --
398 -------------------------------------------------------
399
400 deriving instance Typeable (~)
401 deriving instance Typeable Coercible
402 deriving instance Typeable TestEquality
403 deriving instance Typeable TestCoercion
404
405 deriving instance Typeable Eq
406 deriving instance Typeable Ord
407
408 deriving instance Typeable Bits
409 deriving instance Typeable FiniteBits
410 deriving instance Typeable Num
411 deriving instance Typeable Real
412 deriving instance Typeable Integral
413 deriving instance Typeable Fractional
414 deriving instance Typeable RealFrac
415 deriving instance Typeable Floating
416 deriving instance Typeable RealFloat
417
418 deriving instance Typeable Bounded
419 deriving instance Typeable Enum
420 deriving instance Typeable Ix
421
422 deriving instance Typeable Show
423 deriving instance Typeable Read
424
425 deriving instance Typeable Functor
426 deriving instance Typeable Monad
427 deriving instance Typeable MonadPlus
428
429 deriving instance Typeable Typeable
430
431
432
433 --------------------------------------------------------------------------------
434 -- Instances for type literals
435
436 {- Note [Potential Collisions in `Nat` and `Symbol` instances]
437
438 Kinds resulting from lifted types have finitely many type-constructors.
439 This is not the case for `Nat` and `Symbol`, which both contain *infinitely*
440 many type constructors (e.g., `Nat` has 0, 1, 2, 3, etc.). One might think
441 that this would increase the chance of hash-collisions in the type but this
442 is not the case because the fingerprint stored in a `TypeRep` identifies
443 the whole *type* and not just the type constructor. This is why the chance
444 of collisions for `Nat` and `Symbol` is not any worse than it is for other
445 lifted types with infinitely many inhabitants. Indeed, `Nat` is
446 isomorphic to (lifted) `[()]` and `Symbol` is isomorphic to `[Char]`.
447 -}
448
449 instance KnownNat n => Typeable (n :: Nat) where
450 -- See #9203 for an explanation of why this is written as `\_ -> rep`.
451 typeRep# = \_ -> rep
452 where
453 rep = mkTyConApp tc []
454 tc = TyCon
455 { tyConHash = fingerprintString (mk pack modu nm)
456 , tyConPackage = pack
457 , tyConModule = modu
458 , tyConName = nm
459 }
460 pack = "base"
461 modu = "GHC.TypeLits"
462 nm = show (natVal' (proxy# :: Proxy# n))
463 mk a b c = a ++ " " ++ b ++ " " ++ c
464
465
466 instance KnownSymbol s => Typeable (s :: Symbol) where
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 (symbolVal' (proxy# :: Proxy# s))
480 mk a b c = a ++ " " ++ b ++ " " ++ c
481