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