Embrace -XTypeInType, add -XStarIsType
[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 (a :: k) (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 (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 (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 WordRep -> rep @'WordRep
668 Int64Rep -> rep @'Int64Rep
669 Word64Rep -> rep @'Word64Rep
670 AddrRep -> rep @'AddrRep
671 FloatRep -> rep @'FloatRep
672 DoubleRep -> rep @'DoubleRep
673 where
674 rep :: forall (a :: RuntimeRep). Typeable a => SomeKindedTypeRep RuntimeRep
675 rep = kindedTypeRep @RuntimeRep @a
676
677 vecCountTypeRep :: VecCount -> SomeKindedTypeRep VecCount
678 vecCountTypeRep c =
679 case c of
680 Vec2 -> rep @'Vec2
681 Vec4 -> rep @'Vec4
682 Vec8 -> rep @'Vec8
683 Vec16 -> rep @'Vec16
684 Vec32 -> rep @'Vec32
685 Vec64 -> rep @'Vec64
686 where
687 rep :: forall (a :: VecCount). Typeable a => SomeKindedTypeRep VecCount
688 rep = kindedTypeRep @VecCount @a
689
690 vecElemTypeRep :: VecElem -> SomeKindedTypeRep VecElem
691 vecElemTypeRep e =
692 case e of
693 Int8ElemRep -> rep @'Int8ElemRep
694 Int16ElemRep -> rep @'Int16ElemRep
695 Int32ElemRep -> rep @'Int32ElemRep
696 Int64ElemRep -> rep @'Int64ElemRep
697 Word8ElemRep -> rep @'Word8ElemRep
698 Word16ElemRep -> rep @'Word16ElemRep
699 Word32ElemRep -> rep @'Word32ElemRep
700 Word64ElemRep -> rep @'Word64ElemRep
701 FloatElemRep -> rep @'FloatElemRep
702 DoubleElemRep -> rep @'DoubleElemRep
703 where
704 rep :: forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem
705 rep = kindedTypeRep @VecElem @a
706
707 bareArrow :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
708 (a :: TYPE r1) (b :: TYPE r2). ()
709 => TypeRep (a -> b)
710 -> TypeRep ((->) :: TYPE r1 -> TYPE r2 -> Type)
711 bareArrow (TrFun _ a b) =
712 mkTrCon funTyCon [SomeTypeRep rep1, SomeTypeRep rep2]
713 where
714 rep1 = getRuntimeRep $ typeRepKind a :: TypeRep r1
715 rep2 = getRuntimeRep $ typeRepKind b :: TypeRep r2
716 bareArrow _ = error "Data.Typeable.Internal.bareArrow: impossible"
717
718 data IsTYPE (a :: Type) where
719 IsTYPE :: forall (r :: RuntimeRep). TypeRep r -> IsTYPE (TYPE r)
720
721 -- | Is a type of the form @TYPE rep@?
722 isTYPE :: TypeRep (a :: Type) -> Maybe (IsTYPE a)
723 isTYPE TrType = Just (IsTYPE trLiftedRep)
724 isTYPE (TrApp {trAppFun=f, trAppArg=r})
725 | Just HRefl <- f `eqTypeRep` typeRep @TYPE
726 = Just (IsTYPE r)
727 isTYPE _ = Nothing
728
729 getRuntimeRep :: forall (r :: RuntimeRep). TypeRep (TYPE r) -> TypeRep r
730 getRuntimeRep TrType = trLiftedRep
731 getRuntimeRep (TrApp {trAppArg=r}) = r
732 getRuntimeRep _ = error "Data.Typeable.Internal.getRuntimeRep: impossible"
733
734
735 -------------------------------------------------------------
736 --
737 -- The Typeable class and friends
738 --
739 -------------------------------------------------------------
740
741 -- | The class 'Typeable' allows a concrete representation of a type to
742 -- be calculated.
743 class Typeable (a :: k) where
744 typeRep# :: TypeRep a
745
746 typeRep :: Typeable a => TypeRep a
747 typeRep = typeRep#
748
749 typeOf :: Typeable a => a -> TypeRep a
750 typeOf _ = typeRep
751
752 -- | Takes a value of type @a@ and returns a concrete representation
753 -- of that type.
754 --
755 -- @since 4.7.0.0
756 someTypeRep :: forall proxy a. Typeable a => proxy a -> SomeTypeRep
757 someTypeRep _ = SomeTypeRep (typeRep :: TypeRep a)
758 {-# INLINE typeRep #-}
759
760 someTypeRepFingerprint :: SomeTypeRep -> Fingerprint
761 someTypeRepFingerprint (SomeTypeRep t) = typeRepFingerprint t
762
763 ----------------- Showing TypeReps --------------------
764
765 -- This follows roughly the precedence structure described in Note [Precedence
766 -- in types].
767 instance Show (TypeRep (a :: k)) where
768 showsPrec = showTypeable
769
770
771 showTypeable :: Int -> TypeRep (a :: k) -> ShowS
772 showTypeable _ TrType = showChar '*'
773 showTypeable _ rep
774 | isListTyCon tc, [ty] <- tys =
775 showChar '[' . shows ty . showChar ']'
776 | isTupleTyCon tc =
777 showChar '(' . showArgs (showChar ',') tys . showChar ')'
778 where (tc, tys) = splitApps rep
779 showTypeable _ (TrTyCon {trTyCon = tycon, trKindVars = []})
780 = showTyCon tycon
781 showTypeable p (TrTyCon {trTyCon = tycon, trKindVars = args})
782 = showParen (p > 9) $
783 showTyCon tycon .
784 showChar ' ' .
785 showArgs (showChar ' ') args
786 showTypeable p (TrFun {trFunArg = x, trFunRes = r})
787 = showParen (p > 8) $
788 showsPrec 9 x . showString " -> " . showsPrec 8 r
789 showTypeable p (TrApp {trAppFun = f, trAppArg = x})
790 = showParen (p > 9) $
791 showsPrec 8 f .
792 showChar ' ' .
793 showsPrec 10 x
794
795 -- | @since 4.10.0.0
796 instance Show SomeTypeRep where
797 showsPrec p (SomeTypeRep ty) = showsPrec p ty
798
799 splitApps :: TypeRep a -> (TyCon, [SomeTypeRep])
800 splitApps = go []
801 where
802 go :: [SomeTypeRep] -> TypeRep a -> (TyCon, [SomeTypeRep])
803 go xs (TrTyCon {trTyCon = tc})
804 = (tc, xs)
805 go xs (TrApp {trAppFun = f, trAppArg = x})
806 = go (SomeTypeRep x : xs) f
807 go [] (TrFun {trFunArg = a, trFunRes = b})
808 = (funTyCon, [SomeTypeRep a, SomeTypeRep b])
809 go _ (TrFun {})
810 = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 1"
811 go [] TrType = (tyConTYPE, [SomeTypeRep trLiftedRep])
812 go _ TrType
813 = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 2"
814
815 -- This is incredibly shady! We don't really want to do this here; we
816 -- should really have the compiler reveal the TYPE TyCon directly
817 -- somehow. We need to construct this by hand because otherwise
818 -- we end up with horrible and somewhat mysterious loops trying to calculate
819 -- typeRep @TYPE. For the moment, we use the fact that we can get the proper
820 -- name of the ghc-prim package from the TyCon of LiftedRep (which we can
821 -- produce a TypeRep for without difficulty), and then just substitute in the
822 -- appropriate module and constructor names.
823 --
824 -- The ticket to find a better way to deal with this is
825 -- Trac #14480.
826 tyConTYPE :: TyCon
827 tyConTYPE = mkTyCon (tyConPackage liftedRepTyCon) "GHC.Prim" "TYPE" 0
828 (KindRepFun (KindRepTyConApp liftedRepTyCon []) (KindRepTYPE LiftedRep))
829 where
830 liftedRepTyCon = typeRepTyCon (typeRep @RuntimeRep)
831
832 funTyCon :: TyCon
833 funTyCon = typeRepTyCon (typeRep @(->))
834
835 isListTyCon :: TyCon -> Bool
836 isListTyCon tc = tc == typeRepTyCon (typeRep :: TypeRep [])
837
838 isTupleTyCon :: TyCon -> Bool
839 isTupleTyCon tc
840 | ('(':',':_) <- tyConName tc = True
841 | otherwise = False
842
843 -- This is only an approximation. We don't have the general
844 -- character-classification machinery here, so we just do our best.
845 -- This should work for promoted Haskell 98 data constructors and
846 -- for TypeOperators type constructors that begin with ASCII
847 -- characters, but it will miss Unicode operators.
848 --
849 -- If we wanted to catch Unicode as well, we ought to consider moving
850 -- GHC.Lexeme from ghc-boot-th to base. Then we could just say:
851 --
852 -- startsVarSym symb || startsConSym symb
853 --
854 -- But this is a fair deal of work just for one corner case, so I think I'll
855 -- leave it like this unless someone shouts.
856 isOperatorTyCon :: TyCon -> Bool
857 isOperatorTyCon tc
858 | symb : _ <- tyConName tc
859 , symb `elem` "!#$%&*+./<=>?@\\^|-~:" = True
860 | otherwise = False
861
862 showTyCon :: TyCon -> ShowS
863 showTyCon tycon = showParen (isOperatorTyCon tycon) (shows tycon)
864
865 showArgs :: Show a => ShowS -> [a] -> ShowS
866 showArgs _ [] = id
867 showArgs _ [a] = showsPrec 10 a
868 showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as
869
870 -- | Helper to fully evaluate 'TypeRep' for use as @NFData(rnf)@ implementation
871 --
872 -- @since 4.8.0.0
873 rnfTypeRep :: TypeRep a -> ()
874 -- The TypeRep structure is almost entirely strict by definition. The
875 -- fingerprinting and strict kind caching ensure that everything
876 -- else is forced anyway. So we don't need to do anything special
877 -- to reduce to normal form.
878 rnfTypeRep !_ = ()
879
880 -- | Helper to fully evaluate 'SomeTypeRep' for use as @NFData(rnf)@
881 -- implementation
882 --
883 -- @since 4.10.0.0
884 rnfSomeTypeRep :: SomeTypeRep -> ()
885 rnfSomeTypeRep (SomeTypeRep r) = rnfTypeRep r
886
887 {- *********************************************************
888 * *
889 * TyCon/TypeRep definitions for type literals *
890 * (Symbol and Nat) *
891 * *
892 ********************************************************* -}
893
894 pattern KindRepTypeLit :: TypeLitSort -> String -> KindRep
895 pattern KindRepTypeLit sort t <- (getKindRepTypeLit -> Just (sort, t))
896 where
897 KindRepTypeLit sort t = KindRepTypeLitD sort t
898
899 {-# COMPLETE KindRepTyConApp, KindRepVar, KindRepApp, KindRepFun,
900 KindRepTYPE, KindRepTypeLit #-}
901
902 getKindRepTypeLit :: KindRep -> Maybe (TypeLitSort, String)
903 getKindRepTypeLit (KindRepTypeLitS sort t) = Just (sort, unpackCStringUtf8# t)
904 getKindRepTypeLit (KindRepTypeLitD sort t) = Just (sort, t)
905 getKindRepTypeLit _ = Nothing
906
907 -- | Exquisitely unsafe.
908 mkTyCon# :: Addr# -- ^ package name
909 -> Addr# -- ^ module name
910 -> Addr# -- ^ the name of the type constructor
911 -> Int# -- ^ number of kind variables
912 -> KindRep -- ^ kind representation
913 -> TyCon -- ^ A unique 'TyCon' object
914 mkTyCon# pkg modl name n_kinds kind_rep
915 | Fingerprint (W64# hi) (W64# lo) <- fingerprint
916 = TyCon hi lo mod (TrNameS name) n_kinds kind_rep
917 where
918 mod = Module (TrNameS pkg) (TrNameS modl)
919 fingerprint :: Fingerprint
920 fingerprint = mkTyConFingerprint (unpackCStringUtf8# pkg)
921 (unpackCStringUtf8# modl)
922 (unpackCStringUtf8# name)
923
924 -- it is extremely important that this fingerprint computation
925 -- remains in sync with that in TcTypeable to ensure that type
926 -- equality is correct.
927
928 -- | Exquisitely unsafe.
929 mkTyCon :: String -- ^ package name
930 -> String -- ^ module name
931 -> String -- ^ the name of the type constructor
932 -> Int -- ^ number of kind variables
933 -> KindRep -- ^ kind representation
934 -> TyCon -- ^ A unique 'TyCon' object
935 -- Used when the strings are dynamically allocated,
936 -- eg from binary deserialisation
937 mkTyCon pkg modl name (I# n_kinds) kind_rep
938 | Fingerprint (W64# hi) (W64# lo) <- fingerprint
939 = TyCon hi lo mod (TrNameD name) n_kinds kind_rep
940 where
941 mod = Module (TrNameD pkg) (TrNameD modl)
942 fingerprint :: Fingerprint
943 fingerprint = mkTyConFingerprint pkg modl name
944
945 -- This must match the computation done in TcTypeable.mkTyConRepTyConRHS.
946 mkTyConFingerprint :: String -- ^ package name
947 -> String -- ^ module name
948 -> String -- ^ tycon name
949 -> Fingerprint
950 mkTyConFingerprint pkg_name mod_name tycon_name =
951 fingerprintFingerprints
952 [ fingerprintString pkg_name
953 , fingerprintString mod_name
954 , fingerprintString tycon_name
955 ]
956
957 mkTypeLitTyCon :: String -> TyCon -> TyCon
958 mkTypeLitTyCon name kind_tycon
959 = mkTyCon "base" "GHC.TypeLits" name 0 kind
960 where kind = KindRepTyConApp kind_tycon []
961
962 -- | Used to make `'Typeable' instance for things of kind Nat
963 typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep a
964 typeNatTypeRep p = typeLitTypeRep (show (natVal' p)) tcNat
965
966 -- | Used to make `'Typeable' instance for things of kind Symbol
967 typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a
968 typeSymbolTypeRep p = typeLitTypeRep (show (symbolVal' p)) tcSymbol
969
970 mkTypeLitFromString :: TypeLitSort -> String -> SomeTypeRep
971 mkTypeLitFromString TypeLitSymbol s =
972 SomeTypeRep $ (typeLitTypeRep s tcSymbol :: TypeRep Symbol)
973 mkTypeLitFromString TypeLitNat s =
974 SomeTypeRep $ (typeLitTypeRep s tcSymbol :: TypeRep Nat)
975
976 tcSymbol :: TyCon
977 tcSymbol = typeRepTyCon (typeRep @Symbol)
978
979 tcNat :: TyCon
980 tcNat = typeRepTyCon (typeRep @Nat)
981
982 -- | An internal function, to make representations for type literals.
983 typeLitTypeRep :: forall (a :: k). (Typeable k) => String -> TyCon -> TypeRep a
984 typeLitTypeRep nm kind_tycon = mkTrCon (mkTypeLitTyCon nm kind_tycon) []
985
986 -- | For compiler use.
987 mkTrFun :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
988 (a :: TYPE r1) (b :: TYPE r2).
989 TypeRep a -> TypeRep b -> TypeRep ((a -> b) :: Type)
990 mkTrFun arg res = TrFun
991 { trFunFingerprint = fpr
992 , trFunArg = arg
993 , trFunRes = res }
994 where fpr = fingerprintFingerprints [ typeRepFingerprint arg
995 , typeRepFingerprint res]
996
997 {- $kind_instantiation
998
999 Consider a type like 'Data.Proxy.Proxy',
1000
1001 @
1002 data Proxy :: forall k. k -> Type
1003 @
1004
1005 One might think that one could decompose an instantiation of this type like
1006 @Proxy Int@ into two applications,
1007
1008 @
1009 'App' (App a b) c === typeRep @(Proxy Int)
1010 @
1011
1012 where,
1013
1014 @
1015 a = typeRep @Proxy
1016 b = typeRep @Type
1017 c = typeRep @Int
1018 @
1019
1020 However, this isn't the case. Instead we can only decompose into an application
1021 and a constructor,
1022
1023 @
1024 'App' ('Con' proxyTyCon) (typeRep @Int) === typeRep @(Proxy Int)
1025 @
1026
1027 The reason for this is that 'Typeable' can only represent /kind-monomorphic/
1028 types. That is, we must saturate enough of @Proxy@\'s arguments to
1029 fully determine its kind. In the particular case of @Proxy@ this means we must
1030 instantiate the kind variable @k@ such that no @forall@-quantified variables
1031 remain.
1032
1033 While it is not possible to decompose the 'Con' above into an application, it is
1034 possible to observe the kind variable instantiations of the constructor with the
1035 'Con\'' pattern,
1036
1037 @
1038 'App' (Con' proxyTyCon kinds) _ === typeRep @(Proxy Int)
1039 @
1040
1041 Here @kinds@ will be @[typeRep \@Type]@.
1042
1043 -}