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, zonkIdBndr, zonkIdOcc, zonkExpr,
32 zonkForeignExports, zonkRules
35 #include "HsVersions.h"
38 import HsSyn -- oodles of it
41 import Id ( idName, idType, setIdType, 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 = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' ->
160 -- We're even look up up superclass selectors and constructors;
161 -- even though zonking them is a no-op anyway, and the
162 -- superclass selectors aren't in the environment anyway.
163 -- But we don't want to call isLocalId to find out whether
164 -- it's a superclass selector (for example) because that looks
165 -- at the IdInfo field, which in turn be in a knot because of
166 -- the big knot in typecheckModule
168 new_id = case maybe_id' of
169 Just (AnId id') -> id'
170 other -> id -- WARN( isLocalId id, ppr id ) id
171 -- Oops: the warning can give a black hole
172 -- because it looks at the idinfo
179 zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
180 zonkTopBinds binds -- Top level is implicitly recursive
181 = fixNF_Tc (\ ~(_, new_ids) ->
182 tcExtendGlobalValEnv (bagToList new_ids) $
183 zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
184 tcGetEnv `thenNF_Tc` \ env ->
185 returnNF_Tc ((binds', env), new_ids)
186 ) `thenNF_Tc` \ (stuff, _) ->
189 zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
192 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
193 returnNF_Tc (binds', env))
196 -- -> (TypecheckedHsBinds
197 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
199 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
201 go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
203 thing_inside (b1' `ThenBinds` b2')
205 go EmptyBinds thing_inside = thing_inside EmptyBinds
207 go (MonoBind bind sigs is_rec) thing_inside
208 = ASSERT( null sigs )
209 fixNF_Tc (\ ~(_, new_ids) ->
210 tcExtendGlobalValEnv (bagToList new_ids) $
211 zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
212 thing_inside (mkMonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
213 returnNF_Tc (stuff, new_ids)
214 ) `thenNF_Tc` \ (stuff, _) ->
219 -------------------------------------------------------------------------
220 zonkMonoBinds :: TcMonoBinds
221 -> NF_TcM (TypecheckedMonoBinds, Bag Id)
223 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
225 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
226 = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
227 zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
228 returnNF_Tc (b1' `AndMonoBinds` b2',
229 ids1 `unionBags` ids2)
231 zonkMonoBinds (PatMonoBind pat grhss locn)
232 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
233 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
234 returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
236 zonkMonoBinds (VarMonoBind var expr)
237 = zonkIdBndr var `thenNF_Tc` \ new_var ->
238 zonkExpr expr `thenNF_Tc` \ new_expr ->
239 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
241 zonkMonoBinds (CoreMonoBind var core_expr)
242 = zonkIdBndr var `thenNF_Tc` \ new_var ->
243 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
245 zonkMonoBinds (FunMonoBind var inf ms locn)
246 = zonkIdBndr var `thenNF_Tc` \ new_var ->
247 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
248 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
251 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
252 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
253 -- No need to extend tyvar env: the effects are
254 -- propagated through binding the tyvars themselves
256 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
257 tcExtendGlobalValEnv new_dicts $
259 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
260 tcExtendGlobalValEnv (bagToList val_bind_ids) $
261 zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
262 mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports ->
263 returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
264 ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
266 new_globals = listToBag [global | (_, global, local) <- new_exports]
268 returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
271 zonkExport (tyvars, global, local)
272 = zonkTcSigTyVars tyvars `thenNF_Tc` \ new_tyvars ->
273 -- This isn't the binding occurrence of these tyvars
274 -- but they should *be* tyvars. Hence zonkTcSigTyVars.
275 zonkIdBndr global `thenNF_Tc` \ new_global ->
276 zonkIdOcc local `thenNF_Tc` \ new_local ->
277 returnNF_Tc (new_tyvars, new_global, new_local)
280 %************************************************************************
282 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
284 %************************************************************************
287 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
289 zonkMatch (Match _ pats _ grhss)
290 = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
291 tcExtendGlobalValEnv (bagToList new_ids) $
292 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
293 returnNF_Tc (Match [] new_pats Nothing new_grhss)
295 -------------------------------------------------------------------------
297 -> NF_TcM TypecheckedGRHSs
299 zonkGRHSs (GRHSs grhss binds (Just ty))
300 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
303 zonk_grhs (GRHS guarded locn)
304 = zonkStmts guarded `thenNF_Tc` \ new_guarded ->
305 returnNF_Tc (GRHS new_guarded locn)
307 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
308 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
309 returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
312 %************************************************************************
314 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
316 %************************************************************************
319 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
322 = zonkIdOcc id `thenNF_Tc` \ id' ->
323 returnNF_Tc (HsVar id')
325 zonkExpr (HsIPVar id)
326 = zonkIdOcc id `thenNF_Tc` \ id' ->
327 returnNF_Tc (HsIPVar id')
329 zonkExpr (HsLit (HsRat f ty))
330 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
331 returnNF_Tc (HsLit (HsRat f new_ty))
333 zonkExpr (HsLit (HsLitLit lit ty))
334 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
335 returnNF_Tc (HsLit (HsLitLit lit new_ty))
338 = returnNF_Tc (HsLit lit)
340 -- HsOverLit doesn't appear in typechecker output
342 zonkExpr (HsLam match)
343 = zonkMatch match `thenNF_Tc` \ new_match ->
344 returnNF_Tc (HsLam new_match)
346 zonkExpr (HsApp e1 e2)
347 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
348 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
349 returnNF_Tc (HsApp new_e1 new_e2)
351 zonkExpr (OpApp e1 op fixity e2)
352 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
353 zonkExpr op `thenNF_Tc` \ new_op ->
354 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
355 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
357 zonkExpr (NegApp _) = panic "zonkExpr: NegApp"
358 zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
360 zonkExpr (SectionL expr op)
361 = zonkExpr expr `thenNF_Tc` \ new_expr ->
362 zonkExpr op `thenNF_Tc` \ new_op ->
363 returnNF_Tc (SectionL new_expr new_op)
365 zonkExpr (SectionR op expr)
366 = zonkExpr op `thenNF_Tc` \ new_op ->
367 zonkExpr expr `thenNF_Tc` \ new_expr ->
368 returnNF_Tc (SectionR new_op new_expr)
370 zonkExpr (HsCase expr ms src_loc)
371 = zonkExpr expr `thenNF_Tc` \ new_expr ->
372 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
373 returnNF_Tc (HsCase new_expr new_ms src_loc)
375 zonkExpr (HsIf e1 e2 e3 src_loc)
376 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
377 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
378 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
379 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
381 zonkExpr (HsLet binds expr)
382 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
384 zonkExpr expr `thenNF_Tc` \ new_expr ->
385 returnNF_Tc (HsLet new_binds new_expr)
387 zonkExpr (HsWith expr binds)
388 = zonkIPBinds binds `thenNF_Tc` \ new_binds ->
389 tcExtendGlobalValEnv (map fst new_binds) $
390 zonkExpr expr `thenNF_Tc` \ new_expr ->
391 returnNF_Tc (HsWith new_expr new_binds)
393 zonkIPBinds = mapNF_Tc zonkIPBind
395 zonkIdBndr n `thenNF_Tc` \ n' ->
396 zonkExpr e `thenNF_Tc` \ e' ->
399 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
401 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
402 = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
403 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
404 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
405 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
406 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
407 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
410 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
412 zonkExpr (ExplicitListOut ty exprs)
413 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
414 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
415 returnNF_Tc (ExplicitListOut new_ty new_exprs)
417 zonkExpr (ExplicitTuple exprs boxed)
418 = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
419 returnNF_Tc (ExplicitTuple new_exprs boxed)
421 zonkExpr (RecordConOut data_con con_expr rbinds)
422 = zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
423 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
424 returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
426 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
428 zonkExpr (RecordUpdOut expr ty dicts rbinds)
429 = zonkExpr expr `thenNF_Tc` \ new_expr ->
430 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
431 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
432 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
433 returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
435 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
436 zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
438 zonkExpr (ArithSeqOut expr info)
439 = zonkExpr expr `thenNF_Tc` \ new_expr ->
440 zonkArithSeq info `thenNF_Tc` \ new_info ->
441 returnNF_Tc (ArithSeqOut new_expr new_info)
443 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
444 = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
445 zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
446 returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
448 zonkExpr (HsSCC lbl expr)
449 = zonkExpr expr `thenNF_Tc` \ new_expr ->
450 returnNF_Tc (HsSCC lbl new_expr)
452 zonkExpr (TyLam tyvars expr)
453 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
454 -- No need to extend tyvar env; see AbsBinds
456 zonkExpr expr `thenNF_Tc` \ new_expr ->
457 returnNF_Tc (TyLam new_tyvars new_expr)
459 zonkExpr (TyApp expr tys)
460 = zonkExpr expr `thenNF_Tc` \ new_expr ->
461 mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
462 returnNF_Tc (TyApp new_expr new_tys)
464 zonkExpr (DictLam dicts expr)
465 = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
466 tcExtendGlobalValEnv new_dicts $
467 zonkExpr expr `thenNF_Tc` \ new_expr ->
468 returnNF_Tc (DictLam new_dicts new_expr)
470 zonkExpr (DictApp expr dicts)
471 = zonkExpr expr `thenNF_Tc` \ new_expr ->
472 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
473 returnNF_Tc (DictApp new_expr new_dicts)
477 -------------------------------------------------------------------------
478 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
480 zonkArithSeq (From e)
481 = zonkExpr e `thenNF_Tc` \ new_e ->
482 returnNF_Tc (From new_e)
484 zonkArithSeq (FromThen e1 e2)
485 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
486 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
487 returnNF_Tc (FromThen new_e1 new_e2)
489 zonkArithSeq (FromTo e1 e2)
490 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
491 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
492 returnNF_Tc (FromTo new_e1 new_e2)
494 zonkArithSeq (FromThenTo e1 e2 e3)
495 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
496 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
497 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
498 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
500 -------------------------------------------------------------------------
501 zonkStmts :: [TcStmt]
502 -> NF_TcM [TypecheckedStmt]
504 zonkStmts [] = returnNF_Tc []
506 zonkStmts (ParStmtOut bndrstmtss : stmts)
507 = mapNF_Tc (mapNF_Tc zonkId) bndrss `thenNF_Tc` \ new_bndrss ->
508 let new_binders = concat new_bndrss in
509 mapNF_Tc zonkStmts stmtss `thenNF_Tc` \ new_stmtss ->
510 tcExtendGlobalValEnv new_binders $
511 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
512 returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
513 where (bndrss, stmtss) = unzip bndrstmtss
515 zonkStmts (ExprStmt expr locn : stmts)
516 = zonkExpr expr `thenNF_Tc` \ new_expr ->
517 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
518 returnNF_Tc (ExprStmt new_expr locn : new_stmts)
520 zonkStmts (LetStmt binds : stmts)
521 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
523 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
524 returnNF_Tc (LetStmt new_binds : new_stmts)
526 zonkStmts (BindStmt pat expr locn : stmts)
527 = zonkExpr expr `thenNF_Tc` \ new_expr ->
528 zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) ->
529 tcExtendGlobalValEnv (bagToList new_ids) $
530 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
531 returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
535 -------------------------------------------------------------------------
536 zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
539 = mapNF_Tc zonk_rbind rbinds
541 zonk_rbind (field, expr, pun)
542 = zonkExpr expr `thenNF_Tc` \ new_expr ->
543 zonkIdOcc field `thenNF_Tc` \ new_field ->
544 returnNF_Tc (new_field, new_expr, pun)
547 %************************************************************************
549 \subsection[BackSubst-Pats]{Patterns}
551 %************************************************************************
554 zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
557 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
558 returnNF_Tc (WildPat new_ty, emptyBag)
561 = zonkIdBndr v `thenNF_Tc` \ new_v ->
562 returnNF_Tc (VarPat new_v, unitBag new_v)
564 zonkPat (LazyPat pat)
565 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
566 returnNF_Tc (LazyPat new_pat, ids)
568 zonkPat (AsPat n pat)
569 = zonkIdBndr n `thenNF_Tc` \ new_n ->
570 zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
571 returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
573 zonkPat (ListPat ty pats)
574 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
575 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
576 returnNF_Tc (ListPat new_ty new_pats, ids)
578 zonkPat (TuplePat pats boxed)
579 = zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
580 returnNF_Tc (TuplePat new_pats boxed, ids)
582 zonkPat (ConPat n ty tvs dicts pats)
583 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
584 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
585 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
586 tcExtendGlobalValEnv new_dicts $
587 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
588 returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
589 listToBag new_dicts `unionBags` ids)
591 zonkPat (RecPat n ty tvs dicts rpats)
592 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
593 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
594 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
595 tcExtendGlobalValEnv new_dicts $
596 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
597 returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
598 listToBag new_dicts `unionBags` unionManyBags ids_s)
600 zonk_rpat (f, pat, pun)
601 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
602 returnNF_Tc ((f, new_pat, pun), ids)
604 zonkPat (LitPat lit ty)
605 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
606 returnNF_Tc (LitPat lit new_ty, emptyBag)
608 zonkPat (NPat lit ty expr)
609 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
610 zonkExpr expr `thenNF_Tc` \ new_expr ->
611 returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
613 zonkPat (NPlusKPat n k ty e1 e2)
614 = zonkIdBndr n `thenNF_Tc` \ new_n ->
615 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
616 zonkExpr e1 `thenNF_Tc` \ new_e1 ->
617 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
618 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
620 zonkPat (DictPat ds ms)
621 = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
622 mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
623 returnNF_Tc (DictPat new_ds new_ms,
624 listToBag new_ds `unionBags` listToBag new_ms)
628 = returnNF_Tc ([], emptyBag)
631 = zonkPat pat `thenNF_Tc` \ (pat', ids1) ->
632 zonkPats pats `thenNF_Tc` \ (pats', ids2) ->
633 returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
636 %************************************************************************
638 \subsection[BackSubst-Foreign]{Foreign exports}
640 %************************************************************************
644 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
645 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
647 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
648 zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
649 zonkIdOcc i `thenNF_Tc` \ i' ->
650 returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
654 zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
655 zonkRules rs = mapNF_Tc zonkRule rs
657 zonkRule (HsRule name tyvars vars lhs rhs loc)
658 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
659 mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars] `thenNF_Tc` \ new_bndrs ->
660 tcExtendGlobalValEnv new_bndrs $
661 zonkExpr lhs `thenNF_Tc` \ new_lhs ->
662 zonkExpr rhs `thenNF_Tc` \ new_rhs ->
663 returnNF_Tc (HsRule name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
664 -- I hate this map RuleBndr stuff
666 zonkRule (IfaceRuleOut fun rule)
667 = zonkIdOcc fun `thenNF_Tc` \ fun' ->
668 returnNF_Tc (IfaceRuleOut fun' rule)