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