Typeable: Rename KindRep bindings to $krep...
[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
8 module TcTypeable(mkTypeableBinds) where
9
10
11 import BasicTypes ( SourceText(..), Boxity(..), neverInlinePragma )
12 import TcBinds( addTypecheckedBinds )
13 import IfaceEnv( newGlobalBinder )
14 import TyCoRep( Type(..), TyLit(..) )
15 import TcEnv
16 import TcEvidence ( mkWpTyApps )
17 import TcRnMonad
18 import TcMType ( zonkTcType )
19 import HscTypes ( lookupId )
20 import PrelNames
21 import TysPrim ( primTyCons )
22 import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon
23 , vecCountTyCon, vecElemTyCon
24 , nilDataCon, consDataCon )
25 import Id
26 import Type
27 import Kind ( isTYPEApp )
28 import TyCon
29 import DataCon
30 import Name ( getOccName )
31 import OccName
32 import Module
33 import HsSyn
34 import DynFlags
35 import Bag
36 import Var ( TyVarBndr(..) )
37 import VarEnv
38 import Constants
39 import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints)
40 import Outputable
41 import FastString ( FastString, mkFastString, fsLit )
42
43 import Data.Maybe ( isJust )
44 import Data.Word( Word64 )
45
46 {- Note [Grand plan for Typeable]
47 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
48 The overall plan is this:
49
50 1. Generate a binding for each module p:M
51 (done in TcTypeable by mkModIdBindings)
52 M.$trModule :: GHC.Types.Module
53 M.$trModule = Module "p" "M"
54 ("tr" is short for "type representation"; see GHC.Types)
55
56 We might want to add the filename too.
57 This can be used for the lightweight stack-tracing stuff too
58
59 Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv
60
61 2. Generate a binding for every data type declaration T in module M,
62 M.$tcT :: GHC.Types.TyCon
63 M.$tcT = TyCon ...fingerprint info...
64 $trModule
65 "T"
66 0#
67 kind_rep
68
69 Here 0# is the number of arguments expected by the tycon to fully determine
70 its kind. kind_rep is a value of type GHC.Types.KindRep, which gives a
71 recipe for computing the kind of an instantiation of the tycon (see
72 Note [Representing TyCon kinds] later in this file for details).
73
74 We define (in TyCon)
75
76 type TyConRepName = Name
77
78 to use for these M.$tcT "tycon rep names". Note that these must be
79 treated as "never exported" names by Backpack (see
80 Note [Handling never-exported TyThings under Backpack]). Consequently
81 they get slightly special treatment in RnModIface.rnIfaceDecl.
82
83 3. Record the TyConRepName in T's TyCon, including for promoted
84 data and type constructors, and kinds like * and #.
85
86 The TyConRepName is not an "implicit Id". It's more like a record
87 selector: the TyCon knows its name but you have to go to the
88 interface file to find its type, value, etc
89
90 4. Solve Typeable constraints. This is done by a custom Typeable solver,
91 currently in TcInteract, that use M.$tcT so solve (Typeable T).
92
93 There are many wrinkles:
94
95 * The timing of when we produce this bindings is rather important: they must be
96 defined after the rest of the module has been typechecked since we need to be
97 able to lookup Module and TyCon in the type environment and we may be
98 currently compiling GHC.Types (where they are defined).
99
100 * GHC.Prim doesn't have any associated object code, so we need to put the
101 representations for types defined in this module elsewhere. We chose this
102 place to be GHC.Types. TcTypeable.mkPrimTypeableBinds is responsible for
103 injecting the bindings for the GHC.Prim representions when compiling
104 GHC.Types.
105
106 * TyCon.tyConRepModOcc is responsible for determining where to find
107 the representation binding for a given type. This is where we handle
108 the special case for GHC.Prim.
109
110 * To save space and reduce dependencies, we need use quite low-level
111 representations for TyCon and Module. See GHC.Types
112 Note [Runtime representation of modules and tycons]
113
114 * The KindReps can unfortunately get quite large. Moreover, the simplifier will
115 float out various pieces of them, resulting in numerous top-level bindings.
116 Consequently we mark the KindRep bindings as noinline, ensuring that the
117 float-outs don't make it into the interface file. This is important since
118 there is generally little benefit to inlining KindReps and they would
119 otherwise strongly affect compiler performance.
120
121 * Even KindReps aren't inlined this scheme still has more of an effect on
122 compilation time than I'd like. This is especially true in the case of
123 families of type constructors (e.g. tuples and unboxed sums). The problem is
124 particularly bad in the case of sums, since each arity-N tycon brings with it
125 N promoted datacons, each with a KindRep whose size also scales with N.
126 Consequently we currently simply don't allow sums to be Typeable.
127
128 In general we might consider moving some or all of this generation logic back
129 to the solver since the performance hit we take in doing this at
130 type-definition time is non-trivial and Typeable isn't very widely used. This
131 is discussed in #13261.
132
133 -}
134
135 -- | Generate the Typeable bindings for a module. This is the only
136 -- entry-point of this module and is invoked by the typechecker driver in
137 -- 'tcRnSrcDecls'.
138 --
139 -- See Note [Grand plan for Typeable] in TcTypeable.
140 mkTypeableBinds :: TcM TcGblEnv
141 mkTypeableBinds
142 = do { -- Create a binding for $trModule.
143 -- Do this before processing any data type declarations,
144 -- which need tcg_tr_module to be initialised
145 ; tcg_env <- mkModIdBindings
146 -- Now we can generate the TyCon representations...
147 -- First we handle the primitive TyCons if we are compiling GHC.Types
148 ; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos
149
150 -- Then we produce bindings for the user-defined types in this module.
151 ; setGblEnv tcg_env $
152 do { mod <- getModule
153 ; let tycons = filter needs_typeable_binds (tcg_tcs tcg_env)
154 mod_id = case tcg_tr_module tcg_env of -- Should be set by now
155 Just mod_id -> mod_id
156 Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons)
157 ; traceTc "mkTypeableBinds" (ppr tycons)
158 ; this_mod_todos <- todoForTyCons mod mod_id tycons
159 ; mkTypeableTyConBinds (this_mod_todos : prim_todos)
160 } }
161 where
162 needs_typeable_binds tc
163 | tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon]
164 = False
165 | otherwise =
166 (not (isFamInstTyCon tc) && isAlgTyCon tc)
167 || isDataFamilyTyCon tc
168 || isClassTyCon tc
169
170
171 {- *********************************************************************
172 * *
173 Building top-level binding for $trModule
174 * *
175 ********************************************************************* -}
176
177 mkModIdBindings :: TcM TcGblEnv
178 mkModIdBindings
179 = do { mod <- getModule
180 ; loc <- getSrcSpanM
181 ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc
182 ; trModuleTyCon <- tcLookupTyCon trModuleTyConName
183 ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon [])
184 ; mod_bind <- mkVarBind mod_id <$> mkModIdRHS mod
185
186 ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
187 ; return (tcg_env { tcg_tr_module = Just mod_id }
188 `addTypecheckedBinds` [unitBag mod_bind]) }
189
190 mkModIdRHS :: Module -> TcM (LHsExpr Id)
191 mkModIdRHS mod
192 = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName
193 ; trNameLit <- mkTrNameLit
194 ; return $ nlHsDataCon trModuleDataCon
195 `nlHsApp` trNameLit (unitIdFS (moduleUnitId mod))
196 `nlHsApp` trNameLit (moduleNameFS (moduleName mod))
197 }
198
199 {- *********************************************************************
200 * *
201 Building type-representation bindings
202 * *
203 ********************************************************************* -}
204
205 -- | Information we need about a 'TyCon' to generate its representation.
206 data TypeableTyCon
207 = TypeableTyCon
208 { tycon :: !TyCon
209 , tycon_kind :: !Kind
210 , tycon_rep_id :: !Id
211 }
212
213 -- | A group of 'TyCon's in need of type-rep bindings.
214 data TypeRepTodo
215 = TypeRepTodo
216 { mod_rep_expr :: LHsExpr Id -- ^ Module's typerep binding
217 , pkg_fingerprint :: !Fingerprint -- ^ Package name fingerprint
218 , mod_fingerprint :: !Fingerprint -- ^ Module name fingerprint
219 , todo_tycons :: [TypeableTyCon]
220 -- ^ The 'TyCon's in need of bindings and their zonked kinds
221 }
222
223 todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo
224 todoForTyCons mod mod_id tycons = do
225 trTyConTyCon <- tcLookupTyCon trTyConTyConName
226 let mkRepId :: TyConRepName -> Id
227 mkRepId rep_name = mkExportedVanillaId rep_name (mkTyConTy trTyConTyCon)
228
229 tycons <- sequence
230 [ do kind <- zonkTcType $ tyConKind tc''
231 return TypeableTyCon { tycon = tc''
232 , tycon_kind = kind
233 , tycon_rep_id = mkRepId rep_name
234 }
235 | tc <- tycons
236 , tc' <- tc : tyConATs tc
237 -- If the tycon itself isn't typeable then we needn't look
238 -- at its promoted datacons as their kinds aren't Typeable
239 , Just _ <- pure $ tyConRepName_maybe tc'
240 -- We need type representations for any associated types
241 , let promoted = map promoteDataCon (tyConDataCons tc')
242 , tc'' <- tc' : promoted
243 , Just rep_name <- pure $ tyConRepName_maybe tc''
244 ]
245 let typeable_tycons = filter is_typeable tycons
246 is_typeable (TypeableTyCon {..}) =
247 --pprTrace "todoForTycons" (ppr tycon $$ ppr bare_kind $$ ppr is_typeable)
248 (typeIsTypeable bare_kind)
249 where bare_kind = dropForAlls tycon_kind
250 return TypeRepTodo { mod_rep_expr = nlHsVar mod_id
251 , pkg_fingerprint = pkg_fpr
252 , mod_fingerprint = mod_fpr
253 , todo_tycons = typeable_tycons
254 }
255 where
256 mod_fpr = fingerprintString $ moduleNameString $ moduleName mod
257 pkg_fpr = fingerprintString $ unitIdString $ moduleUnitId mod
258
259 -- | Generate TyCon bindings for a set of type constructors
260 mkTypeableTyConBinds :: [TypeRepTodo] -> TcM TcGblEnv
261 mkTypeableTyConBinds [] = getGblEnv
262 mkTypeableTyConBinds todos
263 = do { stuff <- collect_stuff
264
265 -- First extend the type environment with all of the bindings which we
266 -- are going to produce since we may need to refer to them while
267 -- generating the kind representations of other types.
268 ; let tycon_rep_bndrs :: [Id]
269 tycon_rep_bndrs = [ tycon_rep_id
270 | todo <- todos
271 , TypeableTyCon {..} <- todo_tycons todo
272 ]
273 ; gbl_env <- tcExtendGlobalValEnv tycon_rep_bndrs getGblEnv
274
275 ; setGblEnv gbl_env $ foldlM (mk_typeable_binds stuff) gbl_env todos }
276
277 -- | Make bindings for the type representations of a 'TyCon' and its
278 -- promoted constructors.
279 mk_typeable_binds :: TypeableStuff -> TcGblEnv -> TypeRepTodo -> TcM TcGblEnv
280 mk_typeable_binds stuff gbl_env todo
281 = do pairs <- mapM (mkTyConRepBinds stuff todo) (todo_tycons todo)
282 gbl_env <- tcExtendGlobalValEnv (map fst pairs) (return gbl_env)
283 return $ gbl_env `addTypecheckedBinds` map snd pairs
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] getGblEnv
303 ; let gbl_env' = gbl_env `addTypecheckedBinds`
304 [unitBag ghc_prim_module_bind]
305 ; todo <- todoForTyCons gHC_PRIM ghc_prim_module_id
306 ghcPrimTypeableTyCons
307 ; return (gbl_env', [todo])
308 }
309 else do gbl_env <- getGblEnv
310 return (gbl_env, [])
311 }
312 where
313
314 -- | This is the list of primitive 'TyCon's for which we must generate bindings
315 -- in "GHC.Types". This should include all types defined in "GHC.Prim".
316 --
317 -- The majority of the types we need here are contained in 'primTyCons'.
318 -- However, not all of them: in particular unboxed tuples are absent since we
319 -- don't want to include them in the original name cache. See
320 -- Note [Built-in syntax and the OrigNameCache] in IfaceEnv for more.
321 ghcPrimTypeableTyCons :: [TyCon]
322 ghcPrimTypeableTyCons = concat
323 [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon
324 , funTyCon, tupleTyCon Unboxed 0]
325 , map (tupleTyCon Unboxed) [2..mAX_TUPLE_SIZE]
326 , map sumTyCon [2..mAX_SUM_SIZE]
327 , primTyCons
328 ]
329
330 data TypeableStuff
331 = Stuff { dflags :: DynFlags
332 , trTyConDataCon :: DataCon -- ^ of @TyCon@
333 , trNameLit :: FastString -> LHsExpr Id
334 -- ^ To construct @TrName@s
335 -- The various TyCon and DataCons of KindRep
336 , kindRepTyCon :: TyCon
337 , kindRepTyConAppDataCon :: DataCon
338 , kindRepVarDataCon :: DataCon
339 , kindRepAppDataCon :: DataCon
340 , kindRepFunDataCon :: DataCon
341 , kindRepTYPEDataCon :: DataCon
342 , kindRepTypeLitSDataCon :: DataCon
343 , typeLitSymbolDataCon :: DataCon
344 , typeLitNatDataCon :: DataCon
345 }
346
347 -- | Collect various tidbits which we'll need to generate TyCon representations.
348 collect_stuff :: TcM TypeableStuff
349 collect_stuff = do
350 dflags <- getDynFlags
351 trTyConDataCon <- tcLookupDataCon trTyConDataConName
352 kindRepTyCon <- tcLookupTyCon kindRepTyConName
353 kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName
354 kindRepVarDataCon <- tcLookupDataCon kindRepVarDataConName
355 kindRepAppDataCon <- tcLookupDataCon kindRepAppDataConName
356 kindRepFunDataCon <- tcLookupDataCon kindRepFunDataConName
357 kindRepTYPEDataCon <- tcLookupDataCon kindRepTYPEDataConName
358 kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName
359 typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName
360 typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName
361 trNameLit <- mkTrNameLit
362 return Stuff {..}
363
364 -- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we
365 -- can save the work of repeating lookups when constructing many TyCon
366 -- representations.
367 mkTrNameLit :: TcM (FastString -> LHsExpr Id)
368 mkTrNameLit = do
369 trNameSDataCon <- tcLookupDataCon trNameSDataConName
370 let trNameLit :: FastString -> LHsExpr Id
371 trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon
372 `nlHsApp` nlHsLit (mkHsStringPrimLit fs)
373 return trNameLit
374
375 -- | Make typeable bindings for the given 'TyCon'.
376 mkTyConRepBinds :: TypeableStuff -> TypeRepTodo
377 -> TypeableTyCon -> TcRn (Id, LHsBinds Id)
378 mkTyConRepBinds stuff@(Stuff {..}) todo (TypeableTyCon {..})
379 = do -- Place a NOINLINE pragma on KindReps since they tend to be quite large
380 -- and bloat interface files.
381 kind_rep_id <- (`setInlinePragma` neverInlinePragma)
382 <$> newSysLocalId (fsLit "$krep") (mkTyConTy kindRepTyCon)
383 kind_rep <- mkTyConKindRep stuff tycon tycon_kind
384
385 tycon_rep_rhs <- mkTyConRepTyConRHS stuff todo tycon kind_rep_id
386 let tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs
387 kind_rep_bind = mkVarBind kind_rep_id kind_rep
388 return (kind_rep_id, listToBag [tycon_rep_bind, kind_rep_bind])
389
390 -- | Here is where we define the set of Typeable types. These exclude type
391 -- families and polytypes.
392 tyConIsTypeable :: TyCon -> Bool
393 tyConIsTypeable tc =
394 isJust (tyConRepName_maybe tc)
395 && typeIsTypeable (dropForAlls $ tyConKind tc)
396 -- Ensure that the kind of the TyCon, with its initial foralls removed,
397 -- is representable (e.g. has no higher-rank polymorphism or type
398 -- synonyms).
399
400 -- | Is a particular 'Type' representable by @Typeable@? Here we look for
401 -- polytypes and types containing casts (which may be, for instance, a type
402 -- family).
403 typeIsTypeable :: Type -> Bool
404 -- We handle types of the form (TYPE rep) specifically to avoid
405 -- looping on (tyConIsTypeable RuntimeRep)
406 typeIsTypeable ty
407 | Just ty' <- coreView ty = typeIsTypeable ty'
408 typeIsTypeable ty
409 | Just _ <- isTYPEApp ty = True
410 typeIsTypeable (TyVarTy _) = True
411 typeIsTypeable (AppTy a b) = typeIsTypeable a && typeIsTypeable b
412 typeIsTypeable (FunTy a b) = typeIsTypeable a && typeIsTypeable b
413 typeIsTypeable (TyConApp tc args) = tyConIsTypeable tc
414 && all typeIsTypeable args
415 typeIsTypeable (ForAllTy{}) = False
416 typeIsTypeable (LitTy _) = True
417 typeIsTypeable (CastTy{}) = False
418 typeIsTypeable (CoercionTy{}) = panic "typeIsTypeable(Coercion)"
419
420 -- | Produce the right-hand-side of a @TyCon@ representation.
421 mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo
422 -> TyCon -> Id
423 -> TcRn (LHsExpr Id)
424 mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep_id
425 = do let rep_rhs = nlHsDataCon trTyConDataCon
426 `nlHsApp` nlHsLit (word64 dflags high)
427 `nlHsApp` nlHsLit (word64 dflags low)
428 `nlHsApp` mod_rep_expr todo
429 `nlHsApp` trNameLit (mkFastString tycon_str)
430 `nlHsApp` nlHsLit (int n_kind_vars)
431 `nlHsApp` nlHsVar kind_rep_id
432 return rep_rhs
433 where
434 n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon)
435 tycon_str = add_tick (occNameString (getOccName tycon))
436 add_tick s | isPromotedDataCon tycon = '\'' : s
437 | otherwise = s
438
439 -- This must match the computation done in
440 -- Data.Typeable.Internal.mkTyConFingerprint.
441 Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo
442 , mod_fingerprint todo
443 , fingerprintString tycon_str
444 ]
445
446 int :: Int -> HsLit
447 int n = HsIntPrim (SourceText $ show n) (toInteger n)
448
449 word64 :: DynFlags -> Word64 -> HsLit
450 word64 dflags n
451 | wORD_SIZE dflags == 4 = HsWord64Prim NoSourceText (toInteger n)
452 | otherwise = HsWordPrim NoSourceText (toInteger n)
453
454 {-
455 Note [Representing TyCon kinds]
456 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
457
458 One of the operations supported by Typeable is typeRepKind,
459
460 typeRepKind :: TypeRep (a :: k) -> TypeRep k
461
462 Implementing this is a bit tricky. To see why let's consider the TypeRep
463 encoding of `Proxy Int` where
464
465 data Proxy (a :: k) :: Type
466
467 which looks like,
468
469 $tcProxy :: TyCon
470 $trInt :: TypeRep Int
471 $trType :: TypeRep Type
472
473 $trProxyType :: TypeRep (Proxy :: Type -> Type)
474 $trProxyType = TrTyCon $tcProxy
475 [$trType] -- kind variable instantiation
476
477 $trProxy :: TypeRep (Proxy Int)
478 $trProxy = TrApp $trProxyType $trInt
479
480 Note how $trProxyType encodes only the kind variables of the TyCon
481 instantiation. To compute the kind (Proxy Int) we need to have a recipe to
482 compute the kind of a concrete instantiation of Proxy. We call this recipe a
483 KindRep and store it in the TyCon produced for Proxy,
484
485 type KindBndr = Int -- de Bruijn index
486
487 data KindRep = KindRepTyConApp TyCon [KindRep]
488 | KindRepVar !KindBndr
489 | KindRepApp KindRep KindRep
490 | KindRepFun KindRep KindRep
491
492 The KindRep for Proxy would look like,
493
494 $tkProxy :: KindRep
495 $tkProxy = KindRepFun (KindRepVar 0) (KindRepTyConApp $trType [])
496
497
498 data Maybe a = Nothing | Just a
499
500 'Just :: a -> Maybe a
501
502 F :: forall k. k -> forall k'. k' -> Type
503 -}
504
505 -- | Produce a @KindRep@ expression for the kind of the given 'TyCon'.
506 mkTyConKindRep :: TypeableStuff -> TyCon -> Kind -> TcRn (LHsExpr Id)
507 mkTyConKindRep (Stuff {..}) tycon tycon_kind = do
508 let (bndrs, kind) = splitForAllTyVarBndrs tycon_kind
509 bndr_idxs = mkVarEnv $ (`zip` [0..]) $ map binderVar bndrs
510 traceTc "mkTyConKindRepBinds"
511 (ppr tycon $$ ppr tycon_kind $$ ppr kind $$ ppr bndr_idxs)
512 go bndr_idxs kind
513 where
514 -- Compute RHS
515 go :: VarEnv Int -> Kind -> TcRn (LHsExpr Id)
516 go bndrs ty
517 | Just ty' <- coreView ty
518 = go bndrs ty'
519 go bndrs (TyVarTy v)
520 | Just idx <- lookupVarEnv bndrs v
521 = return $ nlHsDataCon kindRepVarDataCon
522 `nlHsApp` nlHsIntLit (fromIntegral idx)
523 | otherwise
524 = pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v $$ ppr bndrs)
525 go bndrs (AppTy t1 t2)
526 = do t1' <- go bndrs t1
527 t2' <- go bndrs t2
528 return $ nlHsDataCon kindRepAppDataCon
529 `nlHsApp` t1' `nlHsApp` t2'
530 go _ ty | Just rr <- isTYPEApp ty
531 = return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon rr
532 go bndrs (TyConApp tc tys)
533 | Just rep_name <- tyConRepName_maybe tc
534 = do rep_id <- lookupId rep_name
535 tys' <- mapM (go bndrs) tys
536 return $ nlHsDataCon kindRepTyConAppDataCon
537 `nlHsApp` nlHsVar rep_id
538 `nlHsApp` mkList (mkTyConTy kindRepTyCon) tys'
539 | otherwise
540 = pprPanic "mkTyConKindRepBinds(TyConApp)"
541 (ppr tc $$ ppr tycon_kind)
542 go _ (ForAllTy (TvBndr var _) ty)
543 -- = let bndrs' = extendVarEnv (mapVarEnv (+1) bndrs) var 0 in go bndrs' ty
544 = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty)
545 go bndrs (FunTy t1 t2)
546 = do t1' <- go bndrs t1
547 t2' <- go bndrs t2
548 return $ nlHsDataCon kindRepFunDataCon
549 `nlHsApp` t1' `nlHsApp` t2'
550 go _ (LitTy (NumTyLit n))
551 = return $ nlHsDataCon kindRepTypeLitSDataCon
552 `nlHsApp` nlHsDataCon typeLitNatDataCon
553 `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n)
554 go _ (LitTy (StrTyLit s))
555 = return $ nlHsDataCon kindRepTypeLitSDataCon
556 `nlHsApp` nlHsDataCon typeLitSymbolDataCon
557 `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s)
558 go _ (CastTy ty co)
559 = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co)
560 go _ (CoercionTy co)
561 = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co)
562
563 mkList :: Type -> [LHsExpr Id] -> LHsExpr Id
564 mkList ty = foldr consApp (nilExpr ty)
565 where
566 cons = consExpr ty
567 consApp :: LHsExpr Id -> LHsExpr Id -> LHsExpr Id
568 consApp x xs = cons `nlHsApp` x `nlHsApp` xs
569
570 nilExpr :: Type -> LHsExpr Id
571 nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon)
572
573 consExpr :: Type -> LHsExpr Id
574 consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon)