Fix solving of implicit parameter constraints
[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 )
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 TrieMap
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
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 GhcTc
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 GhcTc)
393 mkTrNameLit = do
394 trNameSDataCon <- tcLookupDataCon trNameSDataConName
395 let trNameLit :: FastString -> LHsExpr GhcTc
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 GhcTc)
403 mkTyConRepBinds stuff@(Stuff {..}) todo (TypeableTyCon {..})
404 = do -- Make a KindRep
405 let (bndrs, kind) = splitForAllTyVarBndrs (tyConKind tycon)
406 liftTc $ traceTc "mkTyConKindRepBinds"
407 (ppr tycon $$ ppr (tyConKind tycon) $$ 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{}) = False
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 GhcTc))
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 GhcTc -> 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 GhcTc)
518 getKindRep stuff@(Stuff {..}) in_scope = go
519 where
520 go :: Kind -> KindRepM (LHsExpr GhcTc)
521 go = KindRepM . StateT . go'
522
523 go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)
524 go' k env
525 -- Look through type synonyms
526 | Just k' <- tcView 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 GhcTc) -- ^ 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 GhcTc -- ^ its 'KindRep'
612 -> LHsExpr GhcTc
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 GhcTc
635 int n = HsIntPrim (sourceText $ show n) (toInteger n)
636
637 word64 :: DynFlags -> Word64 -> HsLit GhcTc
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: KindRep]
644 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
645 One of the operations supported by Typeable is typeRepKind,
646
647 typeRepKind :: TypeRep (a :: k) -> TypeRep k
648
649 Implementing this is a bit tricky for poly-kinded types like
650
651 data Proxy (a :: k) :: Type
652 -- Proxy :: forall k. k -> Type
653
654 The TypeRep encoding of `Proxy Type Int` looks like this:
655
656 $tcProxy :: GHC.Types.TyCon
657 $trInt :: TypeRep Int
658 $trType :: TypeRep Type
659
660 $trProxyType :: TypeRep (Proxy Type :: Type -> Type)
661 $trProxyType = TrTyCon $tcProxy
662 [$trType] -- kind variable instantiation
663
664 $trProxy :: TypeRep (Proxy Type Int)
665 $trProxy = TrApp $trProxyType $trInt
666
667 $tkProxy :: GHC.Types.KindRep
668 $tkProxy = KindRepFun (KindRepVar 0) (KindRepTyConApp $trType [])
669
670 Note how $trProxyType cannot use 'TrApp', because TypeRep cannot represent
671 polymorphic types. So instead
672
673 * $trProxyType uses 'TrTyCon' to apply Proxy to (the representations)
674 of all its kind arguments. We can't represent a tycon that is
675 applied to only some of its kind arguments.
676
677 * In $tcProxy, the GHC.Types.TyCon structure for Proxy, we store a
678 GHC.Types.KindRep, which represents the polymorphic kind of Proxy
679 Proxy :: forall k. k->Type
680
681 * A KindRep is just a recipe that we can instantiate with the
682 argument kinds, using Data.Typeable.Internal.instantiateKindRep.
683
684 Data.Typeable.Internal.typeRepKind uses instantiateKindRep
685
686 * In a KindRep, the kind variables are represented by 0-indexed
687 de Bruijn numbers:
688
689 type KindBndr = Int -- de Bruijn index
690
691 data KindRep = KindRepTyConApp TyCon [KindRep]
692 | KindRepVar !KindBndr
693 | KindRepApp KindRep KindRep
694 | KindRepFun KindRep KindRep
695 ...
696 -}
697
698 mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc
699 mkList ty = foldr consApp (nilExpr ty)
700 where
701 cons = consExpr ty
702 consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
703 consApp x xs = cons `nlHsApp` x `nlHsApp` xs
704
705 nilExpr :: Type -> LHsExpr GhcTc
706 nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon)
707
708 consExpr :: Type -> LHsExpr GhcTc
709 consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon)