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,
29 -- re-exported from TcEnv
32 zonkTopBinds, zonkId, zonkIdOcc,
33 zonkForeignExports, zonkRules
36 #include "HsVersions.h"
39 import HsSyn -- oodles of it
42 import Id ( idName, idType, isLocalId, idUnfolding, setIdType, isIP, Id )
43 import DataCon ( dataConWrapId )
44 import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv,
49 import TcType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars
51 import CoreSyn ( Expr )
52 import CoreUnfold( unfoldingTemplate )
53 import BasicTypes ( RecFlag(..) )
56 import HscTypes ( TyThing(..) )
63 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
64 All the types in @Tc...@ things have mutable type-variables in them for
67 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
68 which have immutable type variables in them.
71 type TcHsBinds = HsBinds TcId TcPat
72 type TcMonoBinds = MonoBinds TcId TcPat
73 type TcDictBinds = TcMonoBinds
74 type TcPat = OutPat TcId
75 type TcExpr = HsExpr TcId TcPat
76 type TcGRHSs = GRHSs TcId TcPat
77 type TcGRHS = GRHS TcId TcPat
78 type TcMatch = Match TcId TcPat
79 type TcStmt = Stmt TcId TcPat
80 type TcArithSeqInfo = ArithSeqInfo TcId TcPat
81 type TcRecordBinds = HsRecordBinds TcId TcPat
82 type TcHsModule = HsModule TcId TcPat
84 type TcCoreExpr = Expr TcId
85 type TcForeignExportDecl = ForeignDecl TcId
86 type TcRuleDecl = RuleDecl TcId TcPat
88 type TypecheckedPat = OutPat Id
89 type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
90 type TypecheckedDictBinds = TypecheckedMonoBinds
91 type TypecheckedHsBinds = HsBinds Id TypecheckedPat
92 type TypecheckedHsExpr = HsExpr Id TypecheckedPat
93 type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat
94 type TypecheckedStmt = Stmt Id TypecheckedPat
95 type TypecheckedMatch = Match Id TypecheckedPat
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
122 idsToMonoBinds :: [Id] -> TcMonoBinds
124 = andMonoBindList [ CoreMonoBind id (unfoldingTemplate (idUnfolding id))
129 %************************************************************************
131 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
133 %************************************************************************
135 This zonking pass runs over the bindings
137 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
138 b) convert unbound TcTyVar to Void
139 c) convert each TcId to an Id by zonking its type
141 The type variables are converted by binding mutable tyvars to immutable ones
142 and then zonking as normal.
144 The Ids are converted by binding them in the normal Tc envt; that
145 way we maintain sharing; eg an Id is zonked at its binding site and they
146 all occurrences of that Id point to the common zonked copy
148 It's all pretty boring stuff, because HsSyn is such a large type, and
149 the environment manipulation is tiresome.
152 -- zonkId is used *during* typechecking just to zonk the Id's type
153 zonkId :: TcId -> NF_TcM TcId
155 = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
156 returnNF_Tc (setIdType id ty')
158 -- zonkIdBndr is used *after* typechecking to get the Id's type
159 -- to its final form. The TyVarEnv give
160 zonkIdBndr :: TcId -> NF_TcM Id
162 = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' ->
163 returnNF_Tc (setIdType id ty')
165 zonkIdOcc :: TcId -> NF_TcM Id
167 | not (isLocalId id) || isIP id
168 -- We're avoiding looking up superclass selectors
169 -- and constructors; zonking them is a no-op anyway, and the
170 -- superclass selectors aren't in the environment anyway.
173 = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' ->
175 new_id = case maybe_id' of
176 Just (AnId id') -> id'
177 other -> pprTrace "zonkIdOcc:" (ppr id) id
184 zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
185 zonkTopBinds binds -- Top level is implicitly recursive
186 = fixNF_Tc (\ ~(_, new_ids) ->
187 tcExtendGlobalValEnv (bagToList new_ids) $
188 zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
189 tcGetEnv `thenNF_Tc` \ env ->
190 returnNF_Tc ((binds', env), new_ids)
191 ) `thenNF_Tc` \ (stuff, _) ->
194 zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
197 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
198 returnNF_Tc (binds', env))
201 -- -> (TypecheckedHsBinds
202 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
204 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
206 go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
208 thing_inside (b1' `ThenBinds` b2')
210 go EmptyBinds thing_inside = thing_inside EmptyBinds
212 go (MonoBind bind sigs is_rec) thing_inside
213 = ASSERT( null sigs )
214 fixNF_Tc (\ ~(_, new_ids) ->
215 tcExtendGlobalValEnv (bagToList new_ids) $
216 zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
217 thing_inside (mkMonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
218 returnNF_Tc (stuff, new_ids)
219 ) `thenNF_Tc` \ (stuff, _) ->
224 -------------------------------------------------------------------------
225 zonkMonoBinds :: TcMonoBinds
226 -> NF_TcM (TypecheckedMonoBinds, Bag Id)
228 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
230 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
231 = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
232 zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
233 returnNF_Tc (b1' `AndMonoBinds` b2',
234 ids1 `unionBags` ids2)
236 zonkMonoBinds (PatMonoBind pat grhss locn)
237 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
238 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
239 returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
241 zonkMonoBinds (VarMonoBind var expr)
242 = zonkIdBndr var `thenNF_Tc` \ new_var ->
243 zonkExpr expr `thenNF_Tc` \ new_expr ->
244 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
246 zonkMonoBinds (CoreMonoBind var core_expr)
247 = zonkIdBndr var `thenNF_Tc` \ new_var ->
248 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
250 zonkMonoBinds (FunMonoBind var inf ms locn)
251 = zonkIdBndr var `thenNF_Tc` \ new_var ->
252 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
253 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
256 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
257 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
258 -- No need to extend tyvar env: the effects are
259 -- propagated through binding the tyvars themselves
261 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
262 tcExtendGlobalValEnv new_dicts $
264 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
265 tcExtendGlobalValEnv (bagToList val_bind_ids) $
266 zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
267 mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports ->
268 returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
269 ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
271 new_globals = listToBag [global | (_, global, local) <- new_exports]
273 returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
276 zonkExport (tyvars, global, local)
277 = zonkTcSigTyVars tyvars `thenNF_Tc` \ new_tyvars ->
278 -- This isn't the binding occurrence of these tyvars
279 -- but they should *be* tyvars. Hence zonkTcSigTyVars.
280 zonkIdBndr global `thenNF_Tc` \ new_global ->
281 zonkIdOcc local `thenNF_Tc` \ new_local ->
282 returnNF_Tc (new_tyvars, new_global, new_local)
285 %************************************************************************
287 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
289 %************************************************************************
292 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
294 zonkMatch (Match _ pats _ grhss)
295 = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
296 tcExtendGlobalValEnv (bagToList new_ids) $
297 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
298 returnNF_Tc (Match [] new_pats Nothing new_grhss)
300 -------------------------------------------------------------------------
302 -> NF_TcM TypecheckedGRHSs
304 zonkGRHSs (GRHSs grhss binds (Just ty))
305 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
308 zonk_grhs (GRHS guarded locn)
309 = zonkStmts guarded `thenNF_Tc` \ new_guarded ->
310 returnNF_Tc (GRHS new_guarded locn)
312 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
313 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
314 returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
317 %************************************************************************
319 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
321 %************************************************************************
324 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
327 = zonkIdOcc id `thenNF_Tc` \ id' ->
328 returnNF_Tc (HsVar id')
330 zonkExpr (HsIPVar id)
331 = zonkIdOcc id `thenNF_Tc` \ id' ->
332 returnNF_Tc (HsIPVar id')
334 zonkExpr (HsLit (HsRat f ty))
335 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
336 returnNF_Tc (HsLit (HsRat f new_ty))
338 zonkExpr (HsLit (HsLitLit lit ty))
339 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
340 returnNF_Tc (HsLit (HsLitLit lit new_ty))
343 = returnNF_Tc (HsLit lit)
345 -- HsOverLit doesn't appear in typechecker output
347 zonkExpr (HsLam match)
348 = zonkMatch match `thenNF_Tc` \ new_match ->
349 returnNF_Tc (HsLam new_match)
351 zonkExpr (HsApp e1 e2)
352 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
353 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
354 returnNF_Tc (HsApp new_e1 new_e2)
356 zonkExpr (OpApp e1 op fixity e2)
357 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
358 zonkExpr op `thenNF_Tc` \ new_op ->
359 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
360 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
362 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
363 zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
365 zonkExpr (SectionL expr op)
366 = zonkExpr expr `thenNF_Tc` \ new_expr ->
367 zonkExpr op `thenNF_Tc` \ new_op ->
368 returnNF_Tc (SectionL new_expr new_op)
370 zonkExpr (SectionR op expr)
371 = zonkExpr op `thenNF_Tc` \ new_op ->
372 zonkExpr expr `thenNF_Tc` \ new_expr ->
373 returnNF_Tc (SectionR new_op new_expr)
375 zonkExpr (HsCase expr ms src_loc)
376 = zonkExpr expr `thenNF_Tc` \ new_expr ->
377 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
378 returnNF_Tc (HsCase new_expr new_ms src_loc)
380 zonkExpr (HsIf e1 e2 e3 src_loc)
381 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
382 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
383 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
384 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
386 zonkExpr (HsLet binds expr)
387 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
389 zonkExpr expr `thenNF_Tc` \ new_expr ->
390 returnNF_Tc (HsLet new_binds new_expr)
392 zonkExpr (HsWith expr binds)
393 = zonkIPBinds binds `thenNF_Tc` \ new_binds ->
394 tcExtendGlobalValEnv (map fst new_binds) $
395 zonkExpr expr `thenNF_Tc` \ new_expr ->
396 returnNF_Tc (HsWith new_expr new_binds)
398 zonkIPBinds = mapNF_Tc zonkIPBind
400 zonkIdBndr n `thenNF_Tc` \ n' ->
401 zonkExpr e `thenNF_Tc` \ e' ->
404 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
406 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
407 = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
408 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
409 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
410 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
411 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
412 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
415 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
417 zonkExpr (ExplicitListOut ty exprs)
418 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
419 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
420 returnNF_Tc (ExplicitListOut new_ty new_exprs)
422 zonkExpr (ExplicitTuple exprs boxed)
423 = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
424 returnNF_Tc (ExplicitTuple new_exprs boxed)
426 zonkExpr (RecordConOut data_con con_expr rbinds)
427 = zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
428 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
429 returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
431 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
433 zonkExpr (RecordUpdOut expr ty dicts rbinds)
434 = zonkExpr expr `thenNF_Tc` \ new_expr ->
435 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
436 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
437 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
438 returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
440 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
441 zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
443 zonkExpr (ArithSeqOut expr info)
444 = zonkExpr expr `thenNF_Tc` \ new_expr ->
445 zonkArithSeq info `thenNF_Tc` \ new_info ->
446 returnNF_Tc (ArithSeqOut new_expr new_info)
448 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
449 = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
450 zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
451 returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
453 zonkExpr (HsSCC lbl expr)
454 = zonkExpr expr `thenNF_Tc` \ new_expr ->
455 returnNF_Tc (HsSCC lbl new_expr)
457 zonkExpr (TyLam tyvars expr)
458 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
459 -- No need to extend tyvar env; see AbsBinds
461 zonkExpr expr `thenNF_Tc` \ new_expr ->
462 returnNF_Tc (TyLam new_tyvars new_expr)
464 zonkExpr (TyApp expr tys)
465 = zonkExpr expr `thenNF_Tc` \ new_expr ->
466 mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
467 returnNF_Tc (TyApp new_expr new_tys)
469 zonkExpr (DictLam dicts expr)
470 = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
471 tcExtendGlobalValEnv new_dicts $
472 zonkExpr expr `thenNF_Tc` \ new_expr ->
473 returnNF_Tc (DictLam new_dicts new_expr)
475 zonkExpr (DictApp expr dicts)
476 = zonkExpr expr `thenNF_Tc` \ new_expr ->
477 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
478 returnNF_Tc (DictApp new_expr new_dicts)
482 -------------------------------------------------------------------------
483 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
485 zonkArithSeq (From e)
486 = zonkExpr e `thenNF_Tc` \ new_e ->
487 returnNF_Tc (From new_e)
489 zonkArithSeq (FromThen e1 e2)
490 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
491 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
492 returnNF_Tc (FromThen new_e1 new_e2)
494 zonkArithSeq (FromTo e1 e2)
495 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
496 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
497 returnNF_Tc (FromTo new_e1 new_e2)
499 zonkArithSeq (FromThenTo e1 e2 e3)
500 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
501 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
502 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
503 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
505 -------------------------------------------------------------------------
506 zonkStmts :: [TcStmt]
507 -> NF_TcM [TypecheckedStmt]
509 zonkStmts [] = returnNF_Tc []
511 zonkStmts (ParStmtOut bndrstmtss : stmts)
512 = mapNF_Tc (mapNF_Tc zonkId) bndrss `thenNF_Tc` \ new_bndrss ->
513 let new_binders = concat new_bndrss in
514 mapNF_Tc zonkStmts stmtss `thenNF_Tc` \ new_stmtss ->
515 tcExtendGlobalValEnv new_binders $
516 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
517 returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
518 where (bndrss, stmtss) = unzip bndrstmtss
520 zonkStmts [ReturnStmt expr]
521 = zonkExpr expr `thenNF_Tc` \ new_expr ->
522 returnNF_Tc [ReturnStmt new_expr]
524 zonkStmts (ExprStmt expr locn : stmts)
525 = zonkExpr expr `thenNF_Tc` \ new_expr ->
526 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
527 returnNF_Tc (ExprStmt new_expr locn : new_stmts)
529 zonkStmts (GuardStmt expr locn : stmts)
530 = zonkExpr expr `thenNF_Tc` \ new_expr ->
531 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
532 returnNF_Tc (GuardStmt new_expr locn : new_stmts)
534 zonkStmts (LetStmt binds : stmts)
535 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
537 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
538 returnNF_Tc (LetStmt new_binds : new_stmts)
540 zonkStmts (BindStmt pat expr locn : stmts)
541 = zonkExpr expr `thenNF_Tc` \ new_expr ->
542 zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) ->
543 tcExtendGlobalValEnv (bagToList new_ids) $
544 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
545 returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
549 -------------------------------------------------------------------------
550 zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
553 = mapNF_Tc zonk_rbind rbinds
555 zonk_rbind (field, expr, pun)
556 = zonkExpr expr `thenNF_Tc` \ new_expr ->
557 zonkIdOcc field `thenNF_Tc` \ new_field ->
558 returnNF_Tc (new_field, new_expr, pun)
561 %************************************************************************
563 \subsection[BackSubst-Pats]{Patterns}
565 %************************************************************************
568 zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
571 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
572 returnNF_Tc (WildPat new_ty, emptyBag)
575 = zonkIdBndr v `thenNF_Tc` \ new_v ->
576 returnNF_Tc (VarPat new_v, unitBag new_v)
578 zonkPat (LazyPat pat)
579 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
580 returnNF_Tc (LazyPat new_pat, ids)
582 zonkPat (AsPat n pat)
583 = zonkIdBndr n `thenNF_Tc` \ new_n ->
584 zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
585 returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
587 zonkPat (ListPat ty pats)
588 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
589 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
590 returnNF_Tc (ListPat new_ty new_pats, ids)
592 zonkPat (TuplePat pats boxed)
593 = zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
594 returnNF_Tc (TuplePat new_pats boxed, ids)
596 zonkPat (ConPat n ty tvs dicts pats)
597 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
598 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
599 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
600 tcExtendGlobalValEnv new_dicts $
601 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
602 returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
603 listToBag new_dicts `unionBags` ids)
605 zonkPat (RecPat n ty tvs dicts rpats)
606 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
607 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
608 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
609 tcExtendGlobalValEnv new_dicts $
610 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
611 returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
612 listToBag new_dicts `unionBags` unionManyBags ids_s)
614 zonk_rpat (f, pat, pun)
615 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
616 returnNF_Tc ((f, new_pat, pun), ids)
618 zonkPat (LitPat lit ty)
619 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
620 returnNF_Tc (LitPat lit new_ty, emptyBag)
622 zonkPat (NPat lit ty expr)
623 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
624 zonkExpr expr `thenNF_Tc` \ new_expr ->
625 returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
627 zonkPat (NPlusKPat n k ty e1 e2)
628 = zonkIdBndr n `thenNF_Tc` \ new_n ->
629 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
630 zonkExpr e1 `thenNF_Tc` \ new_e1 ->
631 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
632 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
634 zonkPat (DictPat ds ms)
635 = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
636 mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
637 returnNF_Tc (DictPat new_ds new_ms,
638 listToBag new_ds `unionBags` listToBag new_ms)
642 = returnNF_Tc ([], emptyBag)
645 = zonkPat pat `thenNF_Tc` \ (pat', ids1) ->
646 zonkPats pats `thenNF_Tc` \ (pats', ids2) ->
647 returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
650 %************************************************************************
652 \subsection[BackSubst-Foreign]{Foreign exports}
654 %************************************************************************
658 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
659 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
661 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
662 zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
663 zonkIdOcc i `thenNF_Tc` \ i' ->
664 returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
668 zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
669 zonkRules rs = mapNF_Tc zonkRule rs
671 zonkRule (HsRule name tyvars vars lhs rhs loc)
672 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
673 mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars] `thenNF_Tc` \ new_bndrs ->
674 tcExtendGlobalValEnv new_bndrs $
675 zonkExpr lhs `thenNF_Tc` \ new_lhs ->
676 zonkExpr rhs `thenNF_Tc` \ new_rhs ->
677 returnNF_Tc (HsRule name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
678 -- I hate this map RuleBndr stuff
680 zonkRule (IfaceRuleOut fun rule)
681 = zonkIdOcc fun `thenNF_Tc` \ fun' ->
682 returnNF_Tc (IfaceRuleOut fun' rule)