Generate Typeable info at definition sites
[ghc.git] / libraries / base / Data / Typeable / Internal.hs
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE BangPatterns #-}
3 {-# LANGUAGE CPP #-}
4 {-# LANGUAGE ConstraintKinds #-}
5 {-# LANGUAGE DataKinds #-}
6 {-# LANGUAGE FlexibleInstances #-}
7 {-# LANGUAGE MagicHash #-}
8 {-# LANGUAGE NoImplicitPrelude #-}
9 {-# LANGUAGE PolyKinds #-}
10 {-# LANGUAGE ScopedTypeVariables #-}
11 {-# LANGUAGE StandaloneDeriving #-}
12 {-# LANGUAGE UndecidableInstances #-}
13
14 -----------------------------------------------------------------------------
15 -- |
16 -- Module : Data.Typeable.Internal
17 -- Copyright : (c) The University of Glasgow, CWI 2001--2011
18 -- License : BSD-style (see the file libraries/base/LICENSE)
19 --
20 -- The representations of the types TyCon and TypeRep, and the
21 -- function mkTyCon which is used by derived instances of Typeable to
22 -- construct a TyCon.
23 --
24 -----------------------------------------------------------------------------
25
26 module Data.Typeable.Internal (
27 Proxy (..),
28 Fingerprint(..),
29
30 -- * Typeable class
31 typeOf, typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7,
32 Typeable1, Typeable2, Typeable3, Typeable4, Typeable5, Typeable6, Typeable7,
33
34 -- * Module
35 Module, -- Abstract
36 moduleName, modulePackage,
37
38 -- * TyCon
39 TyCon, -- Abstract
40 tyConPackage, tyConModule, tyConName, tyConString, tyConFingerprint,
41 mkTyCon3, mkTyCon3#,
42 rnfTyCon,
43
44 tcBool, tc'True, tc'False,
45 tcOrdering, tc'LT, tc'EQ, tc'GT,
46 tcChar, tcInt, tcWord, tcFloat, tcDouble, tcFun,
47 tcIO, tcSPEC, tcTyCon, tcModule,
48 tcCoercible, tcList, tcEq,
49 tcLiftedKind, tcUnliftedKind, tcOpenKind, tcBOX, tcConstraint, tcAnyK,
50
51 funTc, -- ToDo
52
53 -- * TypeRep
54 TypeRep(..), KindRep,
55 typeRep,
56 mkTyConApp,
57 mkPolyTyConApp,
58 mkAppTy,
59 typeRepTyCon,
60 Typeable(..),
61 mkFunTy,
62 splitTyConApp,
63 splitPolyTyConApp,
64 funResultTy,
65 typeRepArgs,
66 typeRepFingerprint,
67 rnfTypeRep,
68 showsTypeRep,
69 typeRepKinds,
70 typeSymbolTypeRep, typeNatTypeRep
71 ) where
72
73 import GHC.Base
74 import GHC.Word
75 import GHC.Show
76 import Data.Proxy
77 import GHC.TypeLits( KnownNat, KnownSymbol, natVal', symbolVal' )
78
79 import GHC.Fingerprint.Type
80 import {-# SOURCE #-} GHC.Fingerprint
81 -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable
82 -- Better to break the loop here, because we want non-SOURCE imports
83 -- of Data.Typeable as much as possible so we can optimise the derived
84 -- instances.
85
86 #include "MachDeps.h"
87
88 {- *********************************************************************
89 * *
90 The TyCon type
91 * *
92 ********************************************************************* -}
93
94 modulePackage :: Module -> String
95 modulePackage (Module p _) = trNameString p
96
97 moduleName :: Module -> String
98 moduleName (Module _ m) = trNameString m
99
100 tyConPackage :: TyCon -> String
101 tyConPackage (TyCon _ _ m _) = modulePackage m
102
103 tyConModule :: TyCon -> String
104 tyConModule (TyCon _ _ m _) = moduleName m
105
106 tyConName :: TyCon -> String
107 tyConName (TyCon _ _ _ n) = trNameString n
108
109 trNameString :: TrName -> String
110 trNameString (TrNameS s) = unpackCString# s
111 trNameString (TrNameD s) = s
112
113 -- | Observe string encoding of a type representation
114 {-# DEPRECATED tyConString "renamed to 'tyConName'; 'tyConModule' and 'tyConPackage' are also available." #-}
115 -- deprecated in 7.4
116 tyConString :: TyCon -> String
117 tyConString = tyConName
118
119 tyConFingerprint :: TyCon -> Fingerprint
120 tyConFingerprint (TyCon hi lo _ _)
121 = Fingerprint (W64# hi) (W64# lo)
122
123 mkTyCon3# :: Addr# -- ^ package name
124 -> Addr# -- ^ module name
125 -> Addr# -- ^ the name of the type constructor
126 -> TyCon -- ^ A unique 'TyCon' object
127 mkTyCon3# pkg modl name
128 | Fingerprint (W64# hi) (W64# lo) <- fingerprint
129 = TyCon hi lo (Module (TrNameS pkg) (TrNameS modl)) (TrNameS name)
130 where
131 fingerprint :: Fingerprint
132 fingerprint = fingerprintString (unpackCString# pkg
133 ++ (' ': unpackCString# modl)
134 ++ (' ' : unpackCString# name))
135
136 mkTyCon3 :: String -- ^ package name
137 -> String -- ^ module name
138 -> String -- ^ the name of the type constructor
139 -> TyCon -- ^ A unique 'TyCon' object
140 -- Used when the strings are dynamically allocated,
141 -- eg from binary deserialisation
142 mkTyCon3 pkg modl name
143 | Fingerprint (W64# hi) (W64# lo) <- fingerprint
144 = TyCon hi lo (Module (TrNameD pkg) (TrNameD modl)) (TrNameD name)
145 where
146 fingerprint :: Fingerprint
147 fingerprint = fingerprintString (pkg ++ (' ':modl) ++ (' ':name))
148
149 isTupleTyCon :: TyCon -> Bool
150 isTupleTyCon tc
151 | ('(':',':_) <- tyConName tc = True
152 | otherwise = False
153
154 -- | Helper to fully evaluate 'TyCon' for use as @NFData(rnf)@ implementation
155 --
156 -- @since 4.8.0.0
157 rnfModule :: Module -> ()
158 rnfModule (Module p m) = rnfTrName p `seq` rnfTrName m
159
160 rnfTrName :: TrName -> ()
161 rnfTrName (TrNameS _) = ()
162 rnfTrName (TrNameD n) = rnfString n
163
164 rnfTyCon :: TyCon -> ()
165 rnfTyCon (TyCon _ _ m n) = rnfModule m `seq` rnfTrName n
166
167 rnfString :: [Char] -> ()
168 rnfString [] = ()
169 rnfString (c:cs) = c `seq` rnfString cs
170
171
172 {- *********************************************************************
173 * *
174 The TypeRep type
175 * *
176 ********************************************************************* -}
177
178 -- | A concrete representation of a (monomorphic) type.
179 -- 'TypeRep' supports reasonably efficient equality.
180 data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [KindRep] [TypeRep]
181 -- NB: For now I've made this lazy so that it's easy to
182 -- optimise code that constructs and deconstructs TypeReps
183 -- perf/should_run/T9203 is a good example
184 -- Also note that mkAppTy does discards the fingerprint,
185 -- so it's a waste to compute it
186
187 type KindRep = TypeRep
188
189 -- Compare keys for equality
190 instance Eq TypeRep where
191 TypeRep x _ _ _ == TypeRep y _ _ _ = x == y
192
193 instance Ord TypeRep where
194 TypeRep x _ _ _ <= TypeRep y _ _ _ = x <= y
195
196 -- | Observe the 'Fingerprint' of a type representation
197 --
198 -- @since 4.8.0.0
199 typeRepFingerprint :: TypeRep -> Fingerprint
200 typeRepFingerprint (TypeRep fpr _ _ _) = fpr
201
202 -- | Applies a kind-polymorphic type constructor to a sequence of kinds and
203 -- types
204 mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep
205 {-# INLINE mkPolyTyConApp #-}
206 mkPolyTyConApp tc kinds types
207 = TypeRep (fingerprintFingerprints sub_fps) tc kinds types
208 where
209 !kt_fps = typeRepFingerprints kinds types
210 sub_fps = tyConFingerprint tc : kt_fps
211
212 typeRepFingerprints :: [KindRep] -> [TypeRep] -> [Fingerprint]
213 -- Builds no thunks
214 typeRepFingerprints kinds types
215 = go1 [] kinds
216 where
217 go1 acc [] = go2 acc types
218 go1 acc (k:ks) = let !fp = typeRepFingerprint k
219 in go1 (fp:acc) ks
220 go2 acc [] = acc
221 go2 acc (t:ts) = let !fp = typeRepFingerprint t
222 in go2 (fp:acc) ts
223
224 -- | Applies a kind-monomorphic type constructor to a sequence of types
225 mkTyConApp :: TyCon -> [TypeRep] -> TypeRep
226 mkTyConApp tc = mkPolyTyConApp tc []
227
228 -- | A special case of 'mkTyConApp', which applies the function
229 -- type constructor to a pair of types.
230 mkFunTy :: TypeRep -> TypeRep -> TypeRep
231 mkFunTy f a = mkTyConApp tcFun [f,a]
232
233 -- | Splits a type constructor application.
234 -- Note that if the type construcotr is polymorphic, this will
235 -- not return the kinds that were used.
236 -- See 'splitPolyTyConApp' if you need all parts.
237 splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
238 splitTyConApp (TypeRep _ tc _ trs) = (tc,trs)
239
240 -- | Split a type constructor application
241 splitPolyTyConApp :: TypeRep -> (TyCon,[KindRep],[TypeRep])
242 splitPolyTyConApp (TypeRep _ tc ks trs) = (tc,ks,trs)
243
244 -- | Applies a type to a function type. Returns: @'Just' u@ if the
245 -- first argument represents a function of type @t -> u@ and the
246 -- second argument represents a function of type @t@. Otherwise,
247 -- returns 'Nothing'.
248 funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
249 funResultTy trFun trArg
250 = case splitTyConApp trFun of
251 (tc, [t1,t2]) | tc == tcFun && t1 == trArg -> Just t2
252 _ -> Nothing
253
254 -- | Adds a TypeRep argument to a TypeRep.
255 mkAppTy :: TypeRep -> TypeRep -> TypeRep
256 {-# INLINE mkAppTy #-}
257 mkAppTy (TypeRep _ tc ks trs) arg_tr = mkPolyTyConApp tc ks (trs ++ [arg_tr])
258 -- Notice that we call mkTyConApp to construct the fingerprint from tc and
259 -- the arg fingerprints. Simply combining the current fingerprint with
260 -- the new one won't give the same answer, but of course we want to
261 -- ensure that a TypeRep of the same shape has the same fingerprint!
262 -- See Trac #5962
263
264 ----------------- Observation ---------------------
265
266 -- | Observe the type constructor of a type representation
267 typeRepTyCon :: TypeRep -> TyCon
268 typeRepTyCon (TypeRep _ tc _ _) = tc
269
270 -- | Observe the argument types of a type representation
271 typeRepArgs :: TypeRep -> [TypeRep]
272 typeRepArgs (TypeRep _ _ _ tys) = tys
273
274 -- | Observe the argument kinds of a type representation
275 typeRepKinds :: TypeRep -> [KindRep]
276 typeRepKinds (TypeRep _ _ ks _) = ks
277
278
279 {- *********************************************************************
280 * *
281 The Typeable class
282 * *
283 ********************************************************************* -}
284
285 -------------------------------------------------------------
286 --
287 -- The Typeable class and friends
288 --
289 -------------------------------------------------------------
290
291 -- | The class 'Typeable' allows a concrete representation of a type to
292 -- be calculated.
293 class Typeable a where
294 typeRep# :: Proxy# a -> TypeRep
295
296 -- | Takes a value of type @a@ and returns a concrete representation
297 -- of that type.
298 --
299 -- @since 4.7.0.0
300 typeRep :: forall proxy a. Typeable a => proxy a -> TypeRep
301 typeRep _ = typeRep# (proxy# :: Proxy# a)
302 {-# INLINE typeRep #-}
303
304 -- Keeping backwards-compatibility
305 typeOf :: forall a. Typeable a => a -> TypeRep
306 typeOf _ = typeRep (Proxy :: Proxy a)
307
308 typeOf1 :: forall t (a :: *). Typeable t => t a -> TypeRep
309 typeOf1 _ = typeRep (Proxy :: Proxy t)
310
311 typeOf2 :: forall t (a :: *) (b :: *). Typeable t => t a b -> TypeRep
312 typeOf2 _ = typeRep (Proxy :: Proxy t)
313
314 typeOf3 :: forall t (a :: *) (b :: *) (c :: *). Typeable t
315 => t a b c -> TypeRep
316 typeOf3 _ = typeRep (Proxy :: Proxy t)
317
318 typeOf4 :: forall t (a :: *) (b :: *) (c :: *) (d :: *). Typeable t
319 => t a b c d -> TypeRep
320 typeOf4 _ = typeRep (Proxy :: Proxy t)
321
322 typeOf5 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *). Typeable t
323 => t a b c d e -> TypeRep
324 typeOf5 _ = typeRep (Proxy :: Proxy t)
325
326 typeOf6 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *).
327 Typeable t => t a b c d e f -> TypeRep
328 typeOf6 _ = typeRep (Proxy :: Proxy t)
329
330 typeOf7 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *)
331 (g :: *). Typeable t => t a b c d e f g -> TypeRep
332 typeOf7 _ = typeRep (Proxy :: Proxy t)
333
334 type Typeable1 (a :: * -> *) = Typeable a
335 type Typeable2 (a :: * -> * -> *) = Typeable a
336 type Typeable3 (a :: * -> * -> * -> *) = Typeable a
337 type Typeable4 (a :: * -> * -> * -> * -> *) = Typeable a
338 type Typeable5 (a :: * -> * -> * -> * -> * -> *) = Typeable a
339 type Typeable6 (a :: * -> * -> * -> * -> * -> * -> *) = Typeable a
340 type Typeable7 (a :: * -> * -> * -> * -> * -> * -> * -> *) = Typeable a
341
342 {-# DEPRECATED Typeable1 "renamed to 'Typeable'" #-} -- deprecated in 7.8
343 {-# DEPRECATED Typeable2 "renamed to 'Typeable'" #-} -- deprecated in 7.8
344 {-# DEPRECATED Typeable3 "renamed to 'Typeable'" #-} -- deprecated in 7.8
345 {-# DEPRECATED Typeable4 "renamed to 'Typeable'" #-} -- deprecated in 7.8
346 {-# DEPRECATED Typeable5 "renamed to 'Typeable'" #-} -- deprecated in 7.8
347 {-# DEPRECATED Typeable6 "renamed to 'Typeable'" #-} -- deprecated in 7.8
348 {-# DEPRECATED Typeable7 "renamed to 'Typeable'" #-} -- deprecated in 7.8
349
350
351 ----------------- Showing TypeReps --------------------
352
353 instance Show TypeRep where
354 showsPrec p (TypeRep _ tycon kinds tys) =
355 case tys of
356 [] -> showsPrec p tycon
357 [x] | tycon == tcList -> showChar '[' . shows x . showChar ']'
358 [a,r] | tycon == tcFun -> showParen (p > 8) $
359 showsPrec 9 a .
360 showString " -> " .
361 showsPrec 8 r
362 xs | isTupleTyCon tycon -> showTuple xs
363 | otherwise ->
364 showParen (p > 9) $
365 showsPrec p tycon .
366 showChar ' ' .
367 showArgs (showChar ' ') (kinds ++ tys)
368
369 showsTypeRep :: TypeRep -> ShowS
370 showsTypeRep = shows
371
372 -- | Helper to fully evaluate 'TypeRep' for use as @NFData(rnf)@ implementation
373 --
374 -- @since 4.8.0.0
375 rnfTypeRep :: TypeRep -> ()
376 rnfTypeRep (TypeRep _ tyc krs tyrs) = rnfTyCon tyc `seq` go krs `seq` go tyrs
377 where
378 go [] = ()
379 go (x:xs) = rnfTypeRep x `seq` go xs
380
381 -- Some (Show.TypeRep) helpers:
382
383 showArgs :: Show a => ShowS -> [a] -> ShowS
384 showArgs _ [] = id
385 showArgs _ [a] = showsPrec 10 a
386 showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as
387
388 showTuple :: [TypeRep] -> ShowS
389 showTuple args = showChar '('
390 . showArgs (showChar ',') args
391 . showChar ')'
392
393 {- *********************************************************
394 * *
395 * TyCon definitions for GHC.Types *
396 * *
397 ********************************************************* -}
398
399 mkGhcTypesTyCon :: Addr# -> TyCon
400 {-# INLINE mkGhcTypesTyCon #-}
401 mkGhcTypesTyCon name = mkTyCon3# "ghc-prim"# "GHC.Types"# name
402
403 tcBool, tc'True, tc'False,
404 tcOrdering, tc'GT, tc'EQ, tc'LT,
405 tcChar, tcInt, tcWord, tcFloat, tcDouble, tcFun,
406 tcIO, tcSPEC, tcTyCon, tcModule,
407 tcCoercible, tcEq, tcList :: TyCon
408
409 tcBool = mkGhcTypesTyCon "Bool"# -- Bool is promotable
410 tc'True = mkGhcTypesTyCon "'True"#
411 tc'False = mkGhcTypesTyCon "'False"#
412 tcOrdering = mkGhcTypesTyCon "Ordering"# -- Ordering is promotable
413 tc'GT = mkGhcTypesTyCon "'GT"#
414 tc'EQ = mkGhcTypesTyCon "'EQ"#
415 tc'LT = mkGhcTypesTyCon "'LT"#
416
417 -- None of the rest are promotable (see TysWiredIn)
418 tcChar = mkGhcTypesTyCon "Char"#
419 tcInt = mkGhcTypesTyCon "Int"#
420 tcWord = mkGhcTypesTyCon "Word"#
421 tcFloat = mkGhcTypesTyCon "Float"#
422 tcDouble = mkGhcTypesTyCon "Double"#
423 tcSPEC = mkGhcTypesTyCon "SPEC"#
424 tcIO = mkGhcTypesTyCon "IO"#
425 tcTyCon = mkGhcTypesTyCon "TyCon"#
426 tcModule = mkGhcTypesTyCon "Module"#
427 tcCoercible = mkGhcTypesTyCon "Coercible"#
428
429 tcFun = mkGhcTypesTyCon "->"#
430 tcList = mkGhcTypesTyCon "[]"# -- Type rep for the list type constructor
431 tcEq = mkGhcTypesTyCon "~"# -- Type rep for the (~) type constructor
432
433 tcLiftedKind, tcUnliftedKind, tcOpenKind, tcBOX, tcConstraint, tcAnyK :: TyCon
434 tcLiftedKind = mkGhcTypesTyCon "*"#
435 tcUnliftedKind = mkGhcTypesTyCon "#"#
436 tcOpenKind = mkGhcTypesTyCon "#"#
437 tcBOX = mkGhcTypesTyCon "BOX"#
438 tcAnyK = mkGhcTypesTyCon "AnyK"#
439 tcConstraint = mkGhcTypesTyCon "Constraint"#
440
441 funTc :: TyCon
442 funTc = tcFun -- Legacy
443
444 {- *********************************************************
445 * *
446 * TyCon/TypeRep definitions for type literals *
447 * (Symbol and Nat) *
448 * *
449 ********************************************************* -}
450
451
452 mkTypeLitTyCon :: String -> TyCon
453 mkTypeLitTyCon name = mkTyCon3 "base" "GHC.TypeLits" name
454
455 -- | Used to make `'Typeable' instance for things of kind Nat
456 typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep
457 typeNatTypeRep p = typeLitTypeRep (show (natVal' p))
458
459 -- | Used to make `'Typeable' instance for things of kind Symbol
460 typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep
461 typeSymbolTypeRep p = typeLitTypeRep (show (symbolVal' p))
462
463 -- | An internal function, to make representations for type literals.
464 typeLitTypeRep :: String -> TypeRep
465 typeLitTypeRep nm = mkTyConApp (mkTypeLitTyCon nm) []
466