Update Trac ticket URLs to point to GitLab
[ghc.git] / libraries / base / Data / Typeable / Internal.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE Trustworthy #-}
3 {-# LANGUAGE ViewPatterns #-}
4 {-# LANGUAGE TypeOperators #-}
5 {-# LANGUAGE BangPatterns #-}
6 {-# LANGUAGE RankNTypes #-}
7 {-# LANGUAGE PatternSynonyms #-}
8 {-# LANGUAGE CPP #-}
9 {-# LANGUAGE ConstraintKinds #-}
10 {-# LANGUAGE DataKinds #-}
11 {-# LANGUAGE FlexibleInstances #-}
12 {-# LANGUAGE GADTs #-}
13 {-# LANGUAGE MagicHash #-}
14 {-# LANGUAGE NoImplicitPrelude #-}
15 {-# LANGUAGE PolyKinds #-}
16 {-# LANGUAGE ScopedTypeVariables #-}
17 {-# LANGUAGE StandaloneDeriving #-}
18 {-# LANGUAGE UndecidableInstances #-}
19 {-# LANGUAGE TypeApplications #-}
20 {-# LANGUAGE TypeFamilies #-}
21
22 -----------------------------------------------------------------------------
23 -- |
24 -- Module : Data.Typeable.Internal
25 -- Copyright : (c) The University of Glasgow, CWI 2001--2011
26 -- License : BSD-style (see the file libraries/base/LICENSE)
27 --
28 -- The representations of the types TyCon and TypeRep, and the
29 -- function mkTyCon which is used by derived instances of Typeable to
30 -- construct a TyCon.
31 --
32 -----------------------------------------------------------------------------
33
34 module Data.Typeable.Internal (
35 -- * Typeable and kind polymorphism
36 --
37 -- #kind_instantiation
38
39 -- * Miscellaneous
40 Fingerprint(..),
41
42 -- * Typeable class
43 Typeable(..),
44 withTypeable,
45
46 -- * Module
47 Module, -- Abstract
48 moduleName, modulePackage, rnfModule,
49
50 -- * TyCon
51 TyCon, -- Abstract
52 tyConPackage, tyConModule, tyConName, tyConKindArgs, tyConKindRep,
53 tyConFingerprint,
54 KindRep(.., KindRepTypeLit), TypeLitSort(..),
55 rnfTyCon,
56
57 -- * TypeRep
58 TypeRep,
59 pattern App, pattern Con, pattern Con', pattern Fun,
60 typeRep,
61 typeOf,
62 typeRepTyCon,
63 typeRepFingerprint,
64 rnfTypeRep,
65 eqTypeRep,
66 typeRepKind,
67 splitApps,
68
69 -- * SomeTypeRep
70 SomeTypeRep(..),
71 someTypeRep,
72 someTypeRepTyCon,
73 someTypeRepFingerprint,
74 rnfSomeTypeRep,
75
76 -- * Construction
77 -- | These are for internal use only
78 mkTrType, mkTrCon, mkTrApp, mkTrAppChecked, mkTrFun,
79 mkTyCon, mkTyCon#,
80 typeSymbolTypeRep, typeNatTypeRep,
81 ) where
82
83 import GHC.Base
84 import qualified GHC.Arr as A
85 import GHC.Types ( TYPE )
86 import Data.Type.Equality
87 import GHC.List ( splitAt, foldl', elem )
88 import GHC.Word
89 import GHC.Show
90 import GHC.TypeLits ( KnownSymbol, symbolVal', AppendSymbol )
91 import GHC.TypeNats ( KnownNat, natVal' )
92 import Unsafe.Coerce ( unsafeCoerce )
93
94 import GHC.Fingerprint.Type
95 import {-# SOURCE #-} GHC.Fingerprint
96 -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable
97 -- Better to break the loop here, because we want non-SOURCE imports
98 -- of Data.Typeable as much as possible so we can optimise the derived
99 -- instances.
100 -- import {-# SOURCE #-} Debug.Trace (trace)
101
102 #include "MachDeps.h"
103
104 {- *********************************************************************
105 * *
106 The TyCon type
107 * *
108 ********************************************************************* -}
109
110 modulePackage :: Module -> String
111 modulePackage (Module p _) = trNameString p
112
113 moduleName :: Module -> String
114 moduleName (Module _ m) = trNameString m
115
116 tyConPackage :: TyCon -> String
117 tyConPackage (TyCon _ _ m _ _ _) = modulePackage m
118
119 tyConModule :: TyCon -> String
120 tyConModule (TyCon _ _ m _ _ _) = moduleName m
121
122 tyConName :: TyCon -> String
123 tyConName (TyCon _ _ _ n _ _) = trNameString n
124
125 trNameString :: TrName -> String
126 trNameString (TrNameS s) = unpackCStringUtf8# s
127 trNameString (TrNameD s) = s
128
129 tyConFingerprint :: TyCon -> Fingerprint
130 tyConFingerprint (TyCon hi lo _ _ _ _)
131 = Fingerprint (W64# hi) (W64# lo)
132
133 tyConKindArgs :: TyCon -> Int
134 tyConKindArgs (TyCon _ _ _ _ n _) = I# n
135
136 tyConKindRep :: TyCon -> KindRep
137 tyConKindRep (TyCon _ _ _ _ _ k) = k
138
139 -- | Helper to fully evaluate 'TyCon' for use as @NFData(rnf)@ implementation
140 --
141 -- @since 4.8.0.0
142 rnfModule :: Module -> ()
143 rnfModule (Module p m) = rnfTrName p `seq` rnfTrName m
144
145 rnfTrName :: TrName -> ()
146 rnfTrName (TrNameS _) = ()
147 rnfTrName (TrNameD n) = rnfString n
148
149 rnfKindRep :: KindRep -> ()
150 rnfKindRep (KindRepTyConApp tc args) = rnfTyCon tc `seq` rnfList rnfKindRep args
151 rnfKindRep (KindRepVar _) = ()
152 rnfKindRep (KindRepApp a b) = rnfKindRep a `seq` rnfKindRep b
153 rnfKindRep (KindRepFun a b) = rnfKindRep a `seq` rnfKindRep b
154 rnfKindRep (KindRepTYPE rr) = rnfRuntimeRep rr
155 rnfKindRep (KindRepTypeLitS _ _) = ()
156 rnfKindRep (KindRepTypeLitD _ t) = rnfString t
157
158 rnfRuntimeRep :: RuntimeRep -> ()
159 rnfRuntimeRep (VecRep !_ !_) = ()
160 rnfRuntimeRep !_ = ()
161
162 rnfList :: (a -> ()) -> [a] -> ()
163 rnfList _ [] = ()
164 rnfList force (x:xs) = force x `seq` rnfList force xs
165
166 rnfString :: [Char] -> ()
167 rnfString = rnfList (`seq` ())
168
169 rnfTyCon :: TyCon -> ()
170 rnfTyCon (TyCon _ _ m n _ k) = rnfModule m `seq` rnfTrName n `seq` rnfKindRep k
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 (a :: k) where
182 -- The TypeRep of Type. See Note [Kind caching], Wrinkle 2
183 TrType :: TypeRep Type
184 TrTyCon :: { -- See Note [TypeRep fingerprints]
185 trTyConFingerprint :: {-# UNPACK #-} !Fingerprint
186
187 -- The TypeRep represents the application of trTyCon
188 -- to the kind arguments trKindVars. So for
189 -- 'Just :: Bool -> Maybe Bool, the trTyCon will be
190 -- 'Just and the trKindVars will be [Bool].
191 , trTyCon :: !TyCon
192 , trKindVars :: [SomeTypeRep]
193 , trTyConKind :: !(TypeRep k) } -- See Note [Kind caching]
194 -> TypeRep (a :: k)
195
196 -- | Invariant: Saturated arrow types (e.g. things of the form @a -> b@)
197 -- are represented with @'TrFun' a b@, not @TrApp (TrApp funTyCon a) b@.
198 TrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
199 { -- See Note [TypeRep fingerprints]
200 trAppFingerprint :: {-# UNPACK #-} !Fingerprint
201
202 -- The TypeRep represents the application of trAppFun
203 -- to trAppArg. For Maybe Int, the trAppFun will be Maybe
204 -- and the trAppArg will be Int.
205 , trAppFun :: !(TypeRep (a :: k1 -> k2))
206 , trAppArg :: !(TypeRep (b :: k1))
207 , trAppKind :: !(TypeRep k2) } -- See Note [Kind caching]
208 -> TypeRep (a b)
209
210 -- | @TrFun fpr a b@ represents a function type @a -> b@. We use this for
211 -- the sake of efficiency as functions are quite ubiquitous.
212 TrFun :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
213 (a :: TYPE r1) (b :: TYPE r2).
214 { -- See Note [TypeRep fingerprints]
215 trFunFingerprint :: {-# UNPACK #-} !Fingerprint
216
217 -- The TypeRep represents a function from trFunArg to
218 -- trFunRes.
219 , trFunArg :: !(TypeRep a)
220 , trFunRes :: !(TypeRep b) }
221 -> TypeRep (a -> b)
222
223 {- Note [TypeRep fingerprints]
224 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
225 We store a Fingerprint of each TypeRep in its constructor. This allows
226 us to test whether two TypeReps are equal in constant time, rather than
227 having to walk their full structures.
228 -}
229
230 {- Note [Kind caching]
231 ~~~~~~~~~~~~~~~~~~~
232
233 We cache the kind of the TypeRep in each TrTyCon and TrApp constructor.
234 This is necessary to ensure that typeRepKind (which is used, at least, in
235 deserialization and dynApply) is cheap. There are two reasons for this:
236
237 1. Calculating the kind of a nest of type applications, such as
238
239 F X Y Z W (App (App (App (App F X) Y) Z) W)
240
241 is linear in the depth, which is already a bit pricy. In deserialization,
242 we build up such a nest from the inside out, so without caching, that ends
243 up taking quadratic time, and calculating the KindRep of the constructor,
244 F, a linear number of times. See #14254.
245
246 2. Calculating the kind of a type constructor, in instantiateTypeRep,
247 requires building (allocating) a TypeRep for the kind "from scratch".
248 This can get pricy. When combined with point (1), we can end up with
249 a large amount of extra allocation deserializing very deep nests.
250 See #14337.
251
252 It is quite possible to speed up deserialization by structuring that process
253 very carefully. Unfortunately, that doesn't help dynApply or anything else
254 that may use typeRepKind. Since caching the kind isn't terribly expensive, it
255 seems better to just do that and solve all the potential problems at once.
256
257 There are two things we need to be careful about when caching kinds.
258
259 Wrinkle 1:
260
261 We want to do it eagerly. Suppose we have
262
263 tf :: TypeRep (f :: j -> k)
264 ta :: TypeRep (a :: j)
265
266 Then the cached kind of App tf ta should be eagerly evaluated to k, rather
267 than being stored as a thunk that will strip the (j ->) off of j -> k if
268 and when it is forced.
269
270 Wrinkle 2:
271
272 We need to be able to represent TypeRep Type. This is a bit tricky because
273 typeRepKind (typeRep @Type) = typeRep @Type, so if we actually cache the
274 typerep of the kind of Type, we will have a loop. One simple way to do this
275 is to make the cached kind fields lazy and allow TypeRep Type to be cyclical.
276
277 But we *do not* want TypeReps to have cyclical structure! Most importantly,
278 a cyclical structure cannot be stored in a compact region. Secondarily,
279 using :force in GHCi on a cyclical structure will lead to non-termination.
280
281 To avoid this trouble, we use a separate constructor for TypeRep Type.
282 mkTrApp is responsible for recognizing that TYPE is being applied to
283 'LiftedRep and produce trType; other functions must recognize that TrType
284 represents an application.
285 -}
286
287 -- Compare keys for equality
288
289 -- | @since 2.01
290 instance Eq (TypeRep a) where
291 _ == _ = True
292 {-# INLINABLE (==) #-}
293
294 instance TestEquality TypeRep where
295 a `testEquality` b
296 | Just HRefl <- eqTypeRep a b
297 = Just Refl
298 | otherwise
299 = Nothing
300 {-# INLINEABLE testEquality #-}
301
302 -- | @since 4.4.0.0
303 instance Ord (TypeRep a) where
304 compare _ _ = EQ
305 {-# INLINABLE compare #-}
306
307 -- | A non-indexed type representation.
308 data SomeTypeRep where
309 SomeTypeRep :: forall k (a :: k). !(TypeRep a) -> SomeTypeRep
310
311 instance Eq SomeTypeRep where
312 SomeTypeRep a == SomeTypeRep b =
313 case a `eqTypeRep` b of
314 Just _ -> True
315 Nothing -> False
316
317 instance Ord SomeTypeRep where
318 SomeTypeRep a `compare` SomeTypeRep b =
319 typeRepFingerprint a `compare` typeRepFingerprint b
320
321 -- | The function type constructor.
322 --
323 -- For instance,
324 --
325 -- @
326 -- typeRep \@(Int -> Char) === Fun (typeRep \@Int) (typeRep \@Char)
327 -- @
328 --
329 pattern Fun :: forall k (fun :: k). ()
330 => forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
331 (arg :: TYPE r1) (res :: TYPE r2).
332 (k ~ Type, fun ~~ (arg -> res))
333 => TypeRep arg
334 -> TypeRep res
335 -> TypeRep fun
336 pattern Fun arg res <- TrFun {trFunArg = arg, trFunRes = res}
337 where Fun arg res = mkTrFun arg res
338
339 -- | Observe the 'Fingerprint' of a type representation
340 --
341 -- @since 4.8.0.0
342 typeRepFingerprint :: TypeRep a -> Fingerprint
343 typeRepFingerprint TrType = fpTYPELiftedRep
344 typeRepFingerprint (TrTyCon {trTyConFingerprint = fpr}) = fpr
345 typeRepFingerprint (TrApp {trAppFingerprint = fpr}) = fpr
346 typeRepFingerprint (TrFun {trFunFingerprint = fpr}) = fpr
347
348 -- For compiler use
349 mkTrType :: TypeRep Type
350 mkTrType = TrType
351
352 -- | Construct a representation for a type constructor
353 -- applied at a monomorphic kind.
354 --
355 -- Note that this is unsafe as it allows you to construct
356 -- ill-kinded types.
357 mkTrCon :: forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a
358 mkTrCon tc kind_vars = TrTyCon
359 { trTyConFingerprint = fpr
360 , trTyCon = tc
361 , trKindVars = kind_vars
362 , trTyConKind = kind }
363 where
364 fpr_tc = tyConFingerprint tc
365 fpr_kvs = map someTypeRepFingerprint kind_vars
366 fpr = fingerprintFingerprints (fpr_tc:fpr_kvs)
367 kind = unsafeCoerceRep $ tyConKind tc kind_vars
368
369 -- The fingerprint of Type. We don't store this in the TrType
370 -- constructor, so we need to build it here.
371 fpTYPELiftedRep :: Fingerprint
372 fpTYPELiftedRep = fingerprintFingerprints
373 [tyConFingerprint tyConTYPE, typeRepFingerprint trLiftedRep]
374 -- There is absolutely nothing to gain and everything to lose
375 -- by inlining the worker. The wrapper should inline anyway.
376 {-# NOINLINE fpTYPELiftedRep #-}
377
378 trTYPE :: TypeRep TYPE
379 trTYPE = typeRep
380
381 trLiftedRep :: TypeRep 'LiftedRep
382 trLiftedRep = typeRep
383
384 -- | Construct a representation for a type application that is
385 -- NOT a saturated arrow type. This is not checked!
386
387 -- Note that this is known-key to the compiler, which uses it in desugar
388 -- 'Typeable' evidence.
389 mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
390 TypeRep (a :: k1 -> k2)
391 -> TypeRep (b :: k1)
392 -> TypeRep (a b)
393 mkTrApp a b -- See Note [Kind caching], Wrinkle 2
394 | Just HRefl <- a `eqTypeRep` trTYPE
395 , Just HRefl <- b `eqTypeRep` trLiftedRep
396 = TrType
397
398 | TrFun {trFunRes = res_kind} <- typeRepKind a
399 = TrApp
400 { trAppFingerprint = fpr
401 , trAppFun = a
402 , trAppArg = b
403 , trAppKind = res_kind }
404
405 | otherwise = error ("Ill-kinded type application: "
406 ++ show (typeRepKind a))
407 where
408 fpr_a = typeRepFingerprint a
409 fpr_b = typeRepFingerprint b
410 fpr = fingerprintFingerprints [fpr_a, fpr_b]
411
412 -- | Construct a representation for a type application that
413 -- may be a saturated arrow type. This is renamed to mkTrApp in
414 -- Type.Reflection.Unsafe
415 mkTrAppChecked :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
416 TypeRep (a :: k1 -> k2)
417 -> TypeRep (b :: k1)
418 -> TypeRep (a b)
419 mkTrAppChecked rep@(TrApp {trAppFun = p, trAppArg = x :: TypeRep x})
420 (y :: TypeRep y)
421 | TrTyCon {trTyCon=con} <- p
422 , con == funTyCon -- cheap check first
423 , Just (IsTYPE (rx :: TypeRep rx)) <- isTYPE (typeRepKind x)
424 , Just (IsTYPE (ry :: TypeRep ry)) <- isTYPE (typeRepKind y)
425 , Just HRefl <- withTypeable x $ withTypeable rx $ withTypeable ry
426 $ typeRep @((->) x :: TYPE ry -> Type) `eqTypeRep` rep
427 = mkTrFun x y
428 mkTrAppChecked a b = mkTrApp a b
429
430 -- | A type application.
431 --
432 -- For instance,
433 --
434 -- @
435 -- typeRep \@(Maybe Int) === App (typeRep \@Maybe) (typeRep \@Int)
436 -- @
437 --
438 -- Note that this will also match a function type,
439 --
440 -- @
441 -- typeRep \@(Int# -> Char)
442 -- ===
443 -- App (App arrow (typeRep \@Int#)) (typeRep \@Char)
444 -- @
445 --
446 -- where @arrow :: TypeRep ((->) :: TYPE IntRep -> Type -> Type)@.
447 --
448 pattern App :: forall k2 (t :: k2). ()
449 => forall k1 (a :: k1 -> k2) (b :: k1). (t ~ a b)
450 => TypeRep a -> TypeRep b -> TypeRep t
451 pattern App f x <- (splitApp -> IsApp f x)
452 where App f x = mkTrAppChecked f x
453
454 data AppOrCon (a :: k) where
455 IsApp :: forall k k' (f :: k' -> k) (x :: k'). ()
456 => TypeRep f -> TypeRep x -> AppOrCon (f x)
457 -- See Note [Con evidence]
458 IsCon :: IsApplication a ~ "" => TyCon -> [SomeTypeRep] -> AppOrCon a
459
460 type family IsApplication (x :: k) :: Symbol where
461 IsApplication (_ _) = "An error message about this unifying with \"\" "
462 `AppendSymbol` "means that you tried to match a TypeRep with Con or "
463 `AppendSymbol` "Con' when the represented type was known to be an "
464 `AppendSymbol` "application."
465 IsApplication _ = ""
466
467 splitApp :: forall k (a :: k). ()
468 => TypeRep a
469 -> AppOrCon a
470 splitApp TrType = IsApp trTYPE trLiftedRep
471 splitApp (TrApp {trAppFun = f, trAppArg = x}) = IsApp f x
472 splitApp rep@(TrFun {trFunArg=a, trFunRes=b}) = IsApp (mkTrApp arr a) b
473 where arr = bareArrow rep
474 splitApp (TrTyCon{trTyCon = con, trKindVars = kinds})
475 = case unsafeCoerce Refl :: IsApplication a :~: "" of
476 Refl -> IsCon con kinds
477
478 -- | Use a 'TypeRep' as 'Typeable' evidence.
479 withTypeable :: forall k (a :: k) rep (r :: TYPE rep). ()
480 => TypeRep a -> (Typeable a => r) -> r
481 withTypeable rep k = unsafeCoerce k' rep
482 where k' :: Gift a r
483 k' = Gift k
484
485 -- | A helper to satisfy the type checker in 'withTypeable'.
486 newtype Gift a (r :: TYPE rep) = Gift (Typeable a => r)
487
488 -- | Pattern match on a type constructor
489 pattern Con :: forall k (a :: k). ()
490 => IsApplication a ~ "" -- See Note [Con evidence]
491 => TyCon -> TypeRep a
492 pattern Con con <- (splitApp -> IsCon con _)
493
494 -- | Pattern match on a type constructor including its instantiated kind
495 -- variables.
496 --
497 -- For instance,
498 --
499 -- @
500 -- App (Con' proxyTyCon ks) intRep = typeRep @(Proxy \@Int)
501 -- @
502 --
503 -- will bring into scope,
504 --
505 -- @
506 -- proxyTyCon :: TyCon
507 -- ks == [someTypeRep @Type] :: [SomeTypeRep]
508 -- intRep == typeRep @Int
509 -- @
510 --
511 pattern Con' :: forall k (a :: k). ()
512 => IsApplication a ~ "" -- See Note [Con evidence]
513 => TyCon -> [SomeTypeRep] -> TypeRep a
514 pattern Con' con ks <- (splitApp -> IsCon con ks)
515
516 -- TODO: Remove Fun when #14253 is fixed
517 {-# COMPLETE Fun, App, Con #-}
518 {-# COMPLETE Fun, App, Con' #-}
519
520 {- Note [Con evidence]
521 ~~~~~~~~~~~~~~~~~~~
522
523 Matching TypeRep t on Con or Con' fakes up evidence that
524
525 IsApplication t ~ "".
526
527 Why should anyone care about the value of strange internal type family?
528 Well, almost nobody cares about it, but the pattern checker does!
529 For example, suppose we have TypeRep (f x) and we want to get
530 TypeRep f and TypeRep x. There is no chance that the Con constructor
531 will match, because (f x) is not a constructor, but without the
532 IsApplication evidence, omitting it will lead to an incomplete pattern
533 warning. With the evidence, the pattern checker will see that
534 Con wouldn't typecheck, so everything works out as it should.
535
536 Why do we use Symbols? We would really like to use something like
537
538 type family NotApplication (t :: k) :: Constraint where
539 NotApplication (f a) = TypeError ...
540 NotApplication _ = ()
541
542 Unfortunately, #11503 means that the pattern checker and type checker
543 will fail to actually reject the mistaken patterns. So we describe the
544 error in the result type. It's a horrible hack.
545 -}
546
547 ----------------- Observation ---------------------
548
549 -- | Observe the type constructor of a quantified type representation.
550 someTypeRepTyCon :: SomeTypeRep -> TyCon
551 someTypeRepTyCon (SomeTypeRep t) = typeRepTyCon t
552
553 -- | Observe the type constructor of a type representation
554 typeRepTyCon :: TypeRep a -> TyCon
555 typeRepTyCon TrType = tyConTYPE
556 typeRepTyCon (TrTyCon {trTyCon = tc}) = tc
557 typeRepTyCon (TrApp {trAppFun = a}) = typeRepTyCon a
558 typeRepTyCon (TrFun {}) = typeRepTyCon $ typeRep @(->)
559
560 -- | Type equality
561 --
562 -- @since 4.10
563 eqTypeRep :: forall k1 k2 (a :: k1) (b :: k2).
564 TypeRep a -> TypeRep b -> Maybe (a :~~: b)
565 eqTypeRep a b
566 | sameTypeRep a b = Just (unsafeCoerce# HRefl)
567 | otherwise = Nothing
568 -- We want GHC to inline eqTypeRep to get rid of the Maybe
569 -- in the usual case that it is scrutinized immediately. We
570 -- split eqTypeRep into a worker and wrapper because otherwise
571 -- it's much larger than anything we'd want to inline.
572 {-# INLINABLE eqTypeRep #-}
573
574 sameTypeRep :: forall k1 k2 (a :: k1) (b :: k2).
575 TypeRep a -> TypeRep b -> Bool
576 sameTypeRep a b = typeRepFingerprint a == typeRepFingerprint b
577
578 -------------------------------------------------------------
579 --
580 -- Computing kinds
581 --
582 -------------------------------------------------------------
583
584 -- | Observe the kind of a type.
585 typeRepKind :: TypeRep (a :: k) -> TypeRep k
586 typeRepKind TrType = TrType
587 typeRepKind (TrTyCon {trTyConKind = kind}) = kind
588 typeRepKind (TrApp {trAppKind = kind}) = kind
589 typeRepKind (TrFun {}) = typeRep @Type
590
591 tyConKind :: TyCon -> [SomeTypeRep] -> SomeTypeRep
592 tyConKind (TyCon _ _ _ _ nKindVars# kindRep) kindVars =
593 let kindVarsArr :: A.Array KindBndr SomeTypeRep
594 kindVarsArr = A.listArray (0, I# (nKindVars# -# 1#)) kindVars
595 in instantiateKindRep kindVarsArr kindRep
596
597 instantiateKindRep :: A.Array KindBndr SomeTypeRep -> KindRep -> SomeTypeRep
598 instantiateKindRep vars = go
599 where
600 go :: KindRep -> SomeTypeRep
601 go (KindRepTyConApp tc args)
602 = let n_kind_args = tyConKindArgs tc
603 (kind_args, ty_args) = splitAt n_kind_args args
604 -- First instantiate tycon kind arguments
605 tycon_app = SomeTypeRep $ mkTrCon tc (map go kind_args)
606 -- Then apply remaining type arguments
607 applyTy :: SomeTypeRep -> KindRep -> SomeTypeRep
608 applyTy (SomeTypeRep acc) ty
609 | SomeTypeRep ty' <- go ty
610 = SomeTypeRep $ mkTrApp (unsafeCoerce acc) ty'
611 in foldl' applyTy tycon_app ty_args
612 go (KindRepVar var)
613 = vars A.! var
614 go (KindRepApp f a)
615 = SomeTypeRep $ mkTrApp (unsafeCoerceRep $ go f) (unsafeCoerceRep $ go a)
616 go (KindRepFun a b)
617 = SomeTypeRep $ mkTrFun (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b)
618 go (KindRepTYPE LiftedRep) = SomeTypeRep TrType
619 go (KindRepTYPE r) = unkindedTypeRep $ tYPE `kApp` runtimeRepTypeRep r
620 go (KindRepTypeLitS sort s)
621 = mkTypeLitFromString sort (unpackCStringUtf8# s)
622 go (KindRepTypeLitD sort s)
623 = mkTypeLitFromString sort s
624
625 tYPE = kindedTypeRep @(RuntimeRep -> Type) @TYPE
626
627 unsafeCoerceRep :: SomeTypeRep -> TypeRep a
628 unsafeCoerceRep (SomeTypeRep r) = unsafeCoerce r
629
630 unkindedTypeRep :: SomeKindedTypeRep k -> SomeTypeRep
631 unkindedTypeRep (SomeKindedTypeRep x) = SomeTypeRep x
632
633 data SomeKindedTypeRep k where
634 SomeKindedTypeRep :: forall k (a :: k). TypeRep a
635 -> SomeKindedTypeRep k
636
637 kApp :: SomeKindedTypeRep (k -> k')
638 -> SomeKindedTypeRep k
639 -> SomeKindedTypeRep k'
640 kApp (SomeKindedTypeRep f) (SomeKindedTypeRep a) =
641 SomeKindedTypeRep (mkTrApp f a)
642
643 kindedTypeRep :: forall k (a :: k). Typeable a => SomeKindedTypeRep k
644 kindedTypeRep = SomeKindedTypeRep (typeRep @a)
645
646 buildList :: forall k. Typeable k
647 => [SomeKindedTypeRep k]
648 -> SomeKindedTypeRep [k]
649 buildList = foldr cons nil
650 where
651 nil = kindedTypeRep @[k] @'[]
652 cons x rest = SomeKindedTypeRep (typeRep @'(:)) `kApp` x `kApp` rest
653
654 runtimeRepTypeRep :: RuntimeRep -> SomeKindedTypeRep RuntimeRep
655 runtimeRepTypeRep r =
656 case r of
657 LiftedRep -> rep @'LiftedRep
658 UnliftedRep -> rep @'UnliftedRep
659 VecRep c e -> kindedTypeRep @_ @'VecRep
660 `kApp` vecCountTypeRep c
661 `kApp` vecElemTypeRep e
662 TupleRep rs -> kindedTypeRep @_ @'TupleRep
663 `kApp` buildList (map runtimeRepTypeRep rs)
664 SumRep rs -> kindedTypeRep @_ @'SumRep
665 `kApp` buildList (map runtimeRepTypeRep rs)
666 IntRep -> rep @'IntRep
667 Int8Rep -> rep @'Int8Rep
668 Int16Rep -> rep @'Int16Rep
669 Int64Rep -> rep @'Int64Rep
670 WordRep -> rep @'WordRep
671 Word8Rep -> rep @'Word8Rep
672 Word16Rep -> rep @'Word16Rep
673 Word64Rep -> rep @'Word64Rep
674 AddrRep -> rep @'AddrRep
675 FloatRep -> rep @'FloatRep
676 DoubleRep -> rep @'DoubleRep
677 where
678 rep :: forall (a :: RuntimeRep). Typeable a => SomeKindedTypeRep RuntimeRep
679 rep = kindedTypeRep @RuntimeRep @a
680
681 vecCountTypeRep :: VecCount -> SomeKindedTypeRep VecCount
682 vecCountTypeRep c =
683 case c of
684 Vec2 -> rep @'Vec2
685 Vec4 -> rep @'Vec4
686 Vec8 -> rep @'Vec8
687 Vec16 -> rep @'Vec16
688 Vec32 -> rep @'Vec32
689 Vec64 -> rep @'Vec64
690 where
691 rep :: forall (a :: VecCount). Typeable a => SomeKindedTypeRep VecCount
692 rep = kindedTypeRep @VecCount @a
693
694 vecElemTypeRep :: VecElem -> SomeKindedTypeRep VecElem
695 vecElemTypeRep e =
696 case e of
697 Int8ElemRep -> rep @'Int8ElemRep
698 Int16ElemRep -> rep @'Int16ElemRep
699 Int32ElemRep -> rep @'Int32ElemRep
700 Int64ElemRep -> rep @'Int64ElemRep
701 Word8ElemRep -> rep @'Word8ElemRep
702 Word16ElemRep -> rep @'Word16ElemRep
703 Word32ElemRep -> rep @'Word32ElemRep
704 Word64ElemRep -> rep @'Word64ElemRep
705 FloatElemRep -> rep @'FloatElemRep
706 DoubleElemRep -> rep @'DoubleElemRep
707 where
708 rep :: forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem
709 rep = kindedTypeRep @VecElem @a
710
711 bareArrow :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
712 (a :: TYPE r1) (b :: TYPE r2). ()
713 => TypeRep (a -> b)
714 -> TypeRep ((->) :: TYPE r1 -> TYPE r2 -> Type)
715 bareArrow (TrFun _ a b) =
716 mkTrCon funTyCon [SomeTypeRep rep1, SomeTypeRep rep2]
717 where
718 rep1 = getRuntimeRep $ typeRepKind a :: TypeRep r1
719 rep2 = getRuntimeRep $ typeRepKind b :: TypeRep r2
720 bareArrow _ = error "Data.Typeable.Internal.bareArrow: impossible"
721
722 data IsTYPE (a :: Type) where
723 IsTYPE :: forall (r :: RuntimeRep). TypeRep r -> IsTYPE (TYPE r)
724
725 -- | Is a type of the form @TYPE rep@?
726 isTYPE :: TypeRep (a :: Type) -> Maybe (IsTYPE a)
727 isTYPE TrType = Just (IsTYPE trLiftedRep)
728 isTYPE (TrApp {trAppFun=f, trAppArg=r})
729 | Just HRefl <- f `eqTypeRep` typeRep @TYPE
730 = Just (IsTYPE r)
731 isTYPE _ = Nothing
732
733 getRuntimeRep :: forall (r :: RuntimeRep). TypeRep (TYPE r) -> TypeRep r
734 getRuntimeRep TrType = trLiftedRep
735 getRuntimeRep (TrApp {trAppArg=r}) = r
736 getRuntimeRep _ = error "Data.Typeable.Internal.getRuntimeRep: impossible"
737
738
739 -------------------------------------------------------------
740 --
741 -- The Typeable class and friends
742 --
743 -------------------------------------------------------------
744
745 -- | The class 'Typeable' allows a concrete representation of a type to
746 -- be calculated.
747 class Typeable (a :: k) where
748 typeRep# :: TypeRep a
749
750 typeRep :: Typeable a => TypeRep a
751 typeRep = typeRep#
752
753 typeOf :: Typeable a => a -> TypeRep a
754 typeOf _ = typeRep
755
756 -- | Takes a value of type @a@ and returns a concrete representation
757 -- of that type.
758 --
759 -- @since 4.7.0.0
760 someTypeRep :: forall proxy a. Typeable a => proxy a -> SomeTypeRep
761 someTypeRep _ = SomeTypeRep (typeRep :: TypeRep a)
762 {-# INLINE typeRep #-}
763
764 someTypeRepFingerprint :: SomeTypeRep -> Fingerprint
765 someTypeRepFingerprint (SomeTypeRep t) = typeRepFingerprint t
766
767 ----------------- Showing TypeReps --------------------
768
769 -- This follows roughly the precedence structure described in Note [Precedence
770 -- in types].
771 instance Show (TypeRep (a :: k)) where
772 showsPrec = showTypeable
773
774
775 showTypeable :: Int -> TypeRep (a :: k) -> ShowS
776 showTypeable _ TrType = showChar '*'
777 showTypeable _ rep
778 | isListTyCon tc, [ty] <- tys =
779 showChar '[' . shows ty . showChar ']'
780
781 -- Take care only to render saturated tuple tycon applications
782 -- with tuple notation (#14341).
783 | isTupleTyCon tc,
784 Just _ <- TrType `eqTypeRep` typeRepKind rep =
785 showChar '(' . showArgs (showChar ',') tys . showChar ')'
786 where (tc, tys) = splitApps rep
787 showTypeable _ (TrTyCon {trTyCon = tycon, trKindVars = []})
788 = showTyCon tycon
789 showTypeable p (TrTyCon {trTyCon = tycon, trKindVars = args})
790 = showParen (p > 9) $
791 showTyCon tycon .
792 showChar ' ' .
793 showArgs (showChar ' ') args
794 showTypeable p (TrFun {trFunArg = x, trFunRes = r})
795 = showParen (p > 8) $
796 showsPrec 9 x . showString " -> " . showsPrec 8 r
797 showTypeable p (TrApp {trAppFun = f, trAppArg = x})
798 = showParen (p > 9) $
799 showsPrec 8 f .
800 showChar ' ' .
801 showsPrec 10 x
802
803 -- | @since 4.10.0.0
804 instance Show SomeTypeRep where
805 showsPrec p (SomeTypeRep ty) = showsPrec p ty
806
807 splitApps :: TypeRep a -> (TyCon, [SomeTypeRep])
808 splitApps = go []
809 where
810 go :: [SomeTypeRep] -> TypeRep a -> (TyCon, [SomeTypeRep])
811 go xs (TrTyCon {trTyCon = tc})
812 = (tc, xs)
813 go xs (TrApp {trAppFun = f, trAppArg = x})
814 = go (SomeTypeRep x : xs) f
815 go [] (TrFun {trFunArg = a, trFunRes = b})
816 = (funTyCon, [SomeTypeRep a, SomeTypeRep b])
817 go _ (TrFun {})
818 = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 1"
819 go [] TrType = (tyConTYPE, [SomeTypeRep trLiftedRep])
820 go _ TrType
821 = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 2"
822
823 -- This is incredibly shady! We don't really want to do this here; we
824 -- should really have the compiler reveal the TYPE TyCon directly
825 -- somehow. We need to construct this by hand because otherwise
826 -- we end up with horrible and somewhat mysterious loops trying to calculate
827 -- typeRep @TYPE. For the moment, we use the fact that we can get the proper
828 -- name of the ghc-prim package from the TyCon of LiftedRep (which we can
829 -- produce a TypeRep for without difficulty), and then just substitute in the
830 -- appropriate module and constructor names.
831 --
832 -- The ticket to find a better way to deal with this is
833 -- #14480.
834 tyConTYPE :: TyCon
835 tyConTYPE = mkTyCon (tyConPackage liftedRepTyCon) "GHC.Prim" "TYPE" 0
836 (KindRepFun (KindRepTyConApp liftedRepTyCon []) (KindRepTYPE LiftedRep))
837 where
838 liftedRepTyCon = typeRepTyCon (typeRep @RuntimeRep)
839
840 funTyCon :: TyCon
841 funTyCon = typeRepTyCon (typeRep @(->))
842
843 isListTyCon :: TyCon -> Bool
844 isListTyCon tc = tc == typeRepTyCon (typeRep :: TypeRep [])
845
846 isTupleTyCon :: TyCon -> Bool
847 isTupleTyCon tc
848 | ('(':',':_) <- tyConName tc = True
849 | otherwise = False
850
851 -- This is only an approximation. We don't have the general
852 -- character-classification machinery here, so we just do our best.
853 -- This should work for promoted Haskell 98 data constructors and
854 -- for TypeOperators type constructors that begin with ASCII
855 -- characters, but it will miss Unicode operators.
856 --
857 -- If we wanted to catch Unicode as well, we ought to consider moving
858 -- GHC.Lexeme from ghc-boot-th to base. Then we could just say:
859 --
860 -- startsVarSym symb || startsConSym symb
861 --
862 -- But this is a fair deal of work just for one corner case, so I think I'll
863 -- leave it like this unless someone shouts.
864 isOperatorTyCon :: TyCon -> Bool
865 isOperatorTyCon tc
866 | symb : _ <- tyConName tc
867 , symb `elem` "!#$%&*+./<=>?@\\^|-~:" = True
868 | otherwise = False
869
870 showTyCon :: TyCon -> ShowS
871 showTyCon tycon = showParen (isOperatorTyCon tycon) (shows tycon)
872
873 showArgs :: Show a => ShowS -> [a] -> ShowS
874 showArgs _ [] = id
875 showArgs _ [a] = showsPrec 10 a
876 showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as
877
878 -- | Helper to fully evaluate 'TypeRep' for use as @NFData(rnf)@ implementation
879 --
880 -- @since 4.8.0.0
881 rnfTypeRep :: TypeRep a -> ()
882 -- The TypeRep structure is almost entirely strict by definition. The
883 -- fingerprinting and strict kind caching ensure that everything
884 -- else is forced anyway. So we don't need to do anything special
885 -- to reduce to normal form.
886 rnfTypeRep !_ = ()
887
888 -- | Helper to fully evaluate 'SomeTypeRep' for use as @NFData(rnf)@
889 -- implementation
890 --
891 -- @since 4.10.0.0
892 rnfSomeTypeRep :: SomeTypeRep -> ()
893 rnfSomeTypeRep (SomeTypeRep r) = rnfTypeRep r
894
895 {- *********************************************************
896 * *
897 * TyCon/TypeRep definitions for type literals *
898 * (Symbol and Nat) *
899 * *
900 ********************************************************* -}
901
902 pattern KindRepTypeLit :: TypeLitSort -> String -> KindRep
903 pattern KindRepTypeLit sort t <- (getKindRepTypeLit -> Just (sort, t))
904 where
905 KindRepTypeLit sort t = KindRepTypeLitD sort t
906
907 {-# COMPLETE KindRepTyConApp, KindRepVar, KindRepApp, KindRepFun,
908 KindRepTYPE, KindRepTypeLit #-}
909
910 getKindRepTypeLit :: KindRep -> Maybe (TypeLitSort, String)
911 getKindRepTypeLit (KindRepTypeLitS sort t) = Just (sort, unpackCStringUtf8# t)
912 getKindRepTypeLit (KindRepTypeLitD sort t) = Just (sort, t)
913 getKindRepTypeLit _ = Nothing
914
915 -- | Exquisitely unsafe.
916 mkTyCon# :: Addr# -- ^ package name
917 -> Addr# -- ^ module name
918 -> Addr# -- ^ the name of the type constructor
919 -> Int# -- ^ number of kind variables
920 -> KindRep -- ^ kind representation
921 -> TyCon -- ^ A unique 'TyCon' object
922 mkTyCon# pkg modl name n_kinds kind_rep
923 | Fingerprint (W64# hi) (W64# lo) <- fingerprint
924 = TyCon hi lo mod (TrNameS name) n_kinds kind_rep
925 where
926 mod = Module (TrNameS pkg) (TrNameS modl)
927 fingerprint :: Fingerprint
928 fingerprint = mkTyConFingerprint (unpackCStringUtf8# pkg)
929 (unpackCStringUtf8# modl)
930 (unpackCStringUtf8# name)
931
932 -- it is extremely important that this fingerprint computation
933 -- remains in sync with that in TcTypeable to ensure that type
934 -- equality is correct.
935
936 -- | Exquisitely unsafe.
937 mkTyCon :: String -- ^ package name
938 -> String -- ^ module name
939 -> String -- ^ the name of the type constructor
940 -> Int -- ^ number of kind variables
941 -> KindRep -- ^ kind representation
942 -> TyCon -- ^ A unique 'TyCon' object
943 -- Used when the strings are dynamically allocated,
944 -- eg from binary deserialisation
945 mkTyCon pkg modl name (I# n_kinds) kind_rep
946 | Fingerprint (W64# hi) (W64# lo) <- fingerprint
947 = TyCon hi lo mod (TrNameD name) n_kinds kind_rep
948 where
949 mod = Module (TrNameD pkg) (TrNameD modl)
950 fingerprint :: Fingerprint
951 fingerprint = mkTyConFingerprint pkg modl name
952
953 -- This must match the computation done in TcTypeable.mkTyConRepTyConRHS.
954 mkTyConFingerprint :: String -- ^ package name
955 -> String -- ^ module name
956 -> String -- ^ tycon name
957 -> Fingerprint
958 mkTyConFingerprint pkg_name mod_name tycon_name =
959 fingerprintFingerprints
960 [ fingerprintString pkg_name
961 , fingerprintString mod_name
962 , fingerprintString tycon_name
963 ]
964
965 mkTypeLitTyCon :: String -> TyCon -> TyCon
966 mkTypeLitTyCon name kind_tycon
967 = mkTyCon "base" "GHC.TypeLits" name 0 kind
968 where kind = KindRepTyConApp kind_tycon []
969
970 -- | Used to make `'Typeable' instance for things of kind Nat
971 typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep a
972 typeNatTypeRep p = typeLitTypeRep (show (natVal' p)) tcNat
973
974 -- | Used to make `'Typeable' instance for things of kind Symbol
975 typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a
976 typeSymbolTypeRep p = typeLitTypeRep (show (symbolVal' p)) tcSymbol
977
978 mkTypeLitFromString :: TypeLitSort -> String -> SomeTypeRep
979 mkTypeLitFromString TypeLitSymbol s =
980 SomeTypeRep $ (typeLitTypeRep s tcSymbol :: TypeRep Symbol)
981 mkTypeLitFromString TypeLitNat s =
982 SomeTypeRep $ (typeLitTypeRep s tcSymbol :: TypeRep Nat)
983
984 tcSymbol :: TyCon
985 tcSymbol = typeRepTyCon (typeRep @Symbol)
986
987 tcNat :: TyCon
988 tcNat = typeRepTyCon (typeRep @Nat)
989
990 -- | An internal function, to make representations for type literals.
991 typeLitTypeRep :: forall k (a :: k). (Typeable k) =>
992 String -> TyCon -> TypeRep a
993 typeLitTypeRep nm kind_tycon = mkTrCon (mkTypeLitTyCon nm kind_tycon) []
994
995 -- | For compiler use.
996 mkTrFun :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
997 (a :: TYPE r1) (b :: TYPE r2).
998 TypeRep a -> TypeRep b -> TypeRep ((a -> b) :: Type)
999 mkTrFun arg res = TrFun
1000 { trFunFingerprint = fpr
1001 , trFunArg = arg
1002 , trFunRes = res }
1003 where fpr = fingerprintFingerprints [ typeRepFingerprint arg
1004 , typeRepFingerprint res]
1005
1006 {- $kind_instantiation
1007
1008 Consider a type like 'Data.Proxy.Proxy',
1009
1010 @
1011 data Proxy :: forall k. k -> Type
1012 @
1013
1014 One might think that one could decompose an instantiation of this type like
1015 @Proxy Int@ into two applications,
1016
1017 @
1018 'App' (App a b) c === typeRep @(Proxy Int)
1019 @
1020
1021 where,
1022
1023 @
1024 a = typeRep @Proxy
1025 b = typeRep @Type
1026 c = typeRep @Int
1027 @
1028
1029 However, this isn't the case. Instead we can only decompose into an application
1030 and a constructor,
1031
1032 @
1033 'App' ('Con' proxyTyCon) (typeRep @Int) === typeRep @(Proxy Int)
1034 @
1035
1036 The reason for this is that 'Typeable' can only represent /kind-monomorphic/
1037 types. That is, we must saturate enough of @Proxy@\'s arguments to
1038 fully determine its kind. In the particular case of @Proxy@ this means we must
1039 instantiate the kind variable @k@ such that no @forall@-quantified variables
1040 remain.
1041
1042 While it is not possible to decompose the 'Con' above into an application, it is
1043 possible to observe the kind variable instantiations of the constructor with the
1044 'Con\'' pattern,
1045
1046 @
1047 'App' (Con' proxyTyCon kinds) _ === typeRep @(Proxy Int)
1048 @
1049
1050 Here @kinds@ will be @[typeRep \@Type]@.
1051
1052 -}