2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker}
6 This module is an extension of @HsSyn@ syntax, for use in the type
11 TcMonoBinds, TcHsBinds, TcPat,
12 TcExpr, TcGRHSs, TcGRHS, TcMatch,
13 TcStmt, TcArithSeqInfo, TcRecordBinds,
14 TcHsModule, TcCoreExpr, TcDictBinds,
17 TypecheckedHsBinds, TypecheckedRuleDecl,
18 TypecheckedMonoBinds, TypecheckedPat,
19 TypecheckedHsExpr, TypecheckedArithSeqInfo,
20 TypecheckedStmt, TypecheckedForeignDecl,
21 TypecheckedMatch, TypecheckedHsModule,
22 TypecheckedGRHSs, TypecheckedGRHS,
23 TypecheckedRecordBinds, TypecheckedDictBinds,
25 mkHsTyApp, mkHsDictApp, mkHsConApp,
26 mkHsTyLam, mkHsDictLam, mkHsLet,
28 -- re-exported from TcEnv
31 zonkTopBinds, zonkId, zonkIdOcc, zonkExpr,
32 zonkForeignExports, zonkRules
35 #include "HsVersions.h"
38 import HsSyn -- oodles of it
41 import Id ( idName, idType, isLocalId, setIdType, isIP, Id )
42 import DataCon ( dataConWrapId )
43 import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv,
48 import TcType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars
50 import CoreSyn ( Expr )
51 import BasicTypes ( RecFlag(..) )
54 import HscTypes ( TyThing(..) )
61 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
62 All the types in @Tc...@ things have mutable type-variables in them for
65 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
66 which have immutable type variables in them.
69 type TcHsBinds = HsBinds TcId TcPat
70 type TcMonoBinds = MonoBinds TcId TcPat
71 type TcDictBinds = TcMonoBinds
72 type TcPat = OutPat TcId
73 type TcExpr = HsExpr TcId TcPat
74 type TcGRHSs = GRHSs TcId TcPat
75 type TcGRHS = GRHS TcId TcPat
76 type TcMatch = Match TcId TcPat
77 type TcStmt = Stmt TcId TcPat
78 type TcArithSeqInfo = ArithSeqInfo TcId TcPat
79 type TcRecordBinds = HsRecordBinds TcId TcPat
80 type TcHsModule = HsModule TcId TcPat
82 type TcCoreExpr = Expr TcId
83 type TcForeignExportDecl = ForeignDecl TcId
84 type TcRuleDecl = RuleDecl TcId TcPat
86 type TypecheckedPat = OutPat Id
87 type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
88 type TypecheckedDictBinds = TypecheckedMonoBinds
89 type TypecheckedHsBinds = HsBinds Id TypecheckedPat
90 type TypecheckedHsExpr = HsExpr Id TypecheckedPat
91 type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat
92 type TypecheckedStmt = Stmt Id TypecheckedPat
93 type TypecheckedMatch = Match Id TypecheckedPat
94 type TypecheckedGRHSs = GRHSs Id TypecheckedPat
95 type TypecheckedGRHS = GRHS Id TypecheckedPat
96 type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
97 type TypecheckedHsModule = HsModule Id TypecheckedPat
98 type TypecheckedForeignDecl = ForeignDecl Id
99 type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
103 mkHsTyApp expr [] = expr
104 mkHsTyApp expr tys = TyApp expr tys
106 mkHsDictApp expr [] = expr
107 mkHsDictApp expr dict_vars = DictApp expr dict_vars
109 mkHsTyLam [] expr = expr
110 mkHsTyLam tyvars expr = TyLam tyvars expr
112 mkHsDictLam [] expr = expr
113 mkHsDictLam dicts expr = DictLam dicts expr
115 mkHsLet EmptyMonoBinds expr = expr
116 mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
118 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
121 %************************************************************************
123 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
125 %************************************************************************
127 This zonking pass runs over the bindings
129 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
130 b) convert unbound TcTyVar to Void
131 c) convert each TcId to an Id by zonking its type
133 The type variables are converted by binding mutable tyvars to immutable ones
134 and then zonking as normal.
136 The Ids are converted by binding them in the normal Tc envt; that
137 way we maintain sharing; eg an Id is zonked at its binding site and they
138 all occurrences of that Id point to the common zonked copy
140 It's all pretty boring stuff, because HsSyn is such a large type, and
141 the environment manipulation is tiresome.
144 -- zonkId is used *during* typechecking just to zonk the Id's type
145 zonkId :: TcId -> NF_TcM TcId
147 = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
148 returnNF_Tc (setIdType id ty')
150 -- zonkIdBndr is used *after* typechecking to get the Id's type
151 -- to its final form. The TyVarEnv give
152 zonkIdBndr :: TcId -> NF_TcM Id
154 = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' ->
155 returnNF_Tc (setIdType id ty')
157 zonkIdOcc :: TcId -> NF_TcM Id
159 | not (isLocalId id) || isIP id
160 -- We're avoiding looking up superclass selectors
161 -- and constructors; zonking them is a no-op anyway, and the
162 -- superclass selectors aren't in the environment anyway.
165 = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' ->
167 new_id = case maybe_id' of
168 Just (AnId id') -> id'
169 other -> pprTrace "zonkIdOcc:" (ppr id) id
176 zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
177 zonkTopBinds binds -- Top level is implicitly recursive
178 = fixNF_Tc (\ ~(_, new_ids) ->
179 tcExtendGlobalValEnv (bagToList new_ids) $
180 zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
181 tcGetEnv `thenNF_Tc` \ env ->
182 returnNF_Tc ((binds', env), new_ids)
183 ) `thenNF_Tc` \ (stuff, _) ->
186 zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
189 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
190 returnNF_Tc (binds', env))
193 -- -> (TypecheckedHsBinds
194 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
196 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
198 go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
200 thing_inside (b1' `ThenBinds` b2')
202 go EmptyBinds thing_inside = thing_inside EmptyBinds
204 go (MonoBind bind sigs is_rec) thing_inside
205 = ASSERT( null sigs )
206 fixNF_Tc (\ ~(_, new_ids) ->
207 tcExtendGlobalValEnv (bagToList new_ids) $
208 zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
209 thing_inside (mkMonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
210 returnNF_Tc (stuff, new_ids)
211 ) `thenNF_Tc` \ (stuff, _) ->
216 -------------------------------------------------------------------------
217 zonkMonoBinds :: TcMonoBinds
218 -> NF_TcM (TypecheckedMonoBinds, Bag Id)
220 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
222 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
223 = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
224 zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
225 returnNF_Tc (b1' `AndMonoBinds` b2',
226 ids1 `unionBags` ids2)
228 zonkMonoBinds (PatMonoBind pat grhss locn)
229 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
230 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
231 returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
233 zonkMonoBinds (VarMonoBind var expr)
234 = zonkIdBndr var `thenNF_Tc` \ new_var ->
235 zonkExpr expr `thenNF_Tc` \ new_expr ->
236 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
238 zonkMonoBinds (CoreMonoBind var core_expr)
239 = zonkIdBndr var `thenNF_Tc` \ new_var ->
240 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
242 zonkMonoBinds (FunMonoBind var inf ms locn)
243 = zonkIdBndr var `thenNF_Tc` \ new_var ->
244 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
245 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
248 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
249 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
250 -- No need to extend tyvar env: the effects are
251 -- propagated through binding the tyvars themselves
253 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
254 tcExtendGlobalValEnv new_dicts $
256 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
257 tcExtendGlobalValEnv (bagToList val_bind_ids) $
258 zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
259 mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports ->
260 returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
261 ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
263 new_globals = listToBag [global | (_, global, local) <- new_exports]
265 returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
268 zonkExport (tyvars, global, local)
269 = zonkTcSigTyVars tyvars `thenNF_Tc` \ new_tyvars ->
270 -- This isn't the binding occurrence of these tyvars
271 -- but they should *be* tyvars. Hence zonkTcSigTyVars.
272 zonkIdBndr global `thenNF_Tc` \ new_global ->
273 zonkIdOcc local `thenNF_Tc` \ new_local ->
274 returnNF_Tc (new_tyvars, new_global, new_local)
277 %************************************************************************
279 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
281 %************************************************************************
284 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
286 zonkMatch (Match _ pats _ grhss)
287 = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
288 tcExtendGlobalValEnv (bagToList new_ids) $
289 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
290 returnNF_Tc (Match [] new_pats Nothing new_grhss)
292 -------------------------------------------------------------------------
294 -> NF_TcM TypecheckedGRHSs
296 zonkGRHSs (GRHSs grhss binds (Just ty))
297 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
300 zonk_grhs (GRHS guarded locn)
301 = zonkStmts guarded `thenNF_Tc` \ new_guarded ->
302 returnNF_Tc (GRHS new_guarded locn)
304 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
305 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
306 returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
309 %************************************************************************
311 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
313 %************************************************************************
316 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
319 = zonkIdOcc id `thenNF_Tc` \ id' ->
320 returnNF_Tc (HsVar id')
322 zonkExpr (HsIPVar id)
323 = zonkIdOcc id `thenNF_Tc` \ id' ->
324 returnNF_Tc (HsIPVar id')
326 zonkExpr (HsLit (HsRat f ty))
327 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
328 returnNF_Tc (HsLit (HsRat f new_ty))
330 zonkExpr (HsLit (HsLitLit lit ty))
331 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
332 returnNF_Tc (HsLit (HsLitLit lit new_ty))
335 = returnNF_Tc (HsLit lit)
337 -- HsOverLit doesn't appear in typechecker output
339 zonkExpr (HsLam match)
340 = zonkMatch match `thenNF_Tc` \ new_match ->
341 returnNF_Tc (HsLam new_match)
343 zonkExpr (HsApp e1 e2)
344 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
345 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
346 returnNF_Tc (HsApp new_e1 new_e2)
348 zonkExpr (OpApp e1 op fixity e2)
349 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
350 zonkExpr op `thenNF_Tc` \ new_op ->
351 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
352 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
354 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
355 zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
357 zonkExpr (SectionL expr op)
358 = zonkExpr expr `thenNF_Tc` \ new_expr ->
359 zonkExpr op `thenNF_Tc` \ new_op ->
360 returnNF_Tc (SectionL new_expr new_op)
362 zonkExpr (SectionR op expr)
363 = zonkExpr op `thenNF_Tc` \ new_op ->
364 zonkExpr expr `thenNF_Tc` \ new_expr ->
365 returnNF_Tc (SectionR new_op new_expr)
367 zonkExpr (HsCase expr ms src_loc)
368 = zonkExpr expr `thenNF_Tc` \ new_expr ->
369 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
370 returnNF_Tc (HsCase new_expr new_ms src_loc)
372 zonkExpr (HsIf e1 e2 e3 src_loc)
373 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
374 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
375 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
376 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
378 zonkExpr (HsLet binds expr)
379 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
381 zonkExpr expr `thenNF_Tc` \ new_expr ->
382 returnNF_Tc (HsLet new_binds new_expr)
384 zonkExpr (HsWith expr binds)
385 = zonkIPBinds binds `thenNF_Tc` \ new_binds ->
386 tcExtendGlobalValEnv (map fst new_binds) $
387 zonkExpr expr `thenNF_Tc` \ new_expr ->
388 returnNF_Tc (HsWith new_expr new_binds)
390 zonkIPBinds = mapNF_Tc zonkIPBind
392 zonkIdBndr n `thenNF_Tc` \ n' ->
393 zonkExpr e `thenNF_Tc` \ e' ->
396 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
398 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
399 = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
400 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
401 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
402 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
403 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
404 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
407 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
409 zonkExpr (ExplicitListOut ty exprs)
410 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
411 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
412 returnNF_Tc (ExplicitListOut new_ty new_exprs)
414 zonkExpr (ExplicitTuple exprs boxed)
415 = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
416 returnNF_Tc (ExplicitTuple new_exprs boxed)
418 zonkExpr (RecordConOut data_con con_expr rbinds)
419 = zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
420 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
421 returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
423 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
425 zonkExpr (RecordUpdOut expr ty dicts rbinds)
426 = zonkExpr expr `thenNF_Tc` \ new_expr ->
427 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
428 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
429 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
430 returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
432 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
433 zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
435 zonkExpr (ArithSeqOut expr info)
436 = zonkExpr expr `thenNF_Tc` \ new_expr ->
437 zonkArithSeq info `thenNF_Tc` \ new_info ->
438 returnNF_Tc (ArithSeqOut new_expr new_info)
440 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
441 = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
442 zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
443 returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
445 zonkExpr (HsSCC lbl expr)
446 = zonkExpr expr `thenNF_Tc` \ new_expr ->
447 returnNF_Tc (HsSCC lbl new_expr)
449 zonkExpr (TyLam tyvars expr)
450 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
451 -- No need to extend tyvar env; see AbsBinds
453 zonkExpr expr `thenNF_Tc` \ new_expr ->
454 returnNF_Tc (TyLam new_tyvars new_expr)
456 zonkExpr (TyApp expr tys)
457 = zonkExpr expr `thenNF_Tc` \ new_expr ->
458 mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
459 returnNF_Tc (TyApp new_expr new_tys)
461 zonkExpr (DictLam dicts expr)
462 = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
463 tcExtendGlobalValEnv new_dicts $
464 zonkExpr expr `thenNF_Tc` \ new_expr ->
465 returnNF_Tc (DictLam new_dicts new_expr)
467 zonkExpr (DictApp expr dicts)
468 = zonkExpr expr `thenNF_Tc` \ new_expr ->
469 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
470 returnNF_Tc (DictApp new_expr new_dicts)
474 -------------------------------------------------------------------------
475 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
477 zonkArithSeq (From e)
478 = zonkExpr e `thenNF_Tc` \ new_e ->
479 returnNF_Tc (From new_e)
481 zonkArithSeq (FromThen e1 e2)
482 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
483 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
484 returnNF_Tc (FromThen new_e1 new_e2)
486 zonkArithSeq (FromTo e1 e2)
487 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
488 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
489 returnNF_Tc (FromTo new_e1 new_e2)
491 zonkArithSeq (FromThenTo e1 e2 e3)
492 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
493 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
494 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
495 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
497 -------------------------------------------------------------------------
498 zonkStmts :: [TcStmt]
499 -> NF_TcM [TypecheckedStmt]
501 zonkStmts [] = returnNF_Tc []
503 zonkStmts (ParStmtOut bndrstmtss : stmts)
504 = mapNF_Tc (mapNF_Tc zonkId) bndrss `thenNF_Tc` \ new_bndrss ->
505 let new_binders = concat new_bndrss in
506 mapNF_Tc zonkStmts stmtss `thenNF_Tc` \ new_stmtss ->
507 tcExtendGlobalValEnv new_binders $
508 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
509 returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
510 where (bndrss, stmtss) = unzip bndrstmtss
512 zonkStmts [ReturnStmt expr]
513 = zonkExpr expr `thenNF_Tc` \ new_expr ->
514 returnNF_Tc [ReturnStmt new_expr]
516 zonkStmts (ExprStmt expr locn : stmts)
517 = zonkExpr expr `thenNF_Tc` \ new_expr ->
518 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
519 returnNF_Tc (ExprStmt new_expr locn : new_stmts)
521 zonkStmts (GuardStmt expr locn : stmts)
522 = zonkExpr expr `thenNF_Tc` \ new_expr ->
523 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
524 returnNF_Tc (GuardStmt new_expr locn : new_stmts)
526 zonkStmts (LetStmt binds : stmts)
527 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
529 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
530 returnNF_Tc (LetStmt new_binds : new_stmts)
532 zonkStmts (BindStmt pat expr locn : stmts)
533 = zonkExpr expr `thenNF_Tc` \ new_expr ->
534 zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) ->
535 tcExtendGlobalValEnv (bagToList new_ids) $
536 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
537 returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
541 -------------------------------------------------------------------------
542 zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
545 = mapNF_Tc zonk_rbind rbinds
547 zonk_rbind (field, expr, pun)
548 = zonkExpr expr `thenNF_Tc` \ new_expr ->
549 zonkIdOcc field `thenNF_Tc` \ new_field ->
550 returnNF_Tc (new_field, new_expr, pun)
553 %************************************************************************
555 \subsection[BackSubst-Pats]{Patterns}
557 %************************************************************************
560 zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
563 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
564 returnNF_Tc (WildPat new_ty, emptyBag)
567 = zonkIdBndr v `thenNF_Tc` \ new_v ->
568 returnNF_Tc (VarPat new_v, unitBag new_v)
570 zonkPat (LazyPat pat)
571 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
572 returnNF_Tc (LazyPat new_pat, ids)
574 zonkPat (AsPat n pat)
575 = zonkIdBndr n `thenNF_Tc` \ new_n ->
576 zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
577 returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
579 zonkPat (ListPat ty pats)
580 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
581 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
582 returnNF_Tc (ListPat new_ty new_pats, ids)
584 zonkPat (TuplePat pats boxed)
585 = zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
586 returnNF_Tc (TuplePat new_pats boxed, ids)
588 zonkPat (ConPat n ty tvs dicts pats)
589 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
590 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
591 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
592 tcExtendGlobalValEnv new_dicts $
593 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
594 returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
595 listToBag new_dicts `unionBags` ids)
597 zonkPat (RecPat n ty tvs dicts rpats)
598 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
599 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
600 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
601 tcExtendGlobalValEnv new_dicts $
602 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
603 returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
604 listToBag new_dicts `unionBags` unionManyBags ids_s)
606 zonk_rpat (f, pat, pun)
607 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
608 returnNF_Tc ((f, new_pat, pun), ids)
610 zonkPat (LitPat lit ty)
611 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
612 returnNF_Tc (LitPat lit new_ty, emptyBag)
614 zonkPat (NPat lit ty expr)
615 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
616 zonkExpr expr `thenNF_Tc` \ new_expr ->
617 returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
619 zonkPat (NPlusKPat n k ty e1 e2)
620 = zonkIdBndr n `thenNF_Tc` \ new_n ->
621 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
622 zonkExpr e1 `thenNF_Tc` \ new_e1 ->
623 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
624 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
626 zonkPat (DictPat ds ms)
627 = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
628 mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
629 returnNF_Tc (DictPat new_ds new_ms,
630 listToBag new_ds `unionBags` listToBag new_ms)
634 = returnNF_Tc ([], emptyBag)
637 = zonkPat pat `thenNF_Tc` \ (pat', ids1) ->
638 zonkPats pats `thenNF_Tc` \ (pats', ids2) ->
639 returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
642 %************************************************************************
644 \subsection[BackSubst-Foreign]{Foreign exports}
646 %************************************************************************
650 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
651 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
653 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
654 zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
655 zonkIdOcc i `thenNF_Tc` \ i' ->
656 returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
660 zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
661 zonkRules rs = mapNF_Tc zonkRule rs
663 zonkRule (HsRule name tyvars vars lhs rhs loc)
664 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
665 mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars] `thenNF_Tc` \ new_bndrs ->
666 tcExtendGlobalValEnv new_bndrs $
667 zonkExpr lhs `thenNF_Tc` \ new_lhs ->
668 zonkExpr rhs `thenNF_Tc` \ new_rhs ->
669 returnNF_Tc (HsRule name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
670 -- I hate this map RuleBndr stuff
672 zonkRule (IfaceRuleOut fun rule)
673 = zonkIdOcc fun `thenNF_Tc` \ fun' ->
674 returnNF_Tc (IfaceRuleOut fun' rule)