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, isLocalId, 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 -> WARN( isLocalId id, ppr id ) id
177 zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
178 zonkTopBinds binds -- Top level is implicitly recursive
179 = fixNF_Tc (\ ~(_, new_ids) ->
180 tcExtendGlobalValEnv (bagToList new_ids) $
181 zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
182 tcGetEnv `thenNF_Tc` \ env ->
183 returnNF_Tc ((binds', env), new_ids)
184 ) `thenNF_Tc` \ (stuff, _) ->
187 zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
190 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
191 returnNF_Tc (binds', env))
194 -- -> (TypecheckedHsBinds
195 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
197 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
199 go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
201 thing_inside (b1' `ThenBinds` b2')
203 go EmptyBinds thing_inside = thing_inside EmptyBinds
205 go (MonoBind bind sigs is_rec) thing_inside
206 = ASSERT( null sigs )
207 fixNF_Tc (\ ~(_, new_ids) ->
208 tcExtendGlobalValEnv (bagToList new_ids) $
209 zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
210 thing_inside (mkMonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
211 returnNF_Tc (stuff, new_ids)
212 ) `thenNF_Tc` \ (stuff, _) ->
217 -------------------------------------------------------------------------
218 zonkMonoBinds :: TcMonoBinds
219 -> NF_TcM (TypecheckedMonoBinds, Bag Id)
221 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
223 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
224 = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
225 zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
226 returnNF_Tc (b1' `AndMonoBinds` b2',
227 ids1 `unionBags` ids2)
229 zonkMonoBinds (PatMonoBind pat grhss locn)
230 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
231 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
232 returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
234 zonkMonoBinds (VarMonoBind var expr)
235 = zonkIdBndr var `thenNF_Tc` \ new_var ->
236 zonkExpr expr `thenNF_Tc` \ new_expr ->
237 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
239 zonkMonoBinds (CoreMonoBind var core_expr)
240 = zonkIdBndr var `thenNF_Tc` \ new_var ->
241 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
243 zonkMonoBinds (FunMonoBind var inf ms locn)
244 = zonkIdBndr var `thenNF_Tc` \ new_var ->
245 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
246 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
249 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
250 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
251 -- No need to extend tyvar env: the effects are
252 -- propagated through binding the tyvars themselves
254 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
255 tcExtendGlobalValEnv new_dicts $
257 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
258 tcExtendGlobalValEnv (bagToList val_bind_ids) $
259 zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
260 mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports ->
261 returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
262 ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
264 new_globals = listToBag [global | (_, global, local) <- new_exports]
266 returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
269 zonkExport (tyvars, global, local)
270 = zonkTcSigTyVars tyvars `thenNF_Tc` \ new_tyvars ->
271 -- This isn't the binding occurrence of these tyvars
272 -- but they should *be* tyvars. Hence zonkTcSigTyVars.
273 zonkIdBndr global `thenNF_Tc` \ new_global ->
274 zonkIdOcc local `thenNF_Tc` \ new_local ->
275 returnNF_Tc (new_tyvars, new_global, new_local)
278 %************************************************************************
280 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
282 %************************************************************************
285 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
287 zonkMatch (Match _ pats _ grhss)
288 = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
289 tcExtendGlobalValEnv (bagToList new_ids) $
290 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
291 returnNF_Tc (Match [] new_pats Nothing new_grhss)
293 -------------------------------------------------------------------------
295 -> NF_TcM TypecheckedGRHSs
297 zonkGRHSs (GRHSs grhss binds (Just ty))
298 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
301 zonk_grhs (GRHS guarded locn)
302 = zonkStmts guarded `thenNF_Tc` \ new_guarded ->
303 returnNF_Tc (GRHS new_guarded locn)
305 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
306 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
307 returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
310 %************************************************************************
312 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
314 %************************************************************************
317 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
320 = zonkIdOcc id `thenNF_Tc` \ id' ->
321 returnNF_Tc (HsVar id')
323 zonkExpr (HsIPVar id)
324 = zonkIdOcc id `thenNF_Tc` \ id' ->
325 returnNF_Tc (HsIPVar id')
327 zonkExpr (HsLit (HsRat f ty))
328 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
329 returnNF_Tc (HsLit (HsRat f new_ty))
331 zonkExpr (HsLit (HsLitLit lit ty))
332 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
333 returnNF_Tc (HsLit (HsLitLit lit new_ty))
336 = returnNF_Tc (HsLit lit)
338 -- HsOverLit doesn't appear in typechecker output
340 zonkExpr (HsLam match)
341 = zonkMatch match `thenNF_Tc` \ new_match ->
342 returnNF_Tc (HsLam new_match)
344 zonkExpr (HsApp e1 e2)
345 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
346 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
347 returnNF_Tc (HsApp new_e1 new_e2)
349 zonkExpr (OpApp e1 op fixity e2)
350 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
351 zonkExpr op `thenNF_Tc` \ new_op ->
352 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
353 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
355 zonkExpr (NegApp _) = panic "zonkExpr: NegApp"
356 zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
358 zonkExpr (SectionL expr op)
359 = zonkExpr expr `thenNF_Tc` \ new_expr ->
360 zonkExpr op `thenNF_Tc` \ new_op ->
361 returnNF_Tc (SectionL new_expr new_op)
363 zonkExpr (SectionR op expr)
364 = zonkExpr op `thenNF_Tc` \ new_op ->
365 zonkExpr expr `thenNF_Tc` \ new_expr ->
366 returnNF_Tc (SectionR new_op new_expr)
368 zonkExpr (HsCase expr ms src_loc)
369 = zonkExpr expr `thenNF_Tc` \ new_expr ->
370 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
371 returnNF_Tc (HsCase new_expr new_ms src_loc)
373 zonkExpr (HsIf e1 e2 e3 src_loc)
374 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
375 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
376 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
377 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
379 zonkExpr (HsLet binds expr)
380 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
382 zonkExpr expr `thenNF_Tc` \ new_expr ->
383 returnNF_Tc (HsLet new_binds new_expr)
385 zonkExpr (HsWith expr binds)
386 = zonkIPBinds binds `thenNF_Tc` \ new_binds ->
387 tcExtendGlobalValEnv (map fst new_binds) $
388 zonkExpr expr `thenNF_Tc` \ new_expr ->
389 returnNF_Tc (HsWith new_expr new_binds)
391 zonkIPBinds = mapNF_Tc zonkIPBind
393 zonkIdBndr n `thenNF_Tc` \ n' ->
394 zonkExpr e `thenNF_Tc` \ e' ->
397 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
399 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
400 = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
401 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
402 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
403 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
404 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
405 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
408 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
410 zonkExpr (ExplicitListOut ty exprs)
411 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
412 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
413 returnNF_Tc (ExplicitListOut new_ty new_exprs)
415 zonkExpr (ExplicitTuple exprs boxed)
416 = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
417 returnNF_Tc (ExplicitTuple new_exprs boxed)
419 zonkExpr (RecordConOut data_con con_expr rbinds)
420 = zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
421 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
422 returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
424 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
426 zonkExpr (RecordUpdOut expr ty dicts rbinds)
427 = zonkExpr expr `thenNF_Tc` \ new_expr ->
428 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
429 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
430 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
431 returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
433 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
434 zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
436 zonkExpr (ArithSeqOut expr info)
437 = zonkExpr expr `thenNF_Tc` \ new_expr ->
438 zonkArithSeq info `thenNF_Tc` \ new_info ->
439 returnNF_Tc (ArithSeqOut new_expr new_info)
441 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
442 = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
443 zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
444 returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
446 zonkExpr (HsSCC lbl expr)
447 = zonkExpr expr `thenNF_Tc` \ new_expr ->
448 returnNF_Tc (HsSCC lbl new_expr)
450 zonkExpr (TyLam tyvars expr)
451 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
452 -- No need to extend tyvar env; see AbsBinds
454 zonkExpr expr `thenNF_Tc` \ new_expr ->
455 returnNF_Tc (TyLam new_tyvars new_expr)
457 zonkExpr (TyApp expr tys)
458 = zonkExpr expr `thenNF_Tc` \ new_expr ->
459 mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
460 returnNF_Tc (TyApp new_expr new_tys)
462 zonkExpr (DictLam dicts expr)
463 = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
464 tcExtendGlobalValEnv new_dicts $
465 zonkExpr expr `thenNF_Tc` \ new_expr ->
466 returnNF_Tc (DictLam new_dicts new_expr)
468 zonkExpr (DictApp expr dicts)
469 = zonkExpr expr `thenNF_Tc` \ new_expr ->
470 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
471 returnNF_Tc (DictApp new_expr new_dicts)
475 -------------------------------------------------------------------------
476 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
478 zonkArithSeq (From e)
479 = zonkExpr e `thenNF_Tc` \ new_e ->
480 returnNF_Tc (From new_e)
482 zonkArithSeq (FromThen e1 e2)
483 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
484 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
485 returnNF_Tc (FromThen new_e1 new_e2)
487 zonkArithSeq (FromTo e1 e2)
488 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
489 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
490 returnNF_Tc (FromTo new_e1 new_e2)
492 zonkArithSeq (FromThenTo e1 e2 e3)
493 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
494 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
495 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
496 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
498 -------------------------------------------------------------------------
499 zonkStmts :: [TcStmt]
500 -> NF_TcM [TypecheckedStmt]
502 zonkStmts [] = returnNF_Tc []
504 zonkStmts (ParStmtOut bndrstmtss : stmts)
505 = mapNF_Tc (mapNF_Tc zonkId) bndrss `thenNF_Tc` \ new_bndrss ->
506 let new_binders = concat new_bndrss in
507 mapNF_Tc zonkStmts stmtss `thenNF_Tc` \ new_stmtss ->
508 tcExtendGlobalValEnv new_binders $
509 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
510 returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
511 where (bndrss, stmtss) = unzip bndrstmtss
513 zonkStmts (ExprStmt expr locn : stmts)
514 = zonkExpr expr `thenNF_Tc` \ new_expr ->
515 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
516 returnNF_Tc (ExprStmt new_expr locn : new_stmts)
518 zonkStmts (LetStmt binds : stmts)
519 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
521 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
522 returnNF_Tc (LetStmt new_binds : new_stmts)
524 zonkStmts (BindStmt pat expr locn : stmts)
525 = zonkExpr expr `thenNF_Tc` \ new_expr ->
526 zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) ->
527 tcExtendGlobalValEnv (bagToList new_ids) $
528 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
529 returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
533 -------------------------------------------------------------------------
534 zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
537 = mapNF_Tc zonk_rbind rbinds
539 zonk_rbind (field, expr, pun)
540 = zonkExpr expr `thenNF_Tc` \ new_expr ->
541 zonkIdOcc field `thenNF_Tc` \ new_field ->
542 returnNF_Tc (new_field, new_expr, pun)
545 %************************************************************************
547 \subsection[BackSubst-Pats]{Patterns}
549 %************************************************************************
552 zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
555 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
556 returnNF_Tc (WildPat new_ty, emptyBag)
559 = zonkIdBndr v `thenNF_Tc` \ new_v ->
560 returnNF_Tc (VarPat new_v, unitBag new_v)
562 zonkPat (LazyPat pat)
563 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
564 returnNF_Tc (LazyPat new_pat, ids)
566 zonkPat (AsPat n pat)
567 = zonkIdBndr n `thenNF_Tc` \ new_n ->
568 zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
569 returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
571 zonkPat (ListPat ty pats)
572 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
573 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
574 returnNF_Tc (ListPat new_ty new_pats, ids)
576 zonkPat (TuplePat pats boxed)
577 = zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
578 returnNF_Tc (TuplePat new_pats boxed, ids)
580 zonkPat (ConPat n ty tvs dicts pats)
581 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
582 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
583 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
584 tcExtendGlobalValEnv new_dicts $
585 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
586 returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
587 listToBag new_dicts `unionBags` ids)
589 zonkPat (RecPat n ty tvs dicts rpats)
590 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
591 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
592 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
593 tcExtendGlobalValEnv new_dicts $
594 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
595 returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
596 listToBag new_dicts `unionBags` unionManyBags ids_s)
598 zonk_rpat (f, pat, pun)
599 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
600 returnNF_Tc ((f, new_pat, pun), ids)
602 zonkPat (LitPat lit ty)
603 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
604 returnNF_Tc (LitPat lit new_ty, emptyBag)
606 zonkPat (NPat lit ty expr)
607 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
608 zonkExpr expr `thenNF_Tc` \ new_expr ->
609 returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
611 zonkPat (NPlusKPat n k ty e1 e2)
612 = zonkIdBndr n `thenNF_Tc` \ new_n ->
613 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
614 zonkExpr e1 `thenNF_Tc` \ new_e1 ->
615 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
616 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
618 zonkPat (DictPat ds ms)
619 = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
620 mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
621 returnNF_Tc (DictPat new_ds new_ms,
622 listToBag new_ds `unionBags` listToBag new_ms)
626 = returnNF_Tc ([], emptyBag)
629 = zonkPat pat `thenNF_Tc` \ (pat', ids1) ->
630 zonkPats pats `thenNF_Tc` \ (pats', ids2) ->
631 returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
634 %************************************************************************
636 \subsection[BackSubst-Foreign]{Foreign exports}
638 %************************************************************************
642 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
643 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
645 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
646 zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
647 zonkIdOcc i `thenNF_Tc` \ i' ->
648 returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
652 zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
653 zonkRules rs = mapNF_Tc zonkRule rs
655 zonkRule (HsRule name tyvars vars lhs rhs loc)
656 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
657 mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars] `thenNF_Tc` \ new_bndrs ->
658 tcExtendGlobalValEnv new_bndrs $
659 zonkExpr lhs `thenNF_Tc` \ new_lhs ->
660 zonkExpr rhs `thenNF_Tc` \ new_rhs ->
661 returnNF_Tc (HsRule name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
662 -- I hate this map RuleBndr stuff
664 zonkRule (IfaceRuleOut fun rule)
665 = zonkIdOcc fun `thenNF_Tc` \ fun' ->
666 returnNF_Tc (IfaceRuleOut fun' rule)