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