34bd387a8d6fe785e5a90342d6fa82cac9721b92
[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
9 module TcTypeable(mkTypeableBinds) where
10
11
12 import BasicTypes ( SourceText(..), Boxity(..), neverInlinePragma )
13 import TcBinds( addTypecheckedBinds )
14 import IfaceEnv( newGlobalBinder )
15 import TyCoRep( Type(..), TyLit(..) )
16 import TcEnv
17 import TcEvidence ( mkWpTyApps )
18 import TcRnMonad
19 import TcMType ( zonkTcType )
20 import HscTypes ( lookupId )
21 import PrelNames
22 import TysPrim ( primTyCons )
23 import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon
24 , vecCountTyCon, vecElemTyCon
25 , nilDataCon, consDataCon )
26 import Id
27 import Type
28 import Kind ( isTYPEApp )
29 import TyCon
30 import DataCon
31 import Name ( Name, getOccName )
32 import OccName
33 import Module
34 import HsSyn
35 import DynFlags
36 import Bag
37 import Var ( TyVarBndr(..) )
38 import TrieMap
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] 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 (not (isFamInstTyCon tc) && 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 Id)
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.
213 data TypeableTyCon
214 = TypeableTyCon
215 { tycon :: !TyCon
216 , tycon_kind :: !Kind
217 , tycon_rep_id :: !Id
218 }
219
220 -- | A group of 'TyCon's in need of type-rep bindings.
221 data TypeRepTodo
222 = TypeRepTodo
223 { mod_rep_expr :: LHsExpr Id -- ^ Module's typerep binding
224 , pkg_fingerprint :: !Fingerprint -- ^ Package name fingerprint
225 , mod_fingerprint :: !Fingerprint -- ^ Module name fingerprint
226 , todo_tycons :: [TypeableTyCon]
227 -- ^ The 'TyCon's in need of bindings and their zonked kinds
228 }
229 | ExportedKindRepsTodo [(Kind, Id)]
230 -- ^ Build exported 'KindRep' bindings for the given set of kinds.
231
232 todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo
233 todoForTyCons mod mod_id tycons = do
234 trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName
235 let mkRepId :: TyConRepName -> Id
236 mkRepId rep_name = mkExportedVanillaId rep_name trTyConTy
237
238 tycons <- sequence
239 [ do kind <- zonkTcType $ tyConKind tc''
240 return TypeableTyCon { tycon = tc''
241 , tycon_kind = kind
242 , tycon_rep_id = mkRepId rep_name
243 }
244 | tc <- tycons
245 , tc' <- tc : tyConATs tc
246 -- If the tycon itself isn't typeable then we needn't look
247 -- at its promoted datacons as their kinds aren't Typeable
248 , Just _ <- pure $ tyConRepName_maybe tc'
249 -- We need type representations for any associated types
250 , let promoted = map promoteDataCon (tyConDataCons tc')
251 , tc'' <- tc' : promoted
252 , Just rep_name <- pure $ tyConRepName_maybe tc''
253 ]
254 let typeable_tycons = filter is_typeable tycons
255 is_typeable (TypeableTyCon {..}) =
256 --pprTrace "todoForTycons" (ppr tycon $$ ppr bare_kind $$ ppr is_typeable)
257 (typeIsTypeable bare_kind)
258 where bare_kind = dropForAlls tycon_kind
259 return TypeRepTodo { mod_rep_expr = nlHsVar mod_id
260 , pkg_fingerprint = pkg_fpr
261 , mod_fingerprint = mod_fpr
262 , todo_tycons = typeable_tycons
263 }
264 where
265 mod_fpr = fingerprintString $ moduleNameString $ moduleName mod
266 pkg_fpr = fingerprintString $ unitIdString $ moduleUnitId mod
267
268 todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo
269 todoForExportedKindReps kinds = do
270 trKindRepTy <- mkTyConTy <$> tcLookupTyCon kindRepTyConName
271 let mkId (k, name) = (k, mkExportedVanillaId name trKindRepTy)
272 return $ ExportedKindRepsTodo $ map mkId kinds
273
274 -- | Generate TyCon bindings for a set of type constructors
275 mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv
276 mkTypeRepTodoBinds [] = getGblEnv
277 mkTypeRepTodoBinds todos
278 = do { stuff <- collect_stuff
279
280 -- First extend the type environment with all of the bindings
281 -- which we are going to produce since we may need to refer to them
282 -- while generating the kind representations of other types.
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 Id]
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
349 , funTyCon, tupleTyCon Unboxed 0]
350 , map (tupleTyCon Unboxed) [2..mAX_TUPLE_SIZE]
351 , map sumTyCon [2..mAX_SUM_SIZE]
352 , primTyCons
353 ]
354
355 data TypeableStuff
356 = Stuff { dflags :: DynFlags
357 , trTyConDataCon :: DataCon -- ^ of @TyCon@
358 , trNameLit :: FastString -> LHsExpr Id
359 -- ^ To construct @TrName@s
360 -- The various TyCon and DataCons of KindRep
361 , kindRepTyCon :: TyCon
362 , kindRepTyConAppDataCon :: DataCon
363 , kindRepVarDataCon :: DataCon
364 , kindRepAppDataCon :: DataCon
365 , kindRepFunDataCon :: DataCon
366 , kindRepTYPEDataCon :: DataCon
367 , kindRepTypeLitSDataCon :: DataCon
368 , typeLitSymbolDataCon :: DataCon
369 , typeLitNatDataCon :: DataCon
370 }
371
372 -- | Collect various tidbits which we'll need to generate TyCon representations.
373 collect_stuff :: TcM TypeableStuff
374 collect_stuff = do
375 dflags <- getDynFlags
376 trTyConDataCon <- tcLookupDataCon trTyConDataConName
377 kindRepTyCon <- tcLookupTyCon kindRepTyConName
378 kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName
379 kindRepVarDataCon <- tcLookupDataCon kindRepVarDataConName
380 kindRepAppDataCon <- tcLookupDataCon kindRepAppDataConName
381 kindRepFunDataCon <- tcLookupDataCon kindRepFunDataConName
382 kindRepTYPEDataCon <- tcLookupDataCon kindRepTYPEDataConName
383 kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName
384 typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName
385 typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName
386 trNameLit <- mkTrNameLit
387 return Stuff {..}
388
389 -- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we
390 -- can save the work of repeating lookups when constructing many TyCon
391 -- representations.
392 mkTrNameLit :: TcM (FastString -> LHsExpr Id)
393 mkTrNameLit = do
394 trNameSDataCon <- tcLookupDataCon trNameSDataConName
395 let trNameLit :: FastString -> LHsExpr Id
396 trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon
397 `nlHsApp` nlHsLit (mkHsStringPrimLit fs)
398 return trNameLit
399
400 -- | Make Typeable bindings for the given 'TyCon'.
401 mkTyConRepBinds :: TypeableStuff -> TypeRepTodo
402 -> TypeableTyCon -> KindRepM (LHsBinds Id)
403 mkTyConRepBinds stuff@(Stuff {..}) todo (TypeableTyCon {..})
404 = do -- Make a KindRep
405 let (bndrs, kind) = splitForAllTyVarBndrs tycon_kind
406 liftTc $ traceTc "mkTyConKindRepBinds"
407 (ppr tycon $$ ppr tycon_kind $$ ppr kind)
408 let ctx = mkDeBruijnContext (map binderVar bndrs)
409 kind_rep <- getKindRep stuff ctx kind
410
411 -- Make the TyCon binding
412 let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep
413 tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs
414 return $ unitBag tycon_rep_bind
415
416 -- | Here is where we define the set of Typeable types. These exclude type
417 -- families and polytypes.
418 tyConIsTypeable :: TyCon -> Bool
419 tyConIsTypeable tc =
420 isJust (tyConRepName_maybe tc)
421 && typeIsTypeable (dropForAlls $ tyConKind tc)
422 -- Ensure that the kind of the TyCon, with its initial foralls removed,
423 -- is representable (e.g. has no higher-rank polymorphism or type
424 -- synonyms).
425
426 -- | Is a particular 'Type' representable by @Typeable@? Here we look for
427 -- polytypes and types containing casts (which may be, for instance, a type
428 -- family).
429 typeIsTypeable :: Type -> Bool
430 -- We handle types of the form (TYPE rep) specifically to avoid
431 -- looping on (tyConIsTypeable RuntimeRep)
432 typeIsTypeable ty
433 | Just ty' <- coreView ty = typeIsTypeable ty'
434 typeIsTypeable ty
435 | Just _ <- isTYPEApp ty = True
436 typeIsTypeable (TyVarTy _) = True
437 typeIsTypeable (AppTy a b) = typeIsTypeable a && typeIsTypeable b
438 typeIsTypeable (FunTy a b) = typeIsTypeable a && typeIsTypeable b
439 typeIsTypeable (TyConApp tc args) = tyConIsTypeable tc
440 && all typeIsTypeable args
441 typeIsTypeable (ForAllTy{}) = False
442 typeIsTypeable (LitTy _) = True
443 typeIsTypeable (CastTy{}) = False
444 typeIsTypeable (CoercionTy{}) = panic "typeIsTypeable(Coercion)"
445
446 -- | Maps kinds to 'KindRep' bindings. This binding may either be defined in
447 -- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing')
448 -- or a binding which we generated in the current module (in which case it will
449 -- be 'Just' the RHS of the binding).
450 type KindRepEnv = TypeMap (Id, Maybe (LHsExpr Id))
451
452 -- | A monad within which we will generate 'KindRep's. Here we keep an
453 -- environment containing 'KindRep's which we've already generated so we can
454 -- re-use them opportunistically.
455 newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a }
456 deriving (Functor, Applicative, Monad)
457
458 liftTc :: TcRn a -> KindRepM a
459 liftTc = KindRepM . lift
460
461 -- | We generate @KindRep@s for a few common kinds in @GHC.Types@ so that they
462 -- can be reused across modules.
463 builtInKindReps :: [(Kind, Name)]
464 builtInKindReps =
465 [ (star, starKindRepName)
466 , (mkFunTy star star, starArrStarKindRepName)
467 , (mkFunTys [star, star] star, starArrStarArrStarKindRepName)
468 ]
469 where
470 star = liftedTypeKind
471
472 initialKindRepEnv :: TcRn KindRepEnv
473 initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps
474 where
475 add_kind_rep acc (k,n) = do
476 id <- tcLookupId n
477 return $! extendTypeMap acc k (id, Nothing)
478
479 -- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's.
480 mkExportedKindReps :: TypeableStuff
481 -> [(Kind, Id)] -- ^ the kinds to generate bindings for
482 -> KindRepM ()
483 mkExportedKindReps stuff@(Stuff {..}) = mapM_ kindrep_binding
484 where
485 empty_scope = mkDeBruijnContext []
486
487 kindrep_binding :: (Kind, Id) -> KindRepM ()
488 kindrep_binding (kind, rep_bndr) = do
489 -- We build the binding manually here instead of using mkKindRepRhs
490 -- since the latter would find the built-in 'KindRep's in the
491 -- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv').
492 rhs <- mkKindRepRhs stuff empty_scope kind
493 addKindRepBind empty_scope kind rep_bndr rhs
494
495 addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr Id -> KindRepM ()
496 addKindRepBind in_scope k bndr rhs =
497 KindRepM $ modify' $
498 \env -> extendTypeMapWithScope env in_scope k (bndr, Just rhs)
499
500 -- | Run a 'KindRepM' and add the produced 'KindRep's to the typechecking
501 -- environment.
502 runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a)
503 runKindRepM (KindRepM action) = do
504 kindRepEnv <- initialKindRepEnv
505 (res, reps_env) <- runStateT action kindRepEnv
506 let rep_binds = foldTypeMap to_bind_pair [] reps_env
507 to_bind_pair (bndr, Just rhs) rest = (bndr, rhs) : rest
508 to_bind_pair (_, Nothing) rest = rest
509 tcg_env <- tcExtendGlobalValEnv (map fst rep_binds) getGblEnv
510 let binds = map (uncurry mkVarBind) rep_binds
511 tcg_env' = tcg_env `addTypecheckedBinds` [listToBag binds]
512 return (tcg_env', res)
513
514 -- | Produce or find a 'KindRep' for the given kind.
515 getKindRep :: TypeableStuff -> CmEnv -- ^ in-scope kind variables
516 -> Kind -- ^ the kind we want a 'KindRep' for
517 -> KindRepM (LHsExpr Id)
518 getKindRep stuff@(Stuff {..}) in_scope = go
519 where
520 go :: Kind -> KindRepM (LHsExpr Id)
521 go = KindRepM . StateT . go'
522
523 go' :: Kind -> KindRepEnv -> TcRn (LHsExpr Id, KindRepEnv)
524 go' k env
525 -- Look through type synonyms
526 | Just k' <- coreView k = go' k' env
527
528 -- We've already generated the needed KindRep
529 | Just (id, _) <- lookupTypeMapWithScope env in_scope k
530 = return (nlHsVar id, env)
531
532 -- We need to construct a new KindRep binding
533 | otherwise
534 = do -- Place a NOINLINE pragma on KindReps since they tend to be quite
535 -- large and bloat interface files.
536 rep_bndr <- (`setInlinePragma` neverInlinePragma)
537 <$> newSysLocalId (fsLit "$krep") (mkTyConTy kindRepTyCon)
538
539 -- do we need to tie a knot here?
540 flip runStateT env $ unKindRepM $ do
541 rhs <- mkKindRepRhs stuff in_scope k
542 addKindRepBind in_scope k rep_bndr rhs
543 return $ nlHsVar rep_bndr
544
545 -- | Construct the right-hand-side of the 'KindRep' for the given 'Kind' and
546 -- in-scope kind variable set.
547 mkKindRepRhs :: TypeableStuff
548 -> CmEnv -- ^ in-scope kind variables
549 -> Kind -- ^ the kind we want a 'KindRep' for
550 -> KindRepM (LHsExpr Id) -- ^ RHS expression
551 mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep
552 where
553 new_kind_rep k
554 -- We handle TYPE separately to make it clear to consumers
555 -- (e.g. serializers) that there is a loop here (as
556 -- TYPE :: RuntimeRep -> TYPE 'LiftedRep)
557 | Just rr <- isTYPEApp k
558 = return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon rr
559
560 new_kind_rep (TyVarTy v)
561 | Just idx <- lookupCME in_scope v
562 = return $ nlHsDataCon kindRepVarDataCon
563 `nlHsApp` nlHsIntLit (fromIntegral idx)
564 | otherwise
565 = pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v)
566
567 new_kind_rep (AppTy t1 t2)
568 = do rep1 <- getKindRep stuff in_scope t1
569 rep2 <- getKindRep stuff in_scope t2
570 return $ nlHsDataCon kindRepAppDataCon
571 `nlHsApp` rep1 `nlHsApp` rep2
572
573 new_kind_rep k@(TyConApp tc tys)
574 | Just rep_name <- tyConRepName_maybe tc
575 = do rep_id <- liftTc $ lookupId rep_name
576 tys' <- mapM (getKindRep stuff in_scope) tys
577 return $ nlHsDataCon kindRepTyConAppDataCon
578 `nlHsApp` nlHsVar rep_id
579 `nlHsApp` mkList (mkTyConTy kindRepTyCon) tys'
580 | otherwise
581 = pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k)
582
583 new_kind_rep (ForAllTy (TvBndr var _) ty)
584 = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty)
585
586 new_kind_rep (FunTy t1 t2)
587 = do rep1 <- getKindRep stuff in_scope t1
588 rep2 <- getKindRep stuff in_scope t2
589 return $ nlHsDataCon kindRepFunDataCon
590 `nlHsApp` rep1 `nlHsApp` rep2
591
592 new_kind_rep (LitTy (NumTyLit n))
593 = return $ nlHsDataCon kindRepTypeLitSDataCon
594 `nlHsApp` nlHsDataCon typeLitNatDataCon
595 `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n)
596
597 new_kind_rep (LitTy (StrTyLit s))
598 = return $ nlHsDataCon kindRepTypeLitSDataCon
599 `nlHsApp` nlHsDataCon typeLitSymbolDataCon
600 `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s)
601
602 new_kind_rep (CastTy ty co)
603 = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co)
604
605 new_kind_rep (CoercionTy co)
606 = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co)
607
608 -- | Produce the right-hand-side of a @TyCon@ representation.
609 mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo
610 -> TyCon -- ^ the 'TyCon' we are producing a binding for
611 -> LHsExpr Id -- ^ its 'KindRep'
612 -> LHsExpr Id
613 mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep
614 = nlHsDataCon trTyConDataCon
615 `nlHsApp` nlHsLit (word64 dflags high)
616 `nlHsApp` nlHsLit (word64 dflags low)
617 `nlHsApp` mod_rep_expr todo
618 `nlHsApp` trNameLit (mkFastString tycon_str)
619 `nlHsApp` nlHsLit (int n_kind_vars)
620 `nlHsApp` kind_rep
621 where
622 n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon)
623 tycon_str = add_tick (occNameString (getOccName tycon))
624 add_tick s | isPromotedDataCon tycon = '\'' : s
625 | otherwise = s
626
627 -- This must match the computation done in
628 -- Data.Typeable.Internal.mkTyConFingerprint.
629 Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo
630 , mod_fingerprint todo
631 , fingerprintString tycon_str
632 ]
633
634 int :: Int -> HsLit
635 int n = HsIntPrim (SourceText $ show n) (toInteger n)
636
637 word64 :: DynFlags -> Word64 -> HsLit
638 word64 dflags n
639 | wORD_SIZE dflags == 4 = HsWord64Prim NoSourceText (toInteger n)
640 | otherwise = HsWordPrim NoSourceText (toInteger n)
641
642 {-
643 Note [Representing TyCon kinds]
644 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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. To see why let's consider the TypeRep
651 encoding of `Proxy Int` where
652
653 data Proxy (a :: k) :: Type
654
655 which looks like,
656
657 $tcProxy :: TyCon
658 $trInt :: TypeRep Int
659 $trType :: TypeRep Type
660
661 $trProxyType :: TypeRep (Proxy :: Type -> Type)
662 $trProxyType = TrTyCon $tcProxy
663 [$trType] -- kind variable instantiation
664
665 $trProxy :: TypeRep (Proxy Int)
666 $trProxy = TrApp $trProxyType $trInt
667
668 Note how $trProxyType encodes only the kind variables of the TyCon
669 instantiation. To compute the kind (Proxy Int) we need to have a recipe to
670 compute the kind of a concrete instantiation of Proxy. We call this recipe a
671 KindRep and store it in the TyCon produced for Proxy,
672
673 type KindBndr = Int -- de Bruijn index
674
675 data KindRep = KindRepTyConApp TyCon [KindRep]
676 | KindRepVar !KindBndr
677 | KindRepApp KindRep KindRep
678 | KindRepFun KindRep KindRep
679
680 The KindRep for Proxy would look like,
681
682 $tkProxy :: KindRep
683 $tkProxy = KindRepFun (KindRepVar 0) (KindRepTyConApp $trType [])
684
685
686 data Maybe a = Nothing | Just a
687
688 'Just :: a -> Maybe a
689
690 F :: forall k. k -> forall k'. k' -> Type
691 -}
692
693 mkList :: Type -> [LHsExpr Id] -> LHsExpr Id
694 mkList ty = foldr consApp (nilExpr ty)
695 where
696 cons = consExpr ty
697 consApp :: LHsExpr Id -> LHsExpr Id -> LHsExpr Id
698 consApp x xs = cons `nlHsApp` x `nlHsApp` xs
699
700 nilExpr :: Type -> LHsExpr Id
701 nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon)
702
703 consExpr :: Type -> LHsExpr Id
704 consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon)