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,
24 TypecheckedMatchContext,
26 mkHsTyApp, mkHsDictApp, mkHsConApp,
27 mkHsTyLam, mkHsDictLam, mkHsLet,
29 -- re-exported from TcEnv
32 zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
33 zonkForeignExports, zonkRules
36 #include "HsVersions.h"
39 import HsSyn -- oodles of it
42 import Id ( idName, idType, setIdType, Id )
43 import DataCon ( dataConWrapId )
44 import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv,
49 import TcType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars
51 import CoreSyn ( Expr )
52 import BasicTypes ( RecFlag(..) )
55 import HscTypes ( TyThing(..) )
62 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
63 All the types in @Tc...@ things have mutable type-variables in them for
66 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
67 which have immutable type variables in them.
70 type TcHsBinds = HsBinds TcId TcPat
71 type TcMonoBinds = MonoBinds TcId TcPat
72 type TcDictBinds = TcMonoBinds
73 type TcPat = OutPat TcId
74 type TcExpr = HsExpr TcId TcPat
75 type TcGRHSs = GRHSs TcId TcPat
76 type TcGRHS = GRHS TcId TcPat
77 type TcMatch = Match TcId TcPat
78 type TcStmt = Stmt TcId TcPat
79 type TcArithSeqInfo = ArithSeqInfo TcId TcPat
80 type TcRecordBinds = HsRecordBinds TcId TcPat
81 type TcHsModule = HsModule TcId TcPat
83 type TcCoreExpr = Expr TcId
84 type TcForeignExportDecl = ForeignDecl TcId
85 type TcRuleDecl = RuleDecl TcId TcPat
87 type TypecheckedPat = OutPat Id
88 type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
89 type TypecheckedDictBinds = TypecheckedMonoBinds
90 type TypecheckedHsBinds = HsBinds Id TypecheckedPat
91 type TypecheckedHsExpr = HsExpr Id TypecheckedPat
92 type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat
93 type TypecheckedStmt = Stmt Id TypecheckedPat
94 type TypecheckedMatch = Match Id TypecheckedPat
95 type TypecheckedMatchContext = HsMatchContext Id
96 type TypecheckedGRHSs = GRHSs Id TypecheckedPat
97 type TypecheckedGRHS = GRHS Id TypecheckedPat
98 type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
99 type TypecheckedHsModule = HsModule Id TypecheckedPat
100 type TypecheckedForeignDecl = ForeignDecl Id
101 type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
105 mkHsTyApp expr [] = expr
106 mkHsTyApp expr tys = TyApp expr tys
108 mkHsDictApp expr [] = expr
109 mkHsDictApp expr dict_vars = DictApp expr dict_vars
111 mkHsTyLam [] expr = expr
112 mkHsTyLam tyvars expr = TyLam tyvars expr
114 mkHsDictLam [] expr = expr
115 mkHsDictLam dicts expr = DictLam dicts expr
117 mkHsLet EmptyMonoBinds expr = expr
118 mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
120 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
123 %************************************************************************
125 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
127 %************************************************************************
129 This zonking pass runs over the bindings
131 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
132 b) convert unbound TcTyVar to Void
133 c) convert each TcId to an Id by zonking its type
135 The type variables are converted by binding mutable tyvars to immutable ones
136 and then zonking as normal.
138 The Ids are converted by binding them in the normal Tc envt; that
139 way we maintain sharing; eg an Id is zonked at its binding site and they
140 all occurrences of that Id point to the common zonked copy
142 It's all pretty boring stuff, because HsSyn is such a large type, and
143 the environment manipulation is tiresome.
146 -- zonkId is used *during* typechecking just to zonk the Id's type
147 zonkId :: TcId -> NF_TcM TcId
149 = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
150 returnNF_Tc (setIdType id ty')
152 -- zonkIdBndr is used *after* typechecking to get the Id's type
153 -- to its final form. The TyVarEnv give
154 zonkIdBndr :: TcId -> NF_TcM Id
156 = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' ->
157 returnNF_Tc (setIdType id ty')
159 zonkIdOcc :: TcId -> NF_TcM Id
161 = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' ->
162 -- We're even look up up superclass selectors and constructors;
163 -- even though zonking them is a no-op anyway, and the
164 -- superclass selectors aren't in the environment anyway.
165 -- But we don't want to call isLocalId to find out whether
166 -- it's a superclass selector (for example) because that looks
167 -- at the IdInfo field, which in turn be in a knot because of
168 -- the big knot in typecheckModule
170 new_id = case maybe_id' of
171 Just (AnId id') -> id'
172 other -> id -- WARN( isLocalId id, ppr id ) id
173 -- Oops: the warning can give a black hole
174 -- because it looks at the idinfo
181 zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
182 zonkTopBinds binds -- Top level is implicitly recursive
183 = fixNF_Tc (\ ~(_, new_ids) ->
184 tcExtendGlobalValEnv (bagToList new_ids) $
185 zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
186 tcGetEnv `thenNF_Tc` \ env ->
187 returnNF_Tc ((binds', env), new_ids)
188 ) `thenNF_Tc` \ (stuff, _) ->
191 zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
194 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
195 returnNF_Tc (binds', env))
198 -- -> (TypecheckedHsBinds
199 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
201 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
203 go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
205 thing_inside (b1' `ThenBinds` b2')
207 go EmptyBinds thing_inside = thing_inside EmptyBinds
209 go (MonoBind bind sigs is_rec) thing_inside
210 = ASSERT( null sigs )
211 fixNF_Tc (\ ~(_, new_ids) ->
212 tcExtendGlobalValEnv (bagToList new_ids) $
213 zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
214 thing_inside (mkMonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
215 returnNF_Tc (stuff, new_ids)
216 ) `thenNF_Tc` \ (stuff, _) ->
221 -------------------------------------------------------------------------
222 zonkMonoBinds :: TcMonoBinds
223 -> NF_TcM (TypecheckedMonoBinds, Bag Id)
225 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
227 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
228 = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
229 zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
230 returnNF_Tc (b1' `AndMonoBinds` b2',
231 ids1 `unionBags` ids2)
233 zonkMonoBinds (PatMonoBind pat grhss locn)
234 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
235 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
236 returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
238 zonkMonoBinds (VarMonoBind var expr)
239 = zonkIdBndr var `thenNF_Tc` \ new_var ->
240 zonkExpr expr `thenNF_Tc` \ new_expr ->
241 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
243 zonkMonoBinds (CoreMonoBind var core_expr)
244 = zonkIdBndr var `thenNF_Tc` \ new_var ->
245 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
247 zonkMonoBinds (FunMonoBind var inf ms locn)
248 = zonkIdBndr var `thenNF_Tc` \ new_var ->
249 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
250 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
253 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
254 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
255 -- No need to extend tyvar env: the effects are
256 -- propagated through binding the tyvars themselves
258 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
259 tcExtendGlobalValEnv new_dicts $
261 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
262 tcExtendGlobalValEnv (bagToList val_bind_ids) $
263 zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
264 mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports ->
265 returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
266 ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
268 new_globals = listToBag [global | (_, global, local) <- new_exports]
270 returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
273 zonkExport (tyvars, global, local)
274 = zonkTcSigTyVars tyvars `thenNF_Tc` \ new_tyvars ->
275 -- This isn't the binding occurrence of these tyvars
276 -- but they should *be* tyvars. Hence zonkTcSigTyVars.
277 zonkIdBndr global `thenNF_Tc` \ new_global ->
278 zonkIdOcc local `thenNF_Tc` \ new_local ->
279 returnNF_Tc (new_tyvars, new_global, new_local)
282 %************************************************************************
284 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
286 %************************************************************************
289 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
291 zonkMatch (Match _ pats _ grhss)
292 = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
293 tcExtendGlobalValEnv (bagToList new_ids) $
294 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
295 returnNF_Tc (Match [] new_pats Nothing new_grhss)
297 -------------------------------------------------------------------------
299 -> NF_TcM TypecheckedGRHSs
301 zonkGRHSs (GRHSs grhss binds (Just ty))
302 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
305 zonk_grhs (GRHS guarded locn)
306 = zonkStmts guarded `thenNF_Tc` \ new_guarded ->
307 returnNF_Tc (GRHS new_guarded locn)
309 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
310 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
311 returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
314 %************************************************************************
316 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
318 %************************************************************************
321 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
324 = zonkIdOcc id `thenNF_Tc` \ id' ->
325 returnNF_Tc (HsVar id')
327 zonkExpr (HsIPVar id)
328 = zonkIdOcc id `thenNF_Tc` \ id' ->
329 returnNF_Tc (HsIPVar id')
331 zonkExpr (HsLit (HsRat f ty))
332 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
333 returnNF_Tc (HsLit (HsRat f new_ty))
335 zonkExpr (HsLit (HsLitLit lit ty))
336 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
337 returnNF_Tc (HsLit (HsLitLit lit new_ty))
340 = returnNF_Tc (HsLit lit)
342 -- HsOverLit doesn't appear in typechecker output
344 zonkExpr (HsLam match)
345 = zonkMatch match `thenNF_Tc` \ new_match ->
346 returnNF_Tc (HsLam new_match)
348 zonkExpr (HsApp e1 e2)
349 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
350 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
351 returnNF_Tc (HsApp new_e1 new_e2)
353 zonkExpr (OpApp e1 op fixity e2)
354 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
355 zonkExpr op `thenNF_Tc` \ new_op ->
356 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
357 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
359 zonkExpr (NegApp _) = panic "zonkExpr: NegApp"
360 zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
362 zonkExpr (SectionL expr op)
363 = zonkExpr expr `thenNF_Tc` \ new_expr ->
364 zonkExpr op `thenNF_Tc` \ new_op ->
365 returnNF_Tc (SectionL new_expr new_op)
367 zonkExpr (SectionR op expr)
368 = zonkExpr op `thenNF_Tc` \ new_op ->
369 zonkExpr expr `thenNF_Tc` \ new_expr ->
370 returnNF_Tc (SectionR new_op new_expr)
372 zonkExpr (HsCase expr ms src_loc)
373 = zonkExpr expr `thenNF_Tc` \ new_expr ->
374 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
375 returnNF_Tc (HsCase new_expr new_ms src_loc)
377 zonkExpr (HsIf e1 e2 e3 src_loc)
378 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
379 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
380 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
381 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
383 zonkExpr (HsLet binds expr)
384 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
386 zonkExpr expr `thenNF_Tc` \ new_expr ->
387 returnNF_Tc (HsLet new_binds new_expr)
389 zonkExpr (HsWith expr binds)
390 = zonkIPBinds binds `thenNF_Tc` \ new_binds ->
391 tcExtendGlobalValEnv (map fst new_binds) $
392 zonkExpr expr `thenNF_Tc` \ new_expr ->
393 returnNF_Tc (HsWith new_expr new_binds)
395 zonkIPBinds = mapNF_Tc zonkIPBind
397 zonkIdBndr n `thenNF_Tc` \ n' ->
398 zonkExpr e `thenNF_Tc` \ e' ->
401 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
403 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
404 = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
405 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
406 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
407 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
408 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
409 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
412 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
414 zonkExpr (ExplicitListOut ty exprs)
415 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
416 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
417 returnNF_Tc (ExplicitListOut new_ty new_exprs)
419 zonkExpr (ExplicitTuple exprs boxed)
420 = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
421 returnNF_Tc (ExplicitTuple new_exprs boxed)
423 zonkExpr (RecordConOut data_con con_expr rbinds)
424 = zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
425 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
426 returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
428 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
430 zonkExpr (RecordUpdOut expr ty dicts rbinds)
431 = zonkExpr expr `thenNF_Tc` \ new_expr ->
432 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
433 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
434 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
435 returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
437 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
438 zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
440 zonkExpr (ArithSeqOut expr info)
441 = zonkExpr expr `thenNF_Tc` \ new_expr ->
442 zonkArithSeq info `thenNF_Tc` \ new_info ->
443 returnNF_Tc (ArithSeqOut new_expr new_info)
445 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
446 = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
447 zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
448 returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
450 zonkExpr (HsSCC lbl expr)
451 = zonkExpr expr `thenNF_Tc` \ new_expr ->
452 returnNF_Tc (HsSCC lbl new_expr)
454 zonkExpr (TyLam tyvars expr)
455 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
456 -- No need to extend tyvar env; see AbsBinds
458 zonkExpr expr `thenNF_Tc` \ new_expr ->
459 returnNF_Tc (TyLam new_tyvars new_expr)
461 zonkExpr (TyApp expr tys)
462 = zonkExpr expr `thenNF_Tc` \ new_expr ->
463 mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
464 returnNF_Tc (TyApp new_expr new_tys)
466 zonkExpr (DictLam dicts expr)
467 = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
468 tcExtendGlobalValEnv new_dicts $
469 zonkExpr expr `thenNF_Tc` \ new_expr ->
470 returnNF_Tc (DictLam new_dicts new_expr)
472 zonkExpr (DictApp expr dicts)
473 = zonkExpr expr `thenNF_Tc` \ new_expr ->
474 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
475 returnNF_Tc (DictApp new_expr new_dicts)
479 -------------------------------------------------------------------------
480 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
482 zonkArithSeq (From e)
483 = zonkExpr e `thenNF_Tc` \ new_e ->
484 returnNF_Tc (From new_e)
486 zonkArithSeq (FromThen e1 e2)
487 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
488 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
489 returnNF_Tc (FromThen new_e1 new_e2)
491 zonkArithSeq (FromTo e1 e2)
492 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
493 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
494 returnNF_Tc (FromTo new_e1 new_e2)
496 zonkArithSeq (FromThenTo e1 e2 e3)
497 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
498 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
499 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
500 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
502 -------------------------------------------------------------------------
503 zonkStmts :: [TcStmt]
504 -> NF_TcM [TypecheckedStmt]
506 zonkStmts [] = returnNF_Tc []
508 zonkStmts (ParStmtOut bndrstmtss : stmts)
509 = mapNF_Tc (mapNF_Tc zonkId) bndrss `thenNF_Tc` \ new_bndrss ->
510 let new_binders = concat new_bndrss in
511 mapNF_Tc zonkStmts stmtss `thenNF_Tc` \ new_stmtss ->
512 tcExtendGlobalValEnv new_binders $
513 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
514 returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
515 where (bndrss, stmtss) = unzip bndrstmtss
517 zonkStmts (ResultStmt expr locn : stmts)
518 = zonkExpr expr `thenNF_Tc` \ new_expr ->
519 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
520 returnNF_Tc (ResultStmt new_expr locn : new_stmts)
522 zonkStmts (ExprStmt expr locn : stmts)
523 = zonkExpr expr `thenNF_Tc` \ new_expr ->
524 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
525 returnNF_Tc (ExprStmt new_expr locn : new_stmts)
527 zonkStmts (LetStmt binds : stmts)
528 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
530 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
531 returnNF_Tc (LetStmt new_binds : new_stmts)
533 zonkStmts (BindStmt pat expr locn : stmts)
534 = zonkExpr expr `thenNF_Tc` \ new_expr ->
535 zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) ->
536 tcExtendGlobalValEnv (bagToList new_ids) $
537 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
538 returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
542 -------------------------------------------------------------------------
543 zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
546 = mapNF_Tc zonk_rbind rbinds
548 zonk_rbind (field, expr, pun)
549 = zonkExpr expr `thenNF_Tc` \ new_expr ->
550 zonkIdOcc field `thenNF_Tc` \ new_field ->
551 returnNF_Tc (new_field, new_expr, pun)
554 %************************************************************************
556 \subsection[BackSubst-Pats]{Patterns}
558 %************************************************************************
561 zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
564 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
565 returnNF_Tc (WildPat new_ty, emptyBag)
568 = zonkIdBndr v `thenNF_Tc` \ new_v ->
569 returnNF_Tc (VarPat new_v, unitBag new_v)
571 zonkPat (LazyPat pat)
572 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
573 returnNF_Tc (LazyPat new_pat, ids)
575 zonkPat (AsPat n pat)
576 = zonkIdBndr n `thenNF_Tc` \ new_n ->
577 zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
578 returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
580 zonkPat (ListPat ty pats)
581 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
582 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
583 returnNF_Tc (ListPat new_ty new_pats, ids)
585 zonkPat (TuplePat pats boxed)
586 = zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
587 returnNF_Tc (TuplePat new_pats boxed, ids)
589 zonkPat (ConPat n ty tvs dicts pats)
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 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
595 returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
596 listToBag new_dicts `unionBags` ids)
598 zonkPat (RecPat n ty tvs dicts rpats)
599 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
600 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
601 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
602 tcExtendGlobalValEnv new_dicts $
603 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
604 returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
605 listToBag new_dicts `unionBags` unionManyBags ids_s)
607 zonk_rpat (f, pat, pun)
608 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
609 returnNF_Tc ((f, new_pat, pun), ids)
611 zonkPat (LitPat lit ty)
612 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
613 returnNF_Tc (LitPat lit new_ty, emptyBag)
615 zonkPat (NPat lit ty expr)
616 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
617 zonkExpr expr `thenNF_Tc` \ new_expr ->
618 returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
620 zonkPat (NPlusKPat n k ty e1 e2)
621 = zonkIdBndr n `thenNF_Tc` \ new_n ->
622 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
623 zonkExpr e1 `thenNF_Tc` \ new_e1 ->
624 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
625 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
627 zonkPat (DictPat ds ms)
628 = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
629 mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
630 returnNF_Tc (DictPat new_ds new_ms,
631 listToBag new_ds `unionBags` listToBag new_ms)
635 = returnNF_Tc ([], emptyBag)
638 = zonkPat pat `thenNF_Tc` \ (pat', ids1) ->
639 zonkPats pats `thenNF_Tc` \ (pats', ids2) ->
640 returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
643 %************************************************************************
645 \subsection[BackSubst-Foreign]{Foreign exports}
647 %************************************************************************
651 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
652 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
654 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
655 zonkForeignExport (ForeignExport i hs_ty spec src_loc) =
656 zonkIdOcc i `thenNF_Tc` \ i' ->
657 returnNF_Tc (ForeignExport i' undefined spec src_loc)
661 zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
662 zonkRules rs = mapNF_Tc zonkRule rs
664 zonkRule (HsRule name tyvars vars lhs rhs loc)
665 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
666 mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars] `thenNF_Tc` \ new_bndrs ->
667 tcExtendGlobalValEnv new_bndrs $
668 zonkExpr lhs `thenNF_Tc` \ new_lhs ->
669 zonkExpr rhs `thenNF_Tc` \ new_rhs ->
670 returnNF_Tc (HsRule name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
671 -- I hate this map RuleBndr stuff
673 zonkRule (IfaceRuleOut fun rule)
674 = zonkIdOcc fun `thenNF_Tc` \ fun' ->
675 returnNF_Tc (IfaceRuleOut fun' rule)