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 ( DataCon, dataConWrapId, splitProductType_maybe )
44 import TcEnv ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv,
45 ValueEnv, TcId, tcInstId
49 import TcType ( TcType, TcTyVar,
50 zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
52 import Type ( mkTyVarTy, isUnLiftedType, Type )
53 import Name ( isLocallyDefined )
55 import VarEnv ( TyVarEnv, emptyVarEnv, extendVarEnvList )
56 import VarSet ( isEmptyVarSet )
57 import CoreSyn ( Expr )
58 import CoreUnfold( unfoldingTemplate )
59 import BasicTypes ( RecFlag(..) )
69 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
70 All the types in @Tc...@ things have mutable type-variables in them for
73 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
74 which have immutable type variables in them.
77 type TcHsBinds = HsBinds TcId TcPat
78 type TcMonoBinds = MonoBinds TcId TcPat
79 type TcDictBinds = TcMonoBinds
80 type TcPat = OutPat TcId
81 type TcExpr = HsExpr TcId TcPat
82 type TcGRHSs = GRHSs TcId TcPat
83 type TcGRHS = GRHS TcId TcPat
84 type TcMatch = Match TcId TcPat
85 type TcStmt = Stmt TcId TcPat
86 type TcArithSeqInfo = ArithSeqInfo TcId TcPat
87 type TcRecordBinds = HsRecordBinds TcId TcPat
88 type TcHsModule = HsModule TcId TcPat
90 type TcCoreExpr = Expr TcId
91 type TcForeignExportDecl = ForeignDecl TcId
92 type TcRuleDecl = RuleDecl TcId TcPat
94 type TypecheckedPat = OutPat Id
95 type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
96 type TypecheckedDictBinds = TypecheckedMonoBinds
97 type TypecheckedHsBinds = HsBinds Id TypecheckedPat
98 type TypecheckedHsExpr = HsExpr Id TypecheckedPat
99 type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat
100 type TypecheckedStmt = Stmt Id TypecheckedPat
101 type TypecheckedMatch = Match Id TypecheckedPat
102 type TypecheckedGRHSs = GRHSs Id TypecheckedPat
103 type TypecheckedGRHS = GRHS Id TypecheckedPat
104 type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
105 type TypecheckedHsModule = HsModule Id TypecheckedPat
106 type TypecheckedForeignDecl = ForeignDecl Id
107 type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
111 mkHsTyApp expr [] = expr
112 mkHsTyApp expr tys = TyApp expr tys
114 mkHsDictApp expr [] = expr
115 mkHsDictApp expr dict_vars = DictApp expr dict_vars
117 mkHsTyLam [] expr = expr
118 mkHsTyLam tyvars expr = TyLam tyvars expr
120 mkHsDictLam [] expr = expr
121 mkHsDictLam dicts expr = DictLam dicts expr
123 mkHsLet EmptyMonoBinds expr = expr
124 mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
126 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
128 idsToMonoBinds :: [Id] -> TcMonoBinds
130 = andMonoBindList [ CoreMonoBind id (unfoldingTemplate (idUnfolding id))
135 %************************************************************************
137 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
139 %************************************************************************
141 This zonking pass runs over the bindings
143 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
144 b) convert unbound TcTyVar to Void
145 c) convert each TcId to an Id by zonking its type
147 The type variables are converted by binding mutable tyvars to immutable ones
148 and then zonking as normal.
150 The Ids are converted by binding them in the normal Tc envt; that
151 way we maintain sharing; eg an Id is zonked at its binding site and they
152 all occurrences of that Id point to the common zonked copy
154 It's all pretty boring stuff, because HsSyn is such a large type, and
155 the environment manipulation is tiresome.
158 -- zonkId is used *during* typechecking just to zonk the Id's type
159 zonkId :: TcId -> NF_TcM s TcId
161 = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
162 returnNF_Tc (setIdType id ty')
164 -- zonkIdBndr is used *after* typechecking to get the Id's type
165 -- to its final form. The TyVarEnv give
166 zonkIdBndr :: TcId -> NF_TcM s Id
168 = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' ->
169 returnNF_Tc (setIdType id ty')
171 zonkIdOcc :: TcId -> NF_TcM s Id
173 | not (isLocallyDefined id) || omitIfaceSigForId id || isIP id
174 -- The omitIfaceSigForId thing may look wierd but it's quite
175 -- sensible really. We're avoiding looking up superclass selectors
176 -- and constructors; zonking them is a no-op anyway, and the
177 -- superclass selectors aren't in the environment anyway.
180 = tcLookupValueMaybe (idName id) `thenNF_Tc` \ maybe_id' ->
182 new_id = case maybe_id' of
184 Nothing -> pprTrace "zonkIdOcc: " (ppr id) id
191 zonkTopBinds :: TcMonoBinds -> NF_TcM s (TypecheckedMonoBinds, ValueEnv)
192 zonkTopBinds binds -- Top level is implicitly recursive
193 = fixNF_Tc (\ ~(_, new_ids) ->
194 tcExtendGlobalValEnv (bagToList new_ids) $
195 zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
196 tcGetValueEnv `thenNF_Tc` \ env ->
197 returnNF_Tc ((binds', env), new_ids)
198 ) `thenNF_Tc` \ (stuff, _) ->
201 zonkBinds :: TcHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv)
204 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
205 returnNF_Tc (binds', env))
208 -- -> (TypecheckedHsBinds
209 -- -> NF_TcM s (TypecheckedHsBinds, TcEnv)
211 -- -> NF_TcM s (TypecheckedHsBinds, TcEnv)
213 go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
215 thing_inside (b1' `ThenBinds` b2')
217 go EmptyBinds thing_inside = thing_inside EmptyBinds
219 go (MonoBind bind sigs is_rec) thing_inside
220 = ASSERT( null sigs )
221 fixNF_Tc (\ ~(_, new_ids) ->
222 tcExtendGlobalValEnv (bagToList new_ids) $
223 zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
224 thing_inside (mkMonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
225 returnNF_Tc (stuff, new_ids)
226 ) `thenNF_Tc` \ (stuff, _) ->
231 -------------------------------------------------------------------------
232 zonkMonoBinds :: TcMonoBinds
233 -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
235 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
237 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
238 = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
239 zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
240 returnNF_Tc (b1' `AndMonoBinds` b2',
241 ids1 `unionBags` ids2)
243 zonkMonoBinds (PatMonoBind pat grhss locn)
244 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
245 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
246 returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
248 zonkMonoBinds (VarMonoBind var expr)
249 = zonkIdBndr var `thenNF_Tc` \ new_var ->
250 zonkExpr expr `thenNF_Tc` \ new_expr ->
251 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
253 zonkMonoBinds (CoreMonoBind var core_expr)
254 = zonkIdBndr var `thenNF_Tc` \ new_var ->
255 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
257 zonkMonoBinds (FunMonoBind var inf ms locn)
258 = zonkIdBndr var `thenNF_Tc` \ new_var ->
259 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
260 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
263 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
264 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
265 -- No need to extend tyvar env: the effects are
266 -- propagated through binding the tyvars themselves
268 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
269 tcExtendGlobalValEnv new_dicts $
271 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
272 tcExtendGlobalValEnv (bagToList val_bind_ids) $
273 zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
274 mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports ->
275 returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
276 ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
278 new_globals = listToBag [global | (_, global, local) <- new_exports]
280 returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
283 zonkExport (tyvars, global, local)
284 = mapNF_Tc zonkTcTyVarBndr tyvars `thenNF_Tc` \ new_tyvars ->
285 zonkIdBndr global `thenNF_Tc` \ new_global ->
286 zonkIdOcc local `thenNF_Tc` \ new_local ->
287 returnNF_Tc (new_tyvars, new_global, new_local)
290 %************************************************************************
292 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
294 %************************************************************************
297 zonkMatch :: TcMatch -> NF_TcM s TypecheckedMatch
299 zonkMatch (Match _ pats _ grhss)
300 = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
301 tcExtendGlobalValEnv (bagToList new_ids) $
302 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
303 returnNF_Tc (Match [] new_pats Nothing new_grhss)
305 -------------------------------------------------------------------------
307 -> NF_TcM s TypecheckedGRHSs
309 zonkGRHSs (GRHSs grhss binds (Just ty))
310 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
313 zonk_grhs (GRHS guarded locn)
314 = zonkStmts guarded `thenNF_Tc` \ new_guarded ->
315 returnNF_Tc (GRHS new_guarded locn)
317 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
318 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
319 returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
322 %************************************************************************
324 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
326 %************************************************************************
329 zonkExpr :: TcExpr -> NF_TcM s TypecheckedHsExpr
332 = zonkIdOcc id `thenNF_Tc` \ id' ->
333 returnNF_Tc (HsVar id')
335 zonkExpr (HsIPVar id)
336 = zonkIdOcc id `thenNF_Tc` \ id' ->
337 returnNF_Tc (HsIPVar id')
339 zonkExpr (HsLit _) = panic "zonkExpr:HsLit"
341 zonkExpr (HsLitOut lit ty)
342 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
343 returnNF_Tc (HsLitOut lit new_ty)
345 zonkExpr (HsLam match)
346 = zonkMatch match `thenNF_Tc` \ new_match ->
347 returnNF_Tc (HsLam new_match)
349 zonkExpr (HsApp e1 e2)
350 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
351 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
352 returnNF_Tc (HsApp new_e1 new_e2)
354 zonkExpr (OpApp e1 op fixity e2)
355 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
356 zonkExpr op `thenNF_Tc` \ new_op ->
357 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
358 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
360 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
361 zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
363 zonkExpr (SectionL expr op)
364 = zonkExpr expr `thenNF_Tc` \ new_expr ->
365 zonkExpr op `thenNF_Tc` \ new_op ->
366 returnNF_Tc (SectionL new_expr new_op)
368 zonkExpr (SectionR op expr)
369 = zonkExpr op `thenNF_Tc` \ new_op ->
370 zonkExpr expr `thenNF_Tc` \ new_expr ->
371 returnNF_Tc (SectionR new_op new_expr)
373 zonkExpr (HsCase expr ms src_loc)
374 = zonkExpr expr `thenNF_Tc` \ new_expr ->
375 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
376 returnNF_Tc (HsCase new_expr new_ms src_loc)
378 zonkExpr (HsIf e1 e2 e3 src_loc)
379 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
380 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
381 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
382 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
384 zonkExpr (HsLet binds expr)
385 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
387 zonkExpr expr `thenNF_Tc` \ new_expr ->
388 returnNF_Tc (HsLet new_binds new_expr)
390 zonkExpr (HsWith expr binds)
391 = zonkExpr expr `thenNF_Tc` \ new_expr ->
392 zonkIPBinds binds `thenNF_Tc` \ new_binds ->
393 returnNF_Tc (HsWith new_expr new_binds)
395 zonkIPBinds = mapNF_Tc zonkIPBind
397 zonkExpr e `thenNF_Tc` \ e' ->
400 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
402 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
403 = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
404 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
405 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
406 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
407 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
408 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
411 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
413 zonkExpr (ExplicitListOut ty exprs)
414 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
415 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
416 returnNF_Tc (ExplicitListOut new_ty new_exprs)
418 zonkExpr (ExplicitTuple exprs boxed)
419 = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
420 returnNF_Tc (ExplicitTuple new_exprs boxed)
422 zonkExpr (RecordConOut data_con con_expr rbinds)
423 = zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
424 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
425 returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
427 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
429 zonkExpr (RecordUpdOut expr ty dicts rbinds)
430 = zonkExpr expr `thenNF_Tc` \ new_expr ->
431 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
432 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
433 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
434 returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
436 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
437 zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
439 zonkExpr (ArithSeqOut expr info)
440 = zonkExpr expr `thenNF_Tc` \ new_expr ->
441 zonkArithSeq info `thenNF_Tc` \ new_info ->
442 returnNF_Tc (ArithSeqOut new_expr new_info)
444 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
445 = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
446 zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
447 returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
449 zonkExpr (HsSCC lbl expr)
450 = zonkExpr expr `thenNF_Tc` \ new_expr ->
451 returnNF_Tc (HsSCC lbl new_expr)
453 zonkExpr (TyLam tyvars expr)
454 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
455 -- No need to extend tyvar env; see AbsBinds
457 zonkExpr expr `thenNF_Tc` \ new_expr ->
458 returnNF_Tc (TyLam new_tyvars new_expr)
460 zonkExpr (TyApp expr tys)
461 = zonkExpr expr `thenNF_Tc` \ new_expr ->
462 mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
463 returnNF_Tc (TyApp new_expr new_tys)
465 zonkExpr (DictLam dicts expr)
466 = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
467 tcExtendGlobalValEnv new_dicts $
468 zonkExpr expr `thenNF_Tc` \ new_expr ->
469 returnNF_Tc (DictLam new_dicts new_expr)
471 zonkExpr (DictApp expr dicts)
472 = zonkExpr expr `thenNF_Tc` \ new_expr ->
473 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
474 returnNF_Tc (DictApp new_expr new_dicts)
478 -------------------------------------------------------------------------
479 zonkArithSeq :: TcArithSeqInfo -> NF_TcM s TypecheckedArithSeqInfo
481 zonkArithSeq (From e)
482 = zonkExpr e `thenNF_Tc` \ new_e ->
483 returnNF_Tc (From new_e)
485 zonkArithSeq (FromThen e1 e2)
486 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
487 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
488 returnNF_Tc (FromThen new_e1 new_e2)
490 zonkArithSeq (FromTo e1 e2)
491 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
492 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
493 returnNF_Tc (FromTo new_e1 new_e2)
495 zonkArithSeq (FromThenTo e1 e2 e3)
496 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
497 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
498 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
499 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
501 -------------------------------------------------------------------------
502 zonkStmts :: [TcStmt]
503 -> NF_TcM s [TypecheckedStmt]
505 zonkStmts [] = returnNF_Tc []
507 zonkStmts [ReturnStmt expr]
508 = zonkExpr expr `thenNF_Tc` \ new_expr ->
509 returnNF_Tc [ReturnStmt new_expr]
511 zonkStmts (ExprStmt expr locn : stmts)
512 = zonkExpr expr `thenNF_Tc` \ new_expr ->
513 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
514 returnNF_Tc (ExprStmt new_expr locn : new_stmts)
516 zonkStmts (GuardStmt expr locn : stmts)
517 = zonkExpr expr `thenNF_Tc` \ new_expr ->
518 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
519 returnNF_Tc (GuardStmt new_expr locn : new_stmts)
521 zonkStmts (LetStmt binds : stmts)
522 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
524 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
525 returnNF_Tc (LetStmt new_binds : new_stmts)
527 zonkStmts (BindStmt pat expr locn : stmts)
528 = zonkExpr expr `thenNF_Tc` \ new_expr ->
529 zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) ->
530 tcExtendGlobalValEnv (bagToList new_ids) $
531 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
532 returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
536 -------------------------------------------------------------------------
537 zonkRbinds :: TcRecordBinds -> NF_TcM s TypecheckedRecordBinds
540 = mapNF_Tc zonk_rbind rbinds
542 zonk_rbind (field, expr, pun)
543 = zonkExpr expr `thenNF_Tc` \ new_expr ->
544 zonkIdOcc field `thenNF_Tc` \ new_field ->
545 returnNF_Tc (new_field, new_expr, pun)
548 %************************************************************************
550 \subsection[BackSubst-Pats]{Patterns}
552 %************************************************************************
555 zonkPat :: TcPat -> NF_TcM s (TypecheckedPat, Bag Id)
558 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
559 returnNF_Tc (WildPat new_ty, emptyBag)
562 = zonkIdBndr v `thenNF_Tc` \ new_v ->
563 returnNF_Tc (VarPat new_v, unitBag new_v)
565 zonkPat (LazyPat pat)
566 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
567 returnNF_Tc (LazyPat new_pat, ids)
569 zonkPat (AsPat n pat)
570 = zonkIdBndr n `thenNF_Tc` \ new_n ->
571 zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
572 returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
574 zonkPat (ListPat ty pats)
575 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
576 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
577 returnNF_Tc (ListPat new_ty new_pats, ids)
579 zonkPat (TuplePat pats boxed)
580 = zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
581 returnNF_Tc (TuplePat new_pats boxed, ids)
583 zonkPat (ConPat n ty tvs dicts pats)
584 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
585 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
586 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
587 tcExtendGlobalValEnv new_dicts $
588 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
589 returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
590 listToBag new_dicts `unionBags` ids)
592 zonkPat (RecPat n ty tvs dicts rpats)
593 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
594 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
595 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
596 tcExtendGlobalValEnv new_dicts $
597 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
598 returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
599 listToBag new_dicts `unionBags` unionManyBags ids_s)
601 zonk_rpat (f, pat, pun)
602 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
603 returnNF_Tc ((f, new_pat, pun), ids)
605 zonkPat (LitPat lit ty)
606 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
607 returnNF_Tc (LitPat lit new_ty, emptyBag)
609 zonkPat (NPat lit ty expr)
610 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
611 zonkExpr expr `thenNF_Tc` \ new_expr ->
612 returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
614 zonkPat (NPlusKPat n k ty e1 e2)
615 = zonkIdBndr n `thenNF_Tc` \ new_n ->
616 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
617 zonkExpr e1 `thenNF_Tc` \ new_e1 ->
618 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
619 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
621 zonkPat (DictPat ds ms)
622 = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
623 mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
624 returnNF_Tc (DictPat new_ds new_ms,
625 listToBag new_ds `unionBags` listToBag new_ms)
629 = returnNF_Tc ([], emptyBag)
632 = zonkPat pat `thenNF_Tc` \ (pat', ids1) ->
633 zonkPats pats `thenNF_Tc` \ (pats', ids2) ->
634 returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
637 %************************************************************************
639 \subsection[BackSubst-Foreign]{Foreign exports}
641 %************************************************************************
645 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM s [TypecheckedForeignDecl]
646 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
648 zonkForeignExport :: TcForeignExportDecl -> NF_TcM s (TypecheckedForeignDecl)
649 zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
650 zonkIdOcc i `thenNF_Tc` \ i' ->
651 returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
655 zonkRules :: [TcRuleDecl] -> NF_TcM s [TypecheckedRuleDecl]
656 zonkRules rs = mapNF_Tc zonkRule rs
658 zonkRule (RuleDecl name tyvars vars lhs rhs loc)
659 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
660 mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars] `thenNF_Tc` \ new_bndrs ->
661 tcExtendGlobalValEnv new_bndrs $
662 zonkExpr lhs `thenNF_Tc` \ new_lhs ->
663 zonkExpr rhs `thenNF_Tc` \ new_rhs ->
664 returnNF_Tc (RuleDecl name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
665 -- I hate this map RuleBndr stuff
667 zonkRule (IfaceRuleDecl fun rule loc)
668 = returnNF_Tc (IfaceRuleDecl fun rule loc)