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, idUnfolding, setIdType, omitIfaceSigForId, isIP, Id )
43 import DataCon ( dataConWrapId )
44 import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, tcGetEnv,
49 import TcType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars
51 import Name ( isLocallyDefined )
52 import CoreSyn ( Expr )
53 import CoreUnfold( unfoldingTemplate )
54 import BasicTypes ( RecFlag(..) )
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 (isLocallyDefined id) || omitIfaceSigForId id || isIP id
168 -- The omitIfaceSigForId thing may look wierd but it's quite
169 -- sensible really. We're avoiding looking up superclass selectors
170 -- and constructors; zonking them is a no-op anyway, and the
171 -- superclass selectors aren't in the environment anyway.
174 = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' ->
176 new_id = case maybe_id' of
177 Just (AnId id') -> id'
178 other -> pprTrace "zonkIdOcc: " (ppr id) id
185 zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
186 zonkTopBinds binds -- Top level is implicitly recursive
187 = fixNF_Tc (\ ~(_, new_ids) ->
188 tcExtendGlobalValEnv (bagToList new_ids) $
189 zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
190 tcGetEnv `thenNF_Tc` \ env ->
191 returnNF_Tc ((binds', env), new_ids)
192 ) `thenNF_Tc` \ (stuff, _) ->
195 zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
198 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
199 returnNF_Tc (binds', env))
202 -- -> (TypecheckedHsBinds
203 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
205 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
207 go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
209 thing_inside (b1' `ThenBinds` b2')
211 go EmptyBinds thing_inside = thing_inside EmptyBinds
213 go (MonoBind bind sigs is_rec) thing_inside
214 = ASSERT( null sigs )
215 fixNF_Tc (\ ~(_, new_ids) ->
216 tcExtendGlobalValEnv (bagToList new_ids) $
217 zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
218 thing_inside (mkMonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
219 returnNF_Tc (stuff, new_ids)
220 ) `thenNF_Tc` \ (stuff, _) ->
225 -------------------------------------------------------------------------
226 zonkMonoBinds :: TcMonoBinds
227 -> NF_TcM (TypecheckedMonoBinds, Bag Id)
229 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
231 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
232 = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
233 zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
234 returnNF_Tc (b1' `AndMonoBinds` b2',
235 ids1 `unionBags` ids2)
237 zonkMonoBinds (PatMonoBind pat grhss locn)
238 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
239 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
240 returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
242 zonkMonoBinds (VarMonoBind var expr)
243 = zonkIdBndr var `thenNF_Tc` \ new_var ->
244 zonkExpr expr `thenNF_Tc` \ new_expr ->
245 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
247 zonkMonoBinds (CoreMonoBind var core_expr)
248 = zonkIdBndr var `thenNF_Tc` \ new_var ->
249 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
251 zonkMonoBinds (FunMonoBind var inf ms locn)
252 = zonkIdBndr var `thenNF_Tc` \ new_var ->
253 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
254 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
257 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
258 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
259 -- No need to extend tyvar env: the effects are
260 -- propagated through binding the tyvars themselves
262 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
263 tcExtendGlobalValEnv new_dicts $
265 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
266 tcExtendGlobalValEnv (bagToList val_bind_ids) $
267 zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
268 mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports ->
269 returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
270 ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
272 new_globals = listToBag [global | (_, global, local) <- new_exports]
274 returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
277 zonkExport (tyvars, global, local)
278 = zonkTcSigTyVars tyvars `thenNF_Tc` \ new_tyvars ->
279 -- This isn't the binding occurrence of these tyvars
280 -- but they should *be* tyvars. Hence zonkTcSigTyVars.
281 zonkIdBndr global `thenNF_Tc` \ new_global ->
282 zonkIdOcc local `thenNF_Tc` \ new_local ->
283 returnNF_Tc (new_tyvars, new_global, new_local)
286 %************************************************************************
288 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
290 %************************************************************************
293 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
295 zonkMatch (Match _ pats _ grhss)
296 = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
297 tcExtendGlobalValEnv (bagToList new_ids) $
298 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
299 returnNF_Tc (Match [] new_pats Nothing new_grhss)
301 -------------------------------------------------------------------------
303 -> NF_TcM TypecheckedGRHSs
305 zonkGRHSs (GRHSs grhss binds (Just ty))
306 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
309 zonk_grhs (GRHS guarded locn)
310 = zonkStmts guarded `thenNF_Tc` \ new_guarded ->
311 returnNF_Tc (GRHS new_guarded locn)
313 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
314 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
315 returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
318 %************************************************************************
320 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
322 %************************************************************************
325 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
328 = zonkIdOcc id `thenNF_Tc` \ id' ->
329 returnNF_Tc (HsVar id')
331 zonkExpr (HsIPVar id)
332 = zonkIdOcc id `thenNF_Tc` \ id' ->
333 returnNF_Tc (HsIPVar id')
335 zonkExpr (HsLit (HsRat f ty))
336 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
337 returnNF_Tc (HsLit (HsRat f new_ty))
339 zonkExpr (HsLit (HsLitLit lit ty))
340 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
341 returnNF_Tc (HsLit (HsLitLit lit new_ty))
344 = returnNF_Tc (HsLit lit)
346 -- HsOverLit doesn't appear in typechecker output
348 zonkExpr (HsLam match)
349 = zonkMatch match `thenNF_Tc` \ new_match ->
350 returnNF_Tc (HsLam new_match)
352 zonkExpr (HsApp e1 e2)
353 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
354 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
355 returnNF_Tc (HsApp new_e1 new_e2)
357 zonkExpr (OpApp e1 op fixity e2)
358 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
359 zonkExpr op `thenNF_Tc` \ new_op ->
360 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
361 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
363 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
364 zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
366 zonkExpr (SectionL expr op)
367 = zonkExpr expr `thenNF_Tc` \ new_expr ->
368 zonkExpr op `thenNF_Tc` \ new_op ->
369 returnNF_Tc (SectionL new_expr new_op)
371 zonkExpr (SectionR op expr)
372 = zonkExpr op `thenNF_Tc` \ new_op ->
373 zonkExpr expr `thenNF_Tc` \ new_expr ->
374 returnNF_Tc (SectionR new_op new_expr)
376 zonkExpr (HsCase expr ms src_loc)
377 = zonkExpr expr `thenNF_Tc` \ new_expr ->
378 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
379 returnNF_Tc (HsCase new_expr new_ms src_loc)
381 zonkExpr (HsIf e1 e2 e3 src_loc)
382 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
383 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
384 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
385 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
387 zonkExpr (HsLet binds expr)
388 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
390 zonkExpr expr `thenNF_Tc` \ new_expr ->
391 returnNF_Tc (HsLet new_binds new_expr)
393 zonkExpr (HsWith expr binds)
394 = zonkIPBinds binds `thenNF_Tc` \ new_binds ->
395 tcExtendGlobalValEnv (map fst new_binds) $
396 zonkExpr expr `thenNF_Tc` \ new_expr ->
397 returnNF_Tc (HsWith new_expr new_binds)
399 zonkIPBinds = mapNF_Tc zonkIPBind
401 zonkIdBndr n `thenNF_Tc` \ n' ->
402 zonkExpr e `thenNF_Tc` \ e' ->
405 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
407 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
408 = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
409 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
410 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
411 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
412 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
413 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
416 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
418 zonkExpr (ExplicitListOut ty exprs)
419 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
420 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
421 returnNF_Tc (ExplicitListOut new_ty new_exprs)
423 zonkExpr (ExplicitTuple exprs boxed)
424 = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
425 returnNF_Tc (ExplicitTuple new_exprs boxed)
427 zonkExpr (RecordConOut data_con con_expr rbinds)
428 = zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
429 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
430 returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
432 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
434 zonkExpr (RecordUpdOut expr ty dicts rbinds)
435 = zonkExpr expr `thenNF_Tc` \ new_expr ->
436 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
437 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
438 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
439 returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
441 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
442 zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
444 zonkExpr (ArithSeqOut expr info)
445 = zonkExpr expr `thenNF_Tc` \ new_expr ->
446 zonkArithSeq info `thenNF_Tc` \ new_info ->
447 returnNF_Tc (ArithSeqOut new_expr new_info)
449 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
450 = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
451 zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
452 returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
454 zonkExpr (HsSCC lbl expr)
455 = zonkExpr expr `thenNF_Tc` \ new_expr ->
456 returnNF_Tc (HsSCC lbl new_expr)
458 zonkExpr (TyLam tyvars expr)
459 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
460 -- No need to extend tyvar env; see AbsBinds
462 zonkExpr expr `thenNF_Tc` \ new_expr ->
463 returnNF_Tc (TyLam new_tyvars new_expr)
465 zonkExpr (TyApp expr tys)
466 = zonkExpr expr `thenNF_Tc` \ new_expr ->
467 mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
468 returnNF_Tc (TyApp new_expr new_tys)
470 zonkExpr (DictLam dicts expr)
471 = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
472 tcExtendGlobalValEnv new_dicts $
473 zonkExpr expr `thenNF_Tc` \ new_expr ->
474 returnNF_Tc (DictLam new_dicts new_expr)
476 zonkExpr (DictApp expr dicts)
477 = zonkExpr expr `thenNF_Tc` \ new_expr ->
478 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
479 returnNF_Tc (DictApp new_expr new_dicts)
483 -------------------------------------------------------------------------
484 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
486 zonkArithSeq (From e)
487 = zonkExpr e `thenNF_Tc` \ new_e ->
488 returnNF_Tc (From new_e)
490 zonkArithSeq (FromThen e1 e2)
491 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
492 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
493 returnNF_Tc (FromThen new_e1 new_e2)
495 zonkArithSeq (FromTo e1 e2)
496 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
497 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
498 returnNF_Tc (FromTo new_e1 new_e2)
500 zonkArithSeq (FromThenTo e1 e2 e3)
501 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
502 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
503 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
504 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
506 -------------------------------------------------------------------------
507 zonkStmts :: [TcStmt]
508 -> NF_TcM [TypecheckedStmt]
510 zonkStmts [] = returnNF_Tc []
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)