875296ec78ddac65d7867ee63ee8a8f5a3b8d9e3
[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 ( 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 * Even KindReps aren't inlined this scheme still has more of an effect on
125 compilation time than I'd like. This is especially true in the case of
126 families of type constructors (e.g. tuples and unboxed sums). The problem is
127 particularly bad in the case of sums, since each arity-N tycon brings with it
128 N promoted datacons, each with a KindRep whose size also scales with N.
129 Consequently we currently simply don't allow sums to be Typeable.
130
131 In general we might consider moving some or all of this generation logic back
132 to the solver since the performance hit we take in doing this at
133 type-definition time is non-trivial and Typeable isn't very widely used. This
134 is discussed in #13261.
135
136 -}
137
138 -- | Generate the Typeable bindings for a module. This is the only
139 -- entry-point of this module and is invoked by the typechecker driver in
140 -- 'tcRnSrcDecls'.
141 --
142 -- See Note [Grand plan for Typeable] in TcTypeable.
143 mkTypeableBinds :: TcM TcGblEnv
144 mkTypeableBinds
145 = do { -- Create a binding for $trModule.
146 -- Do this before processing any data type declarations,
147 -- which need tcg_tr_module to be initialised
148 ; tcg_env <- mkModIdBindings
149 -- Now we can generate the TyCon representations...
150 -- First we handle the primitive TyCons if we are compiling GHC.Types
151 ; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos
152
153 -- Then we produce bindings for the user-defined types in this module.
154 ; setGblEnv tcg_env $
155 do { mod <- getModule
156 ; let tycons = filter needs_typeable_binds (tcg_tcs tcg_env)
157 mod_id = case tcg_tr_module tcg_env of -- Should be set by now
158 Just mod_id -> mod_id
159 Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons)
160 ; traceTc "mkTypeableBinds" (ppr tycons)
161 ; this_mod_todos <- todoForTyCons mod mod_id tycons
162 ; mkTypeRepTodoBinds (this_mod_todos : prim_todos)
163 } }
164 where
165 needs_typeable_binds tc
166 | tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon]
167 = False
168 | otherwise =
169 (not (isFamInstTyCon tc) && isAlgTyCon tc)
170 || isDataFamilyTyCon tc
171 || isClassTyCon tc
172
173
174 {- *********************************************************************
175 * *
176 Building top-level binding for $trModule
177 * *
178 ********************************************************************* -}
179
180 mkModIdBindings :: TcM TcGblEnv
181 mkModIdBindings
182 = do { mod <- getModule
183 ; loc <- getSrcSpanM
184 ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc
185 ; trModuleTyCon <- tcLookupTyCon trModuleTyConName
186 ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon [])
187 ; mod_bind <- mkVarBind mod_id <$> mkModIdRHS mod
188
189 ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
190 ; return (tcg_env { tcg_tr_module = Just mod_id }
191 `addTypecheckedBinds` [unitBag mod_bind]) }
192
193 mkModIdRHS :: Module -> TcM (LHsExpr Id)
194 mkModIdRHS mod
195 = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName
196 ; trNameLit <- mkTrNameLit
197 ; return $ nlHsDataCon trModuleDataCon
198 `nlHsApp` trNameLit (unitIdFS (moduleUnitId mod))
199 `nlHsApp` trNameLit (moduleNameFS (moduleName mod))
200 }
201
202 {- *********************************************************************
203 * *
204 Building type-representation bindings
205 * *
206 ********************************************************************* -}
207
208 -- | Information we need about a 'TyCon' to generate its representation.
209 data TypeableTyCon
210 = TypeableTyCon
211 { tycon :: !TyCon
212 , tycon_kind :: !Kind
213 , tycon_rep_id :: !Id
214 }
215
216 -- | A group of 'TyCon's in need of type-rep bindings.
217 data TypeRepTodo
218 = TypeRepTodo
219 { mod_rep_expr :: LHsExpr Id -- ^ Module's typerep binding
220 , pkg_fingerprint :: !Fingerprint -- ^ Package name fingerprint
221 , mod_fingerprint :: !Fingerprint -- ^ Module name fingerprint
222 , todo_tycons :: [TypeableTyCon]
223 -- ^ The 'TyCon's in need of bindings and their zonked kinds
224 }
225
226 todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo
227 todoForTyCons mod mod_id tycons = do
228 trTyConTyCon <- tcLookupTyCon trTyConTyConName
229 let mkRepId :: TyConRepName -> Id
230 mkRepId rep_name = mkExportedVanillaId rep_name (mkTyConTy trTyConTyCon)
231
232 tycons <- sequence
233 [ do kind <- zonkTcType $ tyConKind tc''
234 return TypeableTyCon { tycon = tc''
235 , tycon_kind = kind
236 , tycon_rep_id = mkRepId rep_name
237 }
238 | tc <- tycons
239 , tc' <- tc : tyConATs tc
240 -- If the tycon itself isn't typeable then we needn't look
241 -- at its promoted datacons as their kinds aren't Typeable
242 , Just _ <- pure $ tyConRepName_maybe tc'
243 -- We need type representations for any associated types
244 , let promoted = map promoteDataCon (tyConDataCons tc')
245 , tc'' <- tc' : promoted
246 , Just rep_name <- pure $ tyConRepName_maybe tc''
247 ]
248 let typeable_tycons = filter is_typeable tycons
249 is_typeable (TypeableTyCon {..}) =
250 --pprTrace "todoForTycons" (ppr tycon $$ ppr bare_kind $$ ppr is_typeable)
251 (typeIsTypeable bare_kind)
252 where bare_kind = dropForAlls tycon_kind
253 return TypeRepTodo { mod_rep_expr = nlHsVar mod_id
254 , pkg_fingerprint = pkg_fpr
255 , mod_fingerprint = mod_fpr
256 , todo_tycons = typeable_tycons
257 }
258 where
259 mod_fpr = fingerprintString $ moduleNameString $ moduleName mod
260 pkg_fpr = fingerprintString $ unitIdString $ moduleUnitId mod
261
262 -- | Generate TyCon bindings for a set of type constructors
263 mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv
264 mkTypeRepTodoBinds [] = getGblEnv
265 mkTypeRepTodoBinds todos
266 = do { stuff <- collect_stuff
267
268 -- First extend the type environment with all of the bindings which we
269 -- are going to produce since we may need to refer to them while
270 -- generating the kind representations of other types.
271 ; let tycon_rep_bndrs :: [Id]
272 tycon_rep_bndrs = [ tycon_rep_id
273 | todo <- todos
274 , TypeableTyCon {..} <- todo_tycons todo
275 ]
276 ; gbl_env <- tcExtendGlobalValEnv tycon_rep_bndrs getGblEnv
277
278 ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds Id]
279 mk_binds todo = mapM (mkTyConRepBinds stuff todo)
280 (todo_tycons todo)
281 ; (gbl_env, binds) <- setGblEnv gbl_env
282 $ runKindRepM (mapM mk_binds todos)
283 ; return $ gbl_env `addTypecheckedBinds` concat binds }
284
285 -- | Generate bindings for the type representation of a wired-in 'TyCon's
286 -- defined by the virtual "GHC.Prim" module. This is where we inject the
287 -- representation bindings for these primitive types into "GHC.Types"
288 --
289 -- See Note [Grand plan for Typeable] in this module.
290 mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo])
291 mkPrimTypeableTodos
292 = do { mod <- getModule
293 ; if mod == gHC_TYPES
294 then do { trModuleTyCon <- tcLookupTyCon trModuleTyConName
295 ; let ghc_prim_module_id =
296 mkExportedVanillaId trGhcPrimModuleName
297 (mkTyConTy trModuleTyCon)
298
299 ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id
300 <$> mkModIdRHS gHC_PRIM
301
302 ; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id]
303 getGblEnv
304 ; let gbl_env' = gbl_env `addTypecheckedBinds`
305 [unitBag ghc_prim_module_bind]
306 ; todo <- todoForTyCons gHC_PRIM ghc_prim_module_id
307 ghcPrimTypeableTyCons
308 ; return (gbl_env', [todo])
309 }
310 else do gbl_env <- getGblEnv
311 return (gbl_env, [])
312 }
313 where
314
315 -- | This is the list of primitive 'TyCon's for which we must generate bindings
316 -- in "GHC.Types". This should include all types defined in "GHC.Prim".
317 --
318 -- The majority of the types we need here are contained in 'primTyCons'.
319 -- However, not all of them: in particular unboxed tuples are absent since we
320 -- don't want to include them in the original name cache. See
321 -- Note [Built-in syntax and the OrigNameCache] in IfaceEnv for more.
322 ghcPrimTypeableTyCons :: [TyCon]
323 ghcPrimTypeableTyCons = concat
324 [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon
325 , funTyCon, tupleTyCon Unboxed 0]
326 , map (tupleTyCon Unboxed) [2..mAX_TUPLE_SIZE]
327 , map sumTyCon [2..mAX_SUM_SIZE]
328 , primTyCons
329 ]
330
331 data TypeableStuff
332 = Stuff { dflags :: DynFlags
333 , trTyConDataCon :: DataCon -- ^ of @TyCon@
334 , trNameLit :: FastString -> LHsExpr Id
335 -- ^ To construct @TrName@s
336 -- The various TyCon and DataCons of KindRep
337 , kindRepTyCon :: TyCon
338 , kindRepTyConAppDataCon :: DataCon
339 , kindRepVarDataCon :: DataCon
340 , kindRepAppDataCon :: DataCon
341 , kindRepFunDataCon :: DataCon
342 , kindRepTYPEDataCon :: DataCon
343 , kindRepTypeLitSDataCon :: DataCon
344 , typeLitSymbolDataCon :: DataCon
345 , typeLitNatDataCon :: DataCon
346 }
347
348 -- | Collect various tidbits which we'll need to generate TyCon representations.
349 collect_stuff :: TcM TypeableStuff
350 collect_stuff = do
351 dflags <- getDynFlags
352 trTyConDataCon <- tcLookupDataCon trTyConDataConName
353 kindRepTyCon <- tcLookupTyCon kindRepTyConName
354 kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName
355 kindRepVarDataCon <- tcLookupDataCon kindRepVarDataConName
356 kindRepAppDataCon <- tcLookupDataCon kindRepAppDataConName
357 kindRepFunDataCon <- tcLookupDataCon kindRepFunDataConName
358 kindRepTYPEDataCon <- tcLookupDataCon kindRepTYPEDataConName
359 kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName
360 typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName
361 typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName
362 trNameLit <- mkTrNameLit
363 return Stuff {..}
364
365 -- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we
366 -- can save the work of repeating lookups when constructing many TyCon
367 -- representations.
368 mkTrNameLit :: TcM (FastString -> LHsExpr Id)
369 mkTrNameLit = do
370 trNameSDataCon <- tcLookupDataCon trNameSDataConName
371 let trNameLit :: FastString -> LHsExpr Id
372 trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon
373 `nlHsApp` nlHsLit (mkHsStringPrimLit fs)
374 return trNameLit
375
376 -- | Make Typeable bindings for the given 'TyCon'.
377 mkTyConRepBinds :: TypeableStuff -> TypeRepTodo
378 -> TypeableTyCon -> KindRepM (LHsBinds Id)
379 mkTyConRepBinds stuff@(Stuff {..}) todo (TypeableTyCon {..})
380 = do -- Make a KindRep
381 let (bndrs, kind) = splitForAllTyVarBndrs tycon_kind
382 liftTc $ traceTc "mkTyConKindRepBinds"
383 (ppr tycon $$ ppr tycon_kind $$ ppr kind)
384 let ctx = mkDeBruijnContext (map binderVar bndrs)
385 kind_rep <- getKindRep stuff ctx kind
386
387 -- Make the TyCon binding
388 let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep
389 tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs
390 return $ unitBag tycon_rep_bind
391
392 -- | Here is where we define the set of Typeable types. These exclude type
393 -- families and polytypes.
394 tyConIsTypeable :: TyCon -> Bool
395 tyConIsTypeable tc =
396 isJust (tyConRepName_maybe tc)
397 && typeIsTypeable (dropForAlls $ tyConKind tc)
398 -- Ensure that the kind of the TyCon, with its initial foralls removed,
399 -- is representable (e.g. has no higher-rank polymorphism or type
400 -- synonyms).
401
402 -- | Is a particular 'Type' representable by @Typeable@? Here we look for
403 -- polytypes and types containing casts (which may be, for instance, a type
404 -- family).
405 typeIsTypeable :: Type -> Bool
406 -- We handle types of the form (TYPE rep) specifically to avoid
407 -- looping on (tyConIsTypeable RuntimeRep)
408 typeIsTypeable ty
409 | Just ty' <- coreView ty = typeIsTypeable ty'
410 typeIsTypeable ty
411 | Just _ <- isTYPEApp ty = True
412 typeIsTypeable (TyVarTy _) = True
413 typeIsTypeable (AppTy a b) = typeIsTypeable a && typeIsTypeable b
414 typeIsTypeable (FunTy a b) = typeIsTypeable a && typeIsTypeable b
415 typeIsTypeable (TyConApp tc args) = tyConIsTypeable tc
416 && all typeIsTypeable args
417 typeIsTypeable (ForAllTy{}) = False
418 typeIsTypeable (LitTy _) = True
419 typeIsTypeable (CastTy{}) = False
420 typeIsTypeable (CoercionTy{}) = panic "typeIsTypeable(Coercion)"
421
422 -- | Maps kinds to 'KindRep' bindings (or rather, a pair of the bound identifier
423 -- and its RHS).
424 type KindRepEnv = TypeMap (Id, LHsExpr Id)
425
426 -- | A monad within which we will generate 'KindRep's. Here we keep an
427 -- environments containing 'KindRep's which we've already generated so we can
428 -- re-use them opportunistically.
429 newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a }
430 deriving (Functor, Applicative, Monad)
431
432 liftTc :: TcRn a -> KindRepM a
433 liftTc = KindRepM . lift
434
435 -- | Run a 'KindRepM' and add the produced 'KindRep's to the typechecking
436 -- environment.
437 runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a)
438 runKindRepM (KindRepM action) = do
439 (res, reps_env) <- runStateT action emptyTypeMap
440 let reps = foldTypeMap (:) [] reps_env
441 tcg_env <- tcExtendGlobalValEnv (map fst reps) getGblEnv
442 let to_bind :: (Id, LHsExpr Id) -> LHsBind Id
443 to_bind = uncurry mkVarBind
444 tcg_env' = tcg_env `addTypecheckedBinds` map (unitBag . to_bind) reps
445 return (tcg_env', res)
446
447 -- | Produce or find a 'KindRep' for the given kind.
448 getKindRep :: TypeableStuff -> CmEnv -- ^ in-scope kind variables
449 -> Kind -- ^ the kind we want a 'KindRep' for
450 -> KindRepM (LHsExpr Id)
451 getKindRep (Stuff {..}) in_scope = go
452 where
453 go :: Kind -> KindRepM (LHsExpr Id)
454 go = KindRepM . StateT . go'
455
456 go' :: Kind -> KindRepEnv -> TcRn (LHsExpr Id, KindRepEnv)
457 go' k env
458 -- Look through type synonyms
459 | Just k' <- coreView k = go' k' env
460
461 -- We've already generated the needed KindRep
462 | Just (id, _) <- lookupTypeMapWithScope env in_scope k
463 = return (nlHsVar id, env)
464
465 -- We need to construct a new KindRep binding
466 | otherwise
467 = do -- Place a NOINLINE pragma on KindReps since they tend to be quite
468 -- large and bloat interface files.
469 rep_bndr <- (`setInlinePragma` neverInlinePragma)
470 <$> newSysLocalId (fsLit "$krep") (mkTyConTy kindRepTyCon)
471
472 -- do we need to tie a knot here?
473 (rhs, env') <- runStateT (unKindRepM $ new_kind_rep k) env
474 let env'' = extendTypeMapWithScope env' in_scope k (rep_bndr, rhs)
475 return (nlHsVar rep_bndr, env'')
476
477
478 new_kind_rep :: Kind -- ^ the kind we want a 'KindRep' for
479 -> KindRepM (LHsExpr Id)
480 new_kind_rep k
481 -- We handle TYPE separately to make it clear to consumers
482 -- (e.g. serializers) that there is a loop here (as
483 -- TYPE :: RuntimeRep -> TYPE 'LiftedRep)
484 | Just rr <- isTYPEApp k
485 = return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon rr
486
487 new_kind_rep (TyVarTy v)
488 | Just idx <- lookupCME in_scope v
489 = return $ nlHsDataCon kindRepVarDataCon
490 `nlHsApp` nlHsIntLit (fromIntegral idx)
491 | otherwise
492 = pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v)
493
494 new_kind_rep (AppTy t1 t2)
495 = do rep1 <- go t1
496 rep2 <- go t2
497 return $ nlHsDataCon kindRepAppDataCon
498 `nlHsApp` rep1 `nlHsApp` rep2
499
500 new_kind_rep k@(TyConApp tc tys)
501 | Just rep_name <- tyConRepName_maybe tc
502 = do rep_id <- liftTc $ lookupId rep_name
503 tys' <- mapM go tys
504 return $ nlHsDataCon kindRepTyConAppDataCon
505 `nlHsApp` nlHsVar rep_id
506 `nlHsApp` mkList (mkTyConTy kindRepTyCon) tys'
507 | otherwise
508 = pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k)
509
510 new_kind_rep (ForAllTy (TvBndr var _) ty)
511 = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty)
512
513 new_kind_rep (FunTy t1 t2)
514 = do rep1 <- go t1
515 rep2 <- go t2
516 return $ nlHsDataCon kindRepFunDataCon
517 `nlHsApp` rep1 `nlHsApp` rep2
518
519 new_kind_rep (LitTy (NumTyLit n))
520 = return $ nlHsDataCon kindRepTypeLitSDataCon
521 `nlHsApp` nlHsDataCon typeLitNatDataCon
522 `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n)
523
524 new_kind_rep (LitTy (StrTyLit s))
525 = return $ nlHsDataCon kindRepTypeLitSDataCon
526 `nlHsApp` nlHsDataCon typeLitSymbolDataCon
527 `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s)
528
529 new_kind_rep (CastTy ty co)
530 = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co)
531
532 new_kind_rep (CoercionTy co)
533 = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co)
534
535 -- | Produce the right-hand-side of a @TyCon@ representation.
536 mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo
537 -> TyCon -- ^ the 'TyCon' we are producing a binding for
538 -> LHsExpr Id -- ^ its 'KindRep'
539 -> LHsExpr Id
540 mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep
541 = nlHsDataCon trTyConDataCon
542 `nlHsApp` nlHsLit (word64 dflags high)
543 `nlHsApp` nlHsLit (word64 dflags low)
544 `nlHsApp` mod_rep_expr todo
545 `nlHsApp` trNameLit (mkFastString tycon_str)
546 `nlHsApp` nlHsLit (int n_kind_vars)
547 `nlHsApp` kind_rep
548 where
549 n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon)
550 tycon_str = add_tick (occNameString (getOccName tycon))
551 add_tick s | isPromotedDataCon tycon = '\'' : s
552 | otherwise = s
553
554 -- This must match the computation done in
555 -- Data.Typeable.Internal.mkTyConFingerprint.
556 Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo
557 , mod_fingerprint todo
558 , fingerprintString tycon_str
559 ]
560
561 int :: Int -> HsLit
562 int n = HsIntPrim (SourceText $ show n) (toInteger n)
563
564 word64 :: DynFlags -> Word64 -> HsLit
565 word64 dflags n
566 | wORD_SIZE dflags == 4 = HsWord64Prim NoSourceText (toInteger n)
567 | otherwise = HsWordPrim NoSourceText (toInteger n)
568
569 {-
570 Note [Representing TyCon kinds]
571 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
572
573 One of the operations supported by Typeable is typeRepKind,
574
575 typeRepKind :: TypeRep (a :: k) -> TypeRep k
576
577 Implementing this is a bit tricky. To see why let's consider the TypeRep
578 encoding of `Proxy Int` where
579
580 data Proxy (a :: k) :: Type
581
582 which looks like,
583
584 $tcProxy :: TyCon
585 $trInt :: TypeRep Int
586 $trType :: TypeRep Type
587
588 $trProxyType :: TypeRep (Proxy :: Type -> Type)
589 $trProxyType = TrTyCon $tcProxy
590 [$trType] -- kind variable instantiation
591
592 $trProxy :: TypeRep (Proxy Int)
593 $trProxy = TrApp $trProxyType $trInt
594
595 Note how $trProxyType encodes only the kind variables of the TyCon
596 instantiation. To compute the kind (Proxy Int) we need to have a recipe to
597 compute the kind of a concrete instantiation of Proxy. We call this recipe a
598 KindRep and store it in the TyCon produced for Proxy,
599
600 type KindBndr = Int -- de Bruijn index
601
602 data KindRep = KindRepTyConApp TyCon [KindRep]
603 | KindRepVar !KindBndr
604 | KindRepApp KindRep KindRep
605 | KindRepFun KindRep KindRep
606
607 The KindRep for Proxy would look like,
608
609 $tkProxy :: KindRep
610 $tkProxy = KindRepFun (KindRepVar 0) (KindRepTyConApp $trType [])
611
612
613 data Maybe a = Nothing | Just a
614
615 'Just :: a -> Maybe a
616
617 F :: forall k. k -> forall k'. k' -> Type
618 -}
619
620 mkList :: Type -> [LHsExpr Id] -> LHsExpr Id
621 mkList ty = foldr consApp (nilExpr ty)
622 where
623 cons = consExpr ty
624 consApp :: LHsExpr Id -> LHsExpr Id -> LHsExpr Id
625 consApp x xs = cons `nlHsApp` x `nlHsApp` xs
626
627 nilExpr :: Type -> LHsExpr Id
628 nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon)
629
630 consExpr :: Type -> LHsExpr Id
631 consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon)