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