1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
|
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1999
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module TcTypeable(mkTypeableBinds) where
#include "HsVersions.h"
import GhcPrelude
import BasicTypes ( Boxity(..), neverInlinePragma, SourceText(..) )
import TcBinds( addTypecheckedBinds )
import IfaceEnv( newGlobalBinder )
import TyCoRep( Type(..), TyLit(..) )
import TcEnv
import TcEvidence ( mkWpTyApps )
import TcRnMonad
import TcTypeableValidity
import HscTypes ( lookupId )
import PrelNames
import TysPrim ( primTyCons )
import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon
, vecCountTyCon, vecElemTyCon
, nilDataCon, consDataCon )
import Name
import Id
import Type
import TyCon
import DataCon
import Module
import GHC.Hs
import DynFlags
import Bag
import Var ( VarBndr(..) )
import CoreMap
import Constants
import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints)
import Outputable
import FastString ( FastString, mkFastString, fsLit )
import Control.Monad.Trans.State
import Control.Monad.Trans.Class (lift)
import Data.Word( Word64 )
{- Note [Grand plan for Typeable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The overall plan is this:
1. Generate a binding for each module p:M
(done in TcTypeable by mkModIdBindings)
M.$trModule :: GHC.Types.Module
M.$trModule = Module "p" "M"
("tr" is short for "type representation"; see GHC.Types)
We might want to add the filename too.
This can be used for the lightweight stack-tracing stuff too
Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv
2. Generate a binding for every data type declaration T in module M,
M.$tcT :: GHC.Types.TyCon
M.$tcT = TyCon ...fingerprint info...
$trModule
"T"
0#
kind_rep
Here 0# is the number of arguments expected by the tycon to fully determine
its kind. kind_rep is a value of type GHC.Types.KindRep, which gives a
recipe for computing the kind of an instantiation of the tycon (see
Note [Representing TyCon kinds: KindRep] later in this file for details).
We define (in TyCon)
type TyConRepName = Name
to use for these M.$tcT "tycon rep names". Note that these must be
treated as "never exported" names by Backpack (see
Note [Handling never-exported TyThings under Backpack]). Consequently
they get slightly special treatment in RnModIface.rnIfaceDecl.
3. Record the TyConRepName in T's TyCon, including for promoted
data and type constructors, and kinds like * and #.
The TyConRepName is not an "implicit Id". It's more like a record
selector: the TyCon knows its name but you have to go to the
interface file to find its type, value, etc
4. Solve Typeable constraints. This is done by a custom Typeable solver,
currently in TcInteract, that use M.$tcT so solve (Typeable T).
There are many wrinkles:
* The timing of when we produce this bindings is rather important: they must be
defined after the rest of the module has been typechecked since we need to be
able to lookup Module and TyCon in the type environment and we may be
currently compiling GHC.Types (where they are defined).
* GHC.Prim doesn't have any associated object code, so we need to put the
representations for types defined in this module elsewhere. We chose this
place to be GHC.Types. TcTypeable.mkPrimTypeableBinds is responsible for
injecting the bindings for the GHC.Prim representions when compiling
GHC.Types.
* TyCon.tyConRepModOcc is responsible for determining where to find
the representation binding for a given type. This is where we handle
the special case for GHC.Prim.
* To save space and reduce dependencies, we need use quite low-level
representations for TyCon and Module. See GHC.Types
Note [Runtime representation of modules and tycons]
* The KindReps can unfortunately get quite large. Moreover, the simplifier will
float out various pieces of them, resulting in numerous top-level bindings.
Consequently we mark the KindRep bindings as noinline, ensuring that the
float-outs don't make it into the interface file. This is important since
there is generally little benefit to inlining KindReps and they would
otherwise strongly affect compiler performance.
* In general there are lots of things of kind *, * -> *, and * -> * -> *. To
reduce the number of bindings we need to produce, we generate their KindReps
once in GHC.Types. These are referred to as "built-in" KindReps below.
* Even though KindReps aren't inlined, this scheme still has more of an effect on
compilation time than I'd like. This is especially true in the case of
families of type constructors (e.g. tuples and unboxed sums). The problem is
particularly bad in the case of sums, since each arity-N tycon brings with it
N promoted datacons, each with a KindRep whose size also scales with N.
Consequently we currently simply don't allow sums to be Typeable.
In general we might consider moving some or all of this generation logic back
to the solver since the performance hit we take in doing this at
type-definition time is non-trivial and Typeable isn't very widely used. This
is discussed in #13261.
-}
-- | Generate the Typeable bindings for a module. This is the only
-- entry-point of this module and is invoked by the typechecker driver in
-- 'tcRnSrcDecls'.
--
-- See Note [Grand plan for Typeable] in TcTypeable.
mkTypeableBinds :: TcM TcGblEnv
mkTypeableBinds
= do { dflags <- getDynFlags
; if gopt Opt_NoTypeableBinds dflags then getGblEnv else do
{ -- Create a binding for $trModule.
-- Do this before processing any data type declarations,
-- which need tcg_tr_module to be initialised
; tcg_env <- mkModIdBindings
-- Now we can generate the TyCon representations...
-- First we handle the primitive TyCons if we are compiling GHC.Types
; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos
-- Then we produce bindings for the user-defined types in this module.
; setGblEnv tcg_env $
do { mod <- getModule
; let tycons = filter needs_typeable_binds (tcg_tcs tcg_env)
mod_id = case tcg_tr_module tcg_env of -- Should be set by now
Just mod_id -> mod_id
Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons)
; traceTc "mkTypeableBinds" (ppr tycons)
; this_mod_todos <- todoForTyCons mod mod_id tycons
; mkTypeRepTodoBinds (this_mod_todos : prim_todos)
} } }
where
needs_typeable_binds tc
| tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon]
= False
| otherwise =
isAlgTyCon tc
|| isDataFamilyTyCon tc
|| isClassTyCon tc
{- *********************************************************************
* *
Building top-level binding for $trModule
* *
********************************************************************* -}
mkModIdBindings :: TcM TcGblEnv
mkModIdBindings
= do { mod <- getModule
; loc <- getSrcSpanM
; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc
; trModuleTyCon <- tcLookupTyCon trModuleTyConName
; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon [])
; mod_bind <- mkVarBind mod_id <$> mkModIdRHS mod
; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
; return (tcg_env { tcg_tr_module = Just mod_id }
`addTypecheckedBinds` [unitBag mod_bind]) }
mkModIdRHS :: Module -> TcM (LHsExpr GhcTc)
mkModIdRHS mod
= do { trModuleDataCon <- tcLookupDataCon trModuleDataConName
; trNameLit <- mkTrNameLit
; return $ nlHsDataCon trModuleDataCon
`nlHsApp` trNameLit (unitIdFS (moduleUnitId mod))
`nlHsApp` trNameLit (moduleNameFS (moduleName mod))
}
{- *********************************************************************
* *
Building type-representation bindings
* *
********************************************************************* -}
-- | Information we need about a 'TyCon' to generate its representation. We
-- carry the 'Id' in order to share it between the generation of the @TyCon@ and
-- @KindRep@ bindings.
data TypeableTyCon
= TypeableTyCon
{ tycon :: !TyCon
, tycon_rep_id :: !Id
}
-- | A group of 'TyCon's in need of type-rep bindings.
data TypeRepTodo
= TypeRepTodo
{ mod_rep_expr :: LHsExpr GhcTc -- ^ Module's typerep binding
, pkg_fingerprint :: !Fingerprint -- ^ Package name fingerprint
, mod_fingerprint :: !Fingerprint -- ^ Module name fingerprint
, todo_tycons :: [TypeableTyCon]
-- ^ The 'TyCon's in need of bindings kinds
}
| ExportedKindRepsTodo [(Kind, Id)]
-- ^ Build exported 'KindRep' bindings for the given set of kinds.
todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo
todoForTyCons mod mod_id tycons = do
trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName
let mk_rep_id :: TyConRepName -> Id
mk_rep_id rep_name = mkExportedVanillaId rep_name trTyConTy
let typeable_tycons :: [TypeableTyCon]
typeable_tycons =
[ TypeableTyCon { tycon = tc''
, tycon_rep_id = mk_rep_id rep_name
}
| tc <- tycons
, tc' <- tc : tyConATs tc
-- We need type representations for any associated types
, let promoted = map promoteDataCon (tyConDataCons tc')
, tc'' <- tc' : promoted
-- Don't make bindings for data-family instance tycons.
-- Do, however, make them for their promoted datacon (see #13915).
, not $ isFamInstTyCon tc''
, Just rep_name <- pure $ tyConRepName_maybe tc''
, typeIsTypeable $ dropForAlls $ tyConKind tc''
]
return TypeRepTodo { mod_rep_expr = nlHsVar mod_id
, pkg_fingerprint = pkg_fpr
, mod_fingerprint = mod_fpr
, todo_tycons = typeable_tycons
}
where
mod_fpr = fingerprintString $ moduleNameString $ moduleName mod
pkg_fpr = fingerprintString $ unitIdString $ moduleUnitId mod
todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo
todoForExportedKindReps kinds = do
trKindRepTy <- mkTyConTy <$> tcLookupTyCon kindRepTyConName
let mkId (k, name) = (k, mkExportedVanillaId name trKindRepTy)
return $ ExportedKindRepsTodo $ map mkId kinds
-- | Generate TyCon bindings for a set of type constructors
mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv
mkTypeRepTodoBinds [] = getGblEnv
mkTypeRepTodoBinds todos
= do { stuff <- collect_stuff
-- First extend the type environment with all of the bindings
-- which we are going to produce since we may need to refer to them
-- while generating kind representations (namely, when we want to
-- represent a TyConApp in a kind, we must be able to look up the
-- TyCon associated with the applied type constructor).
; let produced_bndrs :: [Id]
produced_bndrs = [ tycon_rep_id
| todo@(TypeRepTodo{}) <- todos
, TypeableTyCon {..} <- todo_tycons todo
] ++
[ rep_id
| ExportedKindRepsTodo kinds <- todos
, (_, rep_id) <- kinds
]
; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv
; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc]
mk_binds todo@(TypeRepTodo {}) =
mapM (mkTyConRepBinds stuff todo) (todo_tycons todo)
mk_binds (ExportedKindRepsTodo kinds) =
mkExportedKindReps stuff kinds >> return []
; (gbl_env, binds) <- setGblEnv gbl_env
$ runKindRepM (mapM mk_binds todos)
; return $ gbl_env `addTypecheckedBinds` concat binds }
-- | Generate bindings for the type representation of a wired-in 'TyCon's
-- defined by the virtual "GHC.Prim" module. This is where we inject the
-- representation bindings for these primitive types into "GHC.Types"
--
-- See Note [Grand plan for Typeable] in this module.
mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo])
mkPrimTypeableTodos
= do { mod <- getModule
; if mod == gHC_TYPES
then do { -- Build Module binding for GHC.Prim
trModuleTyCon <- tcLookupTyCon trModuleTyConName
; let ghc_prim_module_id =
mkExportedVanillaId trGhcPrimModuleName
(mkTyConTy trModuleTyCon)
; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id
<$> mkModIdRHS gHC_PRIM
-- Extend our environment with above
; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id]
getGblEnv
; let gbl_env' = gbl_env `addTypecheckedBinds`
[unitBag ghc_prim_module_bind]
-- Build TypeRepTodos for built-in KindReps
; todo1 <- todoForExportedKindReps builtInKindReps
-- Build TypeRepTodos for types in GHC.Prim
; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id
ghcPrimTypeableTyCons
; return ( gbl_env' , [todo1, todo2])
}
else do gbl_env <- getGblEnv
return (gbl_env, [])
}
-- | This is the list of primitive 'TyCon's for which we must generate bindings
-- in "GHC.Types". This should include all types defined in "GHC.Prim".
--
-- The majority of the types we need here are contained in 'primTyCons'.
-- However, not all of them: in particular unboxed tuples are absent since we
-- don't want to include them in the original name cache. See
-- Note [Built-in syntax and the OrigNameCache] in IfaceEnv for more.
ghcPrimTypeableTyCons :: [TyCon]
ghcPrimTypeableTyCons = concat
[ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon, funTyCon ]
, map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE]
, map sumTyCon [2..mAX_SUM_SIZE]
, primTyCons
]
data TypeableStuff
= Stuff { dflags :: DynFlags
, trTyConDataCon :: DataCon -- ^ of @TyCon@
, trNameLit :: FastString -> LHsExpr GhcTc
-- ^ To construct @TrName@s
-- The various TyCon and DataCons of KindRep
, kindRepTyCon :: TyCon
, kindRepTyConAppDataCon :: DataCon
, kindRepVarDataCon :: DataCon
, kindRepAppDataCon :: DataCon
, kindRepFunDataCon :: DataCon
, kindRepTYPEDataCon :: DataCon
, kindRepTypeLitSDataCon :: DataCon
, typeLitSymbolDataCon :: DataCon
, typeLitNatDataCon :: DataCon
}
-- | Collect various tidbits which we'll need to generate TyCon representations.
collect_stuff :: TcM TypeableStuff
collect_stuff = do
dflags <- getDynFlags
trTyConDataCon <- tcLookupDataCon trTyConDataConName
kindRepTyCon <- tcLookupTyCon kindRepTyConName
kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName
kindRepVarDataCon <- tcLookupDataCon kindRepVarDataConName
kindRepAppDataCon <- tcLookupDataCon kindRepAppDataConName
kindRepFunDataCon <- tcLookupDataCon kindRepFunDataConName
kindRepTYPEDataCon <- tcLookupDataCon kindRepTYPEDataConName
kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName
typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName
typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName
trNameLit <- mkTrNameLit
return Stuff {..}
-- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we
-- can save the work of repeating lookups when constructing many TyCon
-- representations.
mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc)
mkTrNameLit = do
trNameSDataCon <- tcLookupDataCon trNameSDataConName
let trNameLit :: FastString -> LHsExpr GhcTc
trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon
`nlHsApp` nlHsLit (mkHsStringPrimLit fs)
return trNameLit
-- | Make Typeable bindings for the given 'TyCon'.
mkTyConRepBinds :: TypeableStuff -> TypeRepTodo
-> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
mkTyConRepBinds stuff todo (TypeableTyCon {..})
= do -- Make a KindRep
let (bndrs, kind) = splitForAllVarBndrs (tyConKind tycon)
liftTc $ traceTc "mkTyConKindRepBinds"
(ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind)
let ctx = mkDeBruijnContext (map binderVar bndrs)
kind_rep <- getKindRep stuff ctx kind
-- Make the TyCon binding
let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep
tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs
return $ unitBag tycon_rep_bind
-- | Maps kinds to 'KindRep' bindings. This binding may either be defined in
-- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing')
-- or a binding which we generated in the current module (in which case it will
-- be 'Just' the RHS of the binding).
type KindRepEnv = TypeMap (Id, Maybe (LHsExpr GhcTc))
-- | A monad within which we will generate 'KindRep's. Here we keep an
-- environment containing 'KindRep's which we've already generated so we can
-- re-use them opportunistically.
newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a }
deriving (Functor, Applicative, Monad)
liftTc :: TcRn a -> KindRepM a
liftTc = KindRepM . lift
-- | We generate @KindRep@s for a few common kinds in @GHC.Types@ so that they
-- can be reused across modules.
builtInKindReps :: [(Kind, Name)]
builtInKindReps =
[ (star, starKindRepName)
, (mkVisFunTy star star, starArrStarKindRepName)
, (mkVisFunTys [star, star] star, starArrStarArrStarKindRepName)
]
where
star = liftedTypeKind
initialKindRepEnv :: TcRn KindRepEnv
initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps
where
add_kind_rep acc (k,n) = do
id <- tcLookupId n
return $! extendTypeMap acc k (id, Nothing)
-- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's.
mkExportedKindReps :: TypeableStuff
-> [(Kind, Id)] -- ^ the kinds to generate bindings for
-> KindRepM ()
mkExportedKindReps stuff = mapM_ kindrep_binding
where
empty_scope = mkDeBruijnContext []
kindrep_binding :: (Kind, Id) -> KindRepM ()
kindrep_binding (kind, rep_bndr) = do
-- We build the binding manually here instead of using mkKindRepRhs
-- since the latter would find the built-in 'KindRep's in the
-- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv').
rhs <- mkKindRepRhs stuff empty_scope kind
addKindRepBind empty_scope kind rep_bndr rhs
addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM ()
addKindRepBind in_scope k bndr rhs =
KindRepM $ modify' $
\env -> extendTypeMapWithScope env in_scope k (bndr, Just rhs)
-- | Run a 'KindRepM' and add the produced 'KindRep's to the typechecking
-- environment.
runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a)
runKindRepM (KindRepM action) = do
kindRepEnv <- initialKindRepEnv
(res, reps_env) <- runStateT action kindRepEnv
let rep_binds = foldTypeMap to_bind_pair [] reps_env
to_bind_pair (bndr, Just rhs) rest = (bndr, rhs) : rest
to_bind_pair (_, Nothing) rest = rest
tcg_env <- tcExtendGlobalValEnv (map fst rep_binds) getGblEnv
let binds = map (uncurry mkVarBind) rep_binds
tcg_env' = tcg_env `addTypecheckedBinds` [listToBag binds]
return (tcg_env', res)
-- | Produce or find a 'KindRep' for the given kind.
getKindRep :: TypeableStuff -> CmEnv -- ^ in-scope kind variables
-> Kind -- ^ the kind we want a 'KindRep' for
-> KindRepM (LHsExpr GhcTc)
getKindRep stuff@(Stuff {..}) in_scope = go
where
go :: Kind -> KindRepM (LHsExpr GhcTc)
go = KindRepM . StateT . go'
go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)
go' k env
-- Look through type synonyms
| Just k' <- tcView k = go' k' env
-- We've already generated the needed KindRep
| Just (id, _) <- lookupTypeMapWithScope env in_scope k
= return (nlHsVar id, env)
-- We need to construct a new KindRep binding
| otherwise
= do -- Place a NOINLINE pragma on KindReps since they tend to be quite
-- large and bloat interface files.
rep_bndr <- (`setInlinePragma` neverInlinePragma)
<$> newSysLocalId (fsLit "$krep") (mkTyConTy kindRepTyCon)
-- do we need to tie a knot here?
flip runStateT env $ unKindRepM $ do
rhs <- mkKindRepRhs stuff in_scope k
addKindRepBind in_scope k rep_bndr rhs
return $ nlHsVar rep_bndr
-- | Construct the right-hand-side of the 'KindRep' for the given 'Kind' and
-- in-scope kind variable set.
mkKindRepRhs :: TypeableStuff
-> CmEnv -- ^ in-scope kind variables
-> Kind -- ^ the kind we want a 'KindRep' for
-> KindRepM (LHsExpr GhcTc) -- ^ RHS expression
mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep
where
new_kind_rep k
-- We handle (TYPE LiftedRep) etc separately to make it
-- clear to consumers (e.g. serializers) that there is
-- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep)
| not (tcIsConstraintKind k)
-- Typeable respects the Constraint/Type distinction
-- so do not follow the special case here
, Just arg <- kindRep_maybe k
, Just (tc, []) <- splitTyConApp_maybe arg
, Just dc <- isPromotedDataCon_maybe tc
= return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc
new_kind_rep (TyVarTy v)
| Just idx <- lookupCME in_scope v
= return $ nlHsDataCon kindRepVarDataCon
`nlHsApp` nlHsIntLit (fromIntegral idx)
| otherwise
= pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v)
new_kind_rep (AppTy t1 t2)
= do rep1 <- getKindRep stuff in_scope t1
rep2 <- getKindRep stuff in_scope t2
return $ nlHsDataCon kindRepAppDataCon
`nlHsApp` rep1 `nlHsApp` rep2
new_kind_rep k@(TyConApp tc tys)
| Just rep_name <- tyConRepName_maybe tc
= do rep_id <- liftTc $ lookupId rep_name
tys' <- mapM (getKindRep stuff in_scope) tys
return $ nlHsDataCon kindRepTyConAppDataCon
`nlHsApp` nlHsVar rep_id
`nlHsApp` mkList (mkTyConTy kindRepTyCon) tys'
| otherwise
= pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k)
new_kind_rep (ForAllTy (Bndr var _) ty)
= pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty)
new_kind_rep (FunTy _ t1 t2)
= do rep1 <- getKindRep stuff in_scope t1
rep2 <- getKindRep stuff in_scope t2
return $ nlHsDataCon kindRepFunDataCon
`nlHsApp` rep1 `nlHsApp` rep2
new_kind_rep (LitTy (NumTyLit n))
= return $ nlHsDataCon kindRepTypeLitSDataCon
`nlHsApp` nlHsDataCon typeLitNatDataCon
`nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n)
new_kind_rep (LitTy (StrTyLit s))
= return $ nlHsDataCon kindRepTypeLitSDataCon
`nlHsApp` nlHsDataCon typeLitSymbolDataCon
`nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s)
new_kind_rep (CastTy ty co)
= pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co)
new_kind_rep (CoercionTy co)
= pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co)
-- | Produce the right-hand-side of a @TyCon@ representation.
mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo
-> TyCon -- ^ the 'TyCon' we are producing a binding for
-> LHsExpr GhcTc -- ^ its 'KindRep'
-> LHsExpr GhcTc
mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep
= nlHsDataCon trTyConDataCon
`nlHsApp` nlHsLit (word64 dflags high)
`nlHsApp` nlHsLit (word64 dflags low)
`nlHsApp` mod_rep_expr todo
`nlHsApp` trNameLit (mkFastString tycon_str)
`nlHsApp` nlHsLit (int n_kind_vars)
`nlHsApp` kind_rep
where
n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon)
tycon_str = add_tick (occNameString (getOccName tycon))
add_tick s | isPromotedDataCon tycon = '\'' : s
| otherwise = s
-- This must match the computation done in
-- Data.Typeable.Internal.mkTyConFingerprint.
Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo
, mod_fingerprint todo
, fingerprintString tycon_str
]
int :: Int -> HsLit GhcTc
int n = HsIntPrim (SourceText $ show n) (toInteger n)
word64 :: DynFlags -> Word64 -> HsLit GhcTc
word64 dflags n
| wORD_SIZE dflags == 4 = HsWord64Prim NoSourceText (toInteger n)
| otherwise = HsWordPrim NoSourceText (toInteger n)
{-
Note [Representing TyCon kinds: KindRep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
One of the operations supported by Typeable is typeRepKind,
typeRepKind :: TypeRep (a :: k) -> TypeRep k
Implementing this is a bit tricky for poly-kinded types like
data Proxy (a :: k) :: Type
-- Proxy :: forall k. k -> Type
The TypeRep encoding of `Proxy Type Int` looks like this:
$tcProxy :: GHC.Types.TyCon
$trInt :: TypeRep Int
TrType :: TypeRep Type
$trProxyType :: TypeRep (Proxy Type :: Type -> Type)
$trProxyType = TrTyCon $tcProxy
[TrType] -- kind variable instantiation
(tyConKind $tcProxy [TrType]) -- The TypeRep of
-- Type -> Type
$trProxy :: TypeRep (Proxy Type Int)
$trProxy = TrApp $trProxyType $trInt TrType
$tkProxy :: GHC.Types.KindRep
$tkProxy = KindRepFun (KindRepVar 0)
(KindRepTyConApp (KindRepTYPE LiftedRep) [])
Note how $trProxyType cannot use 'TrApp', because TypeRep cannot represent
polymorphic types. So instead
* $trProxyType uses 'TrTyCon' to apply Proxy to (the representations)
of all its kind arguments. We can't represent a tycon that is
applied to only some of its kind arguments.
* In $tcProxy, the GHC.Types.TyCon structure for Proxy, we store a
GHC.Types.KindRep, which represents the polymorphic kind of Proxy
Proxy :: forall k. k->Type
* A KindRep is just a recipe that we can instantiate with the
argument kinds, using Data.Typeable.Internal.tyConKind and
store in the relevant 'TypeRep' constructor.
Data.Typeable.Internal.typeRepKind looks up the stored kinds.
* In a KindRep, the kind variables are represented by 0-indexed
de Bruijn numbers:
type KindBndr = Int -- de Bruijn index
data KindRep = KindRepTyConApp TyCon [KindRep]
| KindRepVar !KindBndr
| KindRepApp KindRep KindRep
| KindRepFun KindRep KindRep
...
-}
mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc
mkList ty = foldr consApp (nilExpr ty)
where
cons = consExpr ty
consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
consApp x xs = cons `nlHsApp` x `nlHsApp` xs
nilExpr :: Type -> LHsExpr GhcTc
nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon)
consExpr :: Type -> LHsExpr GhcTc
consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon)
|