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