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,
26 mkHsTyLam, mkHsDictLam, mkHsLet,
28 -- re-exported from TcEnv
33 zonkTopBinds, zonkId, zonkIdOcc,
34 zonkForeignExports, zonkRules
37 #include "HsVersions.h"
40 import HsSyn -- oodles of it
43 import Id ( idName, idType, setIdType, omitIfaceSigForId, Id )
44 import DataCon ( DataCon, splitProductType_maybe )
45 import TcEnv ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv,
46 ValueEnv, TcId, tcInstId
50 import TcType ( TcType, TcTyVar,
51 zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
53 import TyCon ( isDataTyCon )
54 import Type ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type )
55 import Name ( isLocallyDefined )
57 import VarEnv ( TyVarEnv, emptyVarEnv, extendVarEnvList )
58 import VarSet ( isEmptyVarSet )
59 import CoreSyn ( Expr )
60 import BasicTypes ( RecFlag(..) )
70 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
71 All the types in @Tc...@ things have mutable type-variables in them for
74 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
75 which have immutable type variables in them.
78 type TcHsBinds = HsBinds TcId TcPat
79 type TcMonoBinds = MonoBinds TcId TcPat
80 type TcDictBinds = TcMonoBinds
81 type TcPat = OutPat TcId
82 type TcExpr = HsExpr TcId TcPat
83 type TcGRHSs = GRHSs TcId TcPat
84 type TcGRHS = GRHS TcId TcPat
85 type TcMatch = Match TcId TcPat
86 type TcStmt = Stmt TcId TcPat
87 type TcArithSeqInfo = ArithSeqInfo TcId TcPat
88 type TcRecordBinds = HsRecordBinds TcId TcPat
89 type TcHsModule = HsModule TcId TcPat
91 type TcCoreExpr = Expr TcId
92 type TcForeignExportDecl = ForeignDecl TcId
93 type TcRuleDecl = RuleDecl TcId TcPat
95 type TypecheckedPat = OutPat Id
96 type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
97 type TypecheckedDictBinds = TypecheckedMonoBinds
98 type TypecheckedHsBinds = HsBinds Id TypecheckedPat
99 type TypecheckedHsExpr = HsExpr Id TypecheckedPat
100 type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat
101 type TypecheckedStmt = Stmt Id TypecheckedPat
102 type TypecheckedMatch = Match Id TypecheckedPat
103 type TypecheckedGRHSs = GRHSs Id TypecheckedPat
104 type TypecheckedGRHS = GRHS Id TypecheckedPat
105 type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
106 type TypecheckedHsModule = HsModule Id TypecheckedPat
107 type TypecheckedForeignDecl = ForeignDecl Id
108 type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
112 mkHsTyApp expr [] = expr
113 mkHsTyApp expr tys = TyApp expr tys
115 mkHsDictApp expr [] = expr
116 mkHsDictApp expr dict_vars = DictApp expr dict_vars
118 mkHsTyLam [] expr = expr
119 mkHsTyLam tyvars expr = TyLam tyvars expr
121 mkHsDictLam [] expr = expr
122 mkHsDictLam dicts expr = DictLam dicts expr
124 mkHsLet EmptyMonoBinds expr = expr
125 mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
128 %************************************************************************
130 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
132 %************************************************************************
134 Some gruesome hackery for desugaring ccalls. It's here because if we put it
135 in Type.lhs we get irritating loops, and it's only used by TcInstDcls.lhs and
139 maybeBoxedPrimType :: Type -> Maybe (DataCon, Type)
140 maybeBoxedPrimType ty
141 = case splitProductType_maybe ty of -- Product data type
142 Just (tycon, tys_applied, data_con, [data_con_arg_ty]) -- constr has one arg
143 | isUnLiftedType data_con_arg_ty -- which is primitive
144 -> Just (data_con, data_con_arg_ty)
146 other_cases -> Nothing
149 %************************************************************************
151 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
153 %************************************************************************
155 This zonking pass runs over the bindings
157 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
158 b) convert unbound TcTyVar to Void
159 c) convert each TcId to an Id by zonking its type
161 The type variables are converted by binding mutable tyvars to immutable ones
162 and then zonking as normal.
164 The Ids are converted by binding them in the normal Tc envt; that
165 way we maintain sharing; eg an Id is zonked at its binding site and they
166 all occurrences of that Id point to the common zonked copy
168 It's all pretty boring stuff, because HsSyn is such a large type, and
169 the environment manipulation is tiresome.
172 -- zonkId is used *during* typechecking just to zonk the Id's type
173 zonkId :: TcId -> NF_TcM s TcId
175 = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
176 returnNF_Tc (setIdType id ty')
178 -- zonkIdBndr is used *after* typechecking to get the Id's type
179 -- to its final form. The TyVarEnv give
180 zonkIdBndr :: TcId -> NF_TcM s Id
182 = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' ->
183 returnNF_Tc (setIdType id ty')
185 zonkIdOcc :: TcId -> NF_TcM s Id
187 | not (isLocallyDefined id) || omitIfaceSigForId id
188 -- The omitIfaceSigForId thing may look wierd but it's quite
189 -- sensible really. We're avoiding looking up superclass selectors
190 -- and constructors; zonking them is a no-op anyway, and the
191 -- superclass selectors aren't in the environment anyway.
194 = tcLookupValueMaybe (idName id) `thenNF_Tc` \ maybe_id' ->
196 new_id = case maybe_id' of
198 Nothing -> pprTrace "zonkIdOcc: " (ppr id) id
205 zonkTopBinds :: TcMonoBinds -> NF_TcM s (TypecheckedMonoBinds, ValueEnv)
206 zonkTopBinds binds -- Top level is implicitly recursive
207 = fixNF_Tc (\ ~(_, new_ids) ->
208 tcExtendGlobalValEnv (bagToList new_ids) $
209 zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
210 tcGetValueEnv `thenNF_Tc` \ env ->
211 returnNF_Tc ((binds', env), new_ids)
212 ) `thenNF_Tc` \ (stuff, _) ->
215 zonkBinds :: TcHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv)
218 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
219 returnNF_Tc (binds', env))
222 -- -> (TypecheckedHsBinds
223 -- -> NF_TcM s (TypecheckedHsBinds, TcEnv)
225 -- -> NF_TcM s (TypecheckedHsBinds, TcEnv)
227 go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
229 thing_inside (b1' `ThenBinds` b2')
231 go EmptyBinds thing_inside = thing_inside EmptyBinds
233 go (MonoBind bind sigs is_rec) thing_inside
234 = ASSERT( null sigs )
235 fixNF_Tc (\ ~(_, new_ids) ->
236 tcExtendGlobalValEnv (bagToList new_ids) $
237 zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
238 thing_inside (mkMonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
239 returnNF_Tc (stuff, new_ids)
240 ) `thenNF_Tc` \ (stuff, _) ->
245 -------------------------------------------------------------------------
246 zonkMonoBinds :: TcMonoBinds
247 -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
249 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
251 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
252 = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
253 zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
254 returnNF_Tc (b1' `AndMonoBinds` b2',
255 ids1 `unionBags` ids2)
257 zonkMonoBinds (PatMonoBind pat grhss locn)
258 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
259 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
260 returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
262 zonkMonoBinds (VarMonoBind var expr)
263 = zonkIdBndr var `thenNF_Tc` \ new_var ->
264 zonkExpr expr `thenNF_Tc` \ new_expr ->
265 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
267 zonkMonoBinds (CoreMonoBind var core_expr)
268 = zonkIdBndr var `thenNF_Tc` \ new_var ->
269 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
271 zonkMonoBinds (FunMonoBind var inf ms locn)
272 = zonkIdBndr var `thenNF_Tc` \ new_var ->
273 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
274 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
277 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
278 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
279 -- No need to extend tyvar env: the effects are
280 -- propagated through binding the tyvars themselves
282 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
283 tcExtendGlobalValEnv new_dicts $
285 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
286 tcExtendGlobalValEnv (bagToList val_bind_ids) $
287 zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
288 mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports ->
289 returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
290 ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
292 new_globals = listToBag [global | (_, global, local) <- new_exports]
294 returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
297 zonkExport (tyvars, global, local)
298 = mapNF_Tc zonkTcTyVarBndr tyvars `thenNF_Tc` \ new_tyvars ->
299 zonkIdBndr global `thenNF_Tc` \ new_global ->
300 zonkIdOcc local `thenNF_Tc` \ new_local ->
301 returnNF_Tc (new_tyvars, new_global, new_local)
304 %************************************************************************
306 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
308 %************************************************************************
311 zonkMatch :: TcMatch -> NF_TcM s TypecheckedMatch
313 zonkMatch (Match _ pats _ grhss)
314 = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
315 tcExtendGlobalValEnv (bagToList new_ids) $
316 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
317 returnNF_Tc (Match [] new_pats Nothing new_grhss)
319 -------------------------------------------------------------------------
321 -> NF_TcM s TypecheckedGRHSs
323 zonkGRHSs (GRHSs grhss binds (Just ty))
324 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
327 zonk_grhs (GRHS guarded locn)
328 = zonkStmts guarded `thenNF_Tc` \ new_guarded ->
329 returnNF_Tc (GRHS new_guarded locn)
331 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
332 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
333 returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
336 %************************************************************************
338 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
340 %************************************************************************
343 zonkExpr :: TcExpr -> NF_TcM s TypecheckedHsExpr
346 = zonkIdOcc id `thenNF_Tc` \ id' ->
347 returnNF_Tc (HsVar id')
349 zonkExpr (HsIPVar id)
350 = zonkIdOcc id `thenNF_Tc` \ id' ->
351 returnNF_Tc (HsIPVar id')
353 zonkExpr (HsLit _) = panic "zonkExpr:HsLit"
355 zonkExpr (HsLitOut lit ty)
356 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
357 returnNF_Tc (HsLitOut lit new_ty)
359 zonkExpr (HsLam match)
360 = zonkMatch match `thenNF_Tc` \ new_match ->
361 returnNF_Tc (HsLam new_match)
363 zonkExpr (HsApp e1 e2)
364 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
365 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
366 returnNF_Tc (HsApp new_e1 new_e2)
368 zonkExpr (OpApp e1 op fixity e2)
369 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
370 zonkExpr op `thenNF_Tc` \ new_op ->
371 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
372 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
374 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
375 zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
377 zonkExpr (SectionL expr op)
378 = zonkExpr expr `thenNF_Tc` \ new_expr ->
379 zonkExpr op `thenNF_Tc` \ new_op ->
380 returnNF_Tc (SectionL new_expr new_op)
382 zonkExpr (SectionR op expr)
383 = zonkExpr op `thenNF_Tc` \ new_op ->
384 zonkExpr expr `thenNF_Tc` \ new_expr ->
385 returnNF_Tc (SectionR new_op new_expr)
387 zonkExpr (HsCase expr ms src_loc)
388 = zonkExpr expr `thenNF_Tc` \ new_expr ->
389 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
390 returnNF_Tc (HsCase new_expr new_ms src_loc)
392 zonkExpr (HsIf e1 e2 e3 src_loc)
393 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
394 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
395 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
396 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
398 zonkExpr (HsLet binds expr)
399 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
401 zonkExpr expr `thenNF_Tc` \ new_expr ->
402 returnNF_Tc (HsLet new_binds new_expr)
404 zonkExpr (HsWith expr binds)
405 = zonkExpr expr `thenNF_Tc` \ new_expr ->
406 zonkIPBinds binds `thenNF_Tc` \ new_binds ->
407 returnNF_Tc (HsWith new_expr new_binds)
409 zonkIPBinds = mapNF_Tc zonkIPBind
411 zonkExpr e `thenNF_Tc` \ e' ->
414 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
416 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
417 = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
418 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
419 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
420 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
421 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
422 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
425 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
427 zonkExpr (ExplicitListOut ty exprs)
428 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
429 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
430 returnNF_Tc (ExplicitListOut new_ty new_exprs)
432 zonkExpr (ExplicitTuple exprs boxed)
433 = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
434 returnNF_Tc (ExplicitTuple new_exprs boxed)
436 zonkExpr (HsCon data_con tys exprs)
437 = mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
438 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
439 returnNF_Tc (HsCon data_con new_tys new_exprs)
441 zonkExpr (RecordConOut data_con con_expr rbinds)
442 = zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
443 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
444 returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
446 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
448 zonkExpr (RecordUpdOut expr ty dicts rbinds)
449 = zonkExpr expr `thenNF_Tc` \ new_expr ->
450 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
451 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
452 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
453 returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
455 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
456 zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
458 zonkExpr (ArithSeqOut expr info)
459 = zonkExpr expr `thenNF_Tc` \ new_expr ->
460 zonkArithSeq info `thenNF_Tc` \ new_info ->
461 returnNF_Tc (ArithSeqOut new_expr new_info)
463 zonkExpr (CCall fun args may_gc is_casm result_ty)
464 = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
465 zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
466 returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
468 zonkExpr (HsSCC lbl expr)
469 = zonkExpr expr `thenNF_Tc` \ new_expr ->
470 returnNF_Tc (HsSCC lbl new_expr)
472 zonkExpr (TyLam tyvars expr)
473 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
474 -- No need to extend tyvar env; see AbsBinds
476 zonkExpr expr `thenNF_Tc` \ new_expr ->
477 returnNF_Tc (TyLam new_tyvars new_expr)
479 zonkExpr (TyApp expr tys)
480 = zonkExpr expr `thenNF_Tc` \ new_expr ->
481 mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
482 returnNF_Tc (TyApp new_expr new_tys)
484 zonkExpr (DictLam dicts expr)
485 = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
486 tcExtendGlobalValEnv new_dicts $
487 zonkExpr expr `thenNF_Tc` \ new_expr ->
488 returnNF_Tc (DictLam new_dicts new_expr)
490 zonkExpr (DictApp expr dicts)
491 = zonkExpr expr `thenNF_Tc` \ new_expr ->
492 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
493 returnNF_Tc (DictApp new_expr new_dicts)
497 -------------------------------------------------------------------------
498 zonkArithSeq :: TcArithSeqInfo -> NF_TcM s TypecheckedArithSeqInfo
500 zonkArithSeq (From e)
501 = zonkExpr e `thenNF_Tc` \ new_e ->
502 returnNF_Tc (From new_e)
504 zonkArithSeq (FromThen e1 e2)
505 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
506 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
507 returnNF_Tc (FromThen new_e1 new_e2)
509 zonkArithSeq (FromTo e1 e2)
510 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
511 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
512 returnNF_Tc (FromTo new_e1 new_e2)
514 zonkArithSeq (FromThenTo e1 e2 e3)
515 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
516 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
517 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
518 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
520 -------------------------------------------------------------------------
521 zonkStmts :: [TcStmt]
522 -> NF_TcM s [TypecheckedStmt]
524 zonkStmts [] = returnNF_Tc []
526 zonkStmts [ReturnStmt expr]
527 = zonkExpr expr `thenNF_Tc` \ new_expr ->
528 returnNF_Tc [ReturnStmt new_expr]
530 zonkStmts (ExprStmt expr locn : stmts)
531 = zonkExpr expr `thenNF_Tc` \ new_expr ->
532 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
533 returnNF_Tc (ExprStmt new_expr locn : new_stmts)
535 zonkStmts (GuardStmt expr locn : stmts)
536 = zonkExpr expr `thenNF_Tc` \ new_expr ->
537 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
538 returnNF_Tc (GuardStmt new_expr locn : new_stmts)
540 zonkStmts (LetStmt binds : stmts)
541 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
543 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
544 returnNF_Tc (LetStmt new_binds : new_stmts)
546 zonkStmts (BindStmt pat expr locn : stmts)
547 = zonkExpr expr `thenNF_Tc` \ new_expr ->
548 zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) ->
549 tcExtendGlobalValEnv (bagToList new_ids) $
550 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
551 returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
555 -------------------------------------------------------------------------
556 zonkRbinds :: TcRecordBinds -> NF_TcM s TypecheckedRecordBinds
559 = mapNF_Tc zonk_rbind rbinds
561 zonk_rbind (field, expr, pun)
562 = zonkExpr expr `thenNF_Tc` \ new_expr ->
563 zonkIdOcc field `thenNF_Tc` \ new_field ->
564 returnNF_Tc (new_field, new_expr, pun)
567 %************************************************************************
569 \subsection[BackSubst-Pats]{Patterns}
571 %************************************************************************
574 zonkPat :: TcPat -> NF_TcM s (TypecheckedPat, Bag Id)
577 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
578 returnNF_Tc (WildPat new_ty, emptyBag)
581 = zonkIdBndr v `thenNF_Tc` \ new_v ->
582 returnNF_Tc (VarPat new_v, unitBag new_v)
584 zonkPat (LazyPat pat)
585 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
586 returnNF_Tc (LazyPat new_pat, ids)
588 zonkPat (AsPat n pat)
589 = zonkIdBndr n `thenNF_Tc` \ new_n ->
590 zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
591 returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
593 zonkPat (ListPat ty pats)
594 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
595 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
596 returnNF_Tc (ListPat new_ty new_pats, ids)
598 zonkPat (TuplePat pats boxed)
599 = zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
600 returnNF_Tc (TuplePat new_pats boxed, ids)
602 zonkPat (ConPat n ty tvs dicts pats)
603 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
604 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
605 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
606 tcExtendGlobalValEnv new_dicts $
607 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
608 returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
609 listToBag new_dicts `unionBags` ids)
611 zonkPat (RecPat n ty tvs dicts rpats)
612 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
613 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
614 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
615 tcExtendGlobalValEnv new_dicts $
616 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
617 returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
618 listToBag new_dicts `unionBags` unionManyBags ids_s)
620 zonk_rpat (f, pat, pun)
621 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
622 returnNF_Tc ((f, new_pat, pun), ids)
624 zonkPat (LitPat lit ty)
625 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
626 returnNF_Tc (LitPat lit new_ty, emptyBag)
628 zonkPat (NPat lit ty expr)
629 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
630 zonkExpr expr `thenNF_Tc` \ new_expr ->
631 returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
633 zonkPat (NPlusKPat n k ty e1 e2)
634 = zonkIdBndr n `thenNF_Tc` \ new_n ->
635 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
636 zonkExpr e1 `thenNF_Tc` \ new_e1 ->
637 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
638 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
640 zonkPat (DictPat ds ms)
641 = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
642 mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
643 returnNF_Tc (DictPat new_ds new_ms,
644 listToBag new_ds `unionBags` listToBag new_ms)
648 = returnNF_Tc ([], emptyBag)
651 = zonkPat pat `thenNF_Tc` \ (pat', ids1) ->
652 zonkPats pats `thenNF_Tc` \ (pats', ids2) ->
653 returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
656 %************************************************************************
658 \subsection[BackSubst-Foreign]{Foreign exports}
660 %************************************************************************
664 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM s [TypecheckedForeignDecl]
665 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
667 zonkForeignExport :: TcForeignExportDecl -> NF_TcM s (TypecheckedForeignDecl)
668 zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
669 zonkIdOcc i `thenNF_Tc` \ i' ->
670 returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
674 zonkRules :: [TcRuleDecl] -> NF_TcM s [TypecheckedRuleDecl]
675 zonkRules rs = mapNF_Tc zonkRule rs
677 zonkRule (RuleDecl name tyvars vars lhs rhs loc)
678 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
679 mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars] `thenNF_Tc` \ new_bndrs ->
680 tcExtendGlobalValEnv new_bndrs $
681 zonkExpr lhs `thenNF_Tc` \ new_lhs ->
682 zonkExpr rhs `thenNF_Tc` \ new_rhs ->
683 returnNF_Tc (RuleDecl name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
684 -- I hate this map RuleBndr stuff
686 zonkRule (IfaceRuleDecl fun rule loc)
687 = returnNF_Tc (IfaceRuleDecl fun rule loc)