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 collectTypedPatBinders, outPatType,
31 -- re-exported from TcEnv
34 zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
35 zonkForeignExports, zonkRules
38 #include "HsVersions.h"
41 import HsSyn -- oodles of it
44 import Id ( idName, idType, setIdType, Id )
45 import DataCon ( dataConWrapId )
46 import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId )
50 import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars )
51 import TysWiredIn ( mkListTy, mkTupleTy, unitTy )
52 import CoreSyn ( Expr )
53 import BasicTypes ( RecFlag(..), Boxity(..) )
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 TypecheckedMatchContext = HsMatchContext Id
97 type TypecheckedGRHSs = GRHSs Id TypecheckedPat
98 type TypecheckedGRHS = GRHS Id TypecheckedPat
99 type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
100 type TypecheckedHsModule = HsModule Id TypecheckedPat
101 type TypecheckedForeignDecl = ForeignDecl Id
102 type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
106 mkHsTyApp expr [] = expr
107 mkHsTyApp expr tys = TyApp expr tys
109 mkHsDictApp expr [] = expr
110 mkHsDictApp expr dict_vars = DictApp expr dict_vars
112 mkHsTyLam [] expr = expr
113 mkHsTyLam tyvars expr = TyLam tyvars expr
115 mkHsDictLam [] expr = expr
116 mkHsDictLam dicts expr = DictLam dicts expr
118 mkHsLet EmptyMonoBinds expr = expr
119 mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
121 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
125 %************************************************************************
127 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
129 %************************************************************************
131 Note: If @outPatType@ doesn't bear a strong resemblance to @exprType@,
132 then something is wrong.
134 outPatType :: TypecheckedPat -> Type
136 outPatType (WildPat ty) = ty
137 outPatType (VarPat var) = idType var
138 outPatType (LazyPat pat) = outPatType pat
139 outPatType (AsPat var pat) = idType var
140 outPatType (ConPat _ ty _ _ _) = ty
141 outPatType (ListPat ty _) = mkListTy ty
142 outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats)
143 outPatType (RecPat _ ty _ _ _) = ty
144 outPatType (LitPat lit ty) = ty
145 outPatType (NPat lit ty _) = ty
146 outPatType (NPlusKPat _ _ ty _ _) = ty
147 outPatType (DictPat ds ms) = case (length ds_ms) of
149 1 -> idType (head ds_ms)
150 n -> mkTupleTy Boxed n (map idType ds_ms)
156 Nota bene: @DsBinds@ relies on the fact that at least for simple
157 tuple patterns @collectTypedPatBinders@ returns the binders in
158 the same order as they appear in the tuple.
160 @collectTypedBinders@ and @collectedTypedPatBinders@ are the exportees.
163 collectTypedPatBinders :: TypecheckedPat -> [Id]
164 collectTypedPatBinders (VarPat var) = [var]
165 collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat
166 collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat
167 collectTypedPatBinders (ConPat _ _ _ _ pats) = concat (map collectTypedPatBinders pats)
168 collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats)
169 collectTypedPatBinders (TuplePat pats _) = concat (map collectTypedPatBinders pats)
170 collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat)
172 collectTypedPatBinders (DictPat ds ms) = ds ++ ms
173 collectTypedPatBinders (NPlusKPat var _ _ _ _) = [var]
174 collectTypedPatBinders any_other_pat = [ {-no binders-} ]
178 %************************************************************************
180 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
182 %************************************************************************
184 This zonking pass runs over the bindings
186 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
187 b) convert unbound TcTyVar to Void
188 c) convert each TcId to an Id by zonking its type
190 The type variables are converted by binding mutable tyvars to immutable ones
191 and then zonking as normal.
193 The Ids are converted by binding them in the normal Tc envt; that
194 way we maintain sharing; eg an Id is zonked at its binding site and they
195 all occurrences of that Id point to the common zonked copy
197 It's all pretty boring stuff, because HsSyn is such a large type, and
198 the environment manipulation is tiresome.
201 -- zonkId is used *during* typechecking just to zonk the Id's type
202 zonkId :: TcId -> NF_TcM TcId
204 = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
205 returnNF_Tc (setIdType id ty')
207 -- zonkIdBndr is used *after* typechecking to get the Id's type
208 -- to its final form. The TyVarEnv give
209 zonkIdBndr :: TcId -> NF_TcM Id
211 = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' ->
212 returnNF_Tc (setIdType id ty')
214 zonkIdOcc :: TcId -> NF_TcM Id
216 = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' ->
217 -- We're even look up up superclass selectors and constructors;
218 -- even though zonking them is a no-op anyway, and the
219 -- superclass selectors aren't in the environment anyway.
220 -- But we don't want to call isLocalId to find out whether
221 -- it's a superclass selector (for example) because that looks
222 -- at the IdInfo field, which in turn be in a knot because of
223 -- the big knot in typecheckModule
225 new_id = case maybe_id' of
226 Just (AnId id') -> id'
227 other -> id -- WARN( isLocalId id, ppr id ) id
228 -- Oops: the warning can give a black hole
229 -- because it looks at the idinfo
236 zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
237 zonkTopBinds binds -- Top level is implicitly recursive
238 = fixNF_Tc (\ ~(_, new_ids) ->
239 tcExtendGlobalValEnv (bagToList new_ids) $
240 zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
241 tcGetEnv `thenNF_Tc` \ env ->
242 returnNF_Tc ((binds', env), new_ids)
243 ) `thenNF_Tc` \ (stuff, _) ->
246 zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
249 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
250 returnNF_Tc (binds', env))
253 -- -> (TypecheckedHsBinds
254 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
256 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
258 go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
260 thing_inside (b1' `ThenBinds` b2')
262 go EmptyBinds thing_inside = thing_inside EmptyBinds
264 go (MonoBind bind sigs is_rec) thing_inside
265 = ASSERT( null sigs )
266 fixNF_Tc (\ ~(_, new_ids) ->
267 tcExtendGlobalValEnv (bagToList new_ids) $
268 zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
269 thing_inside (mkMonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
270 returnNF_Tc (stuff, new_ids)
271 ) `thenNF_Tc` \ (stuff, _) ->
276 -------------------------------------------------------------------------
277 zonkMonoBinds :: TcMonoBinds
278 -> NF_TcM (TypecheckedMonoBinds, Bag Id)
280 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
282 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
283 = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
284 zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
285 returnNF_Tc (b1' `AndMonoBinds` b2',
286 ids1 `unionBags` ids2)
288 zonkMonoBinds (PatMonoBind pat grhss locn)
289 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
290 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
291 returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
293 zonkMonoBinds (VarMonoBind var expr)
294 = zonkIdBndr var `thenNF_Tc` \ new_var ->
295 zonkExpr expr `thenNF_Tc` \ new_expr ->
296 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
298 zonkMonoBinds (CoreMonoBind var core_expr)
299 = zonkIdBndr var `thenNF_Tc` \ new_var ->
300 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
302 zonkMonoBinds (FunMonoBind var inf ms locn)
303 = zonkIdBndr var `thenNF_Tc` \ new_var ->
304 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
305 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
308 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
309 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
310 -- No need to extend tyvar env: the effects are
311 -- propagated through binding the tyvars themselves
313 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
314 tcExtendGlobalValEnv new_dicts $
316 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
317 tcExtendGlobalValEnv (bagToList val_bind_ids) $
318 zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
319 mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports ->
320 returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
321 ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
323 new_globals = listToBag [global | (_, global, local) <- new_exports]
325 returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
328 zonkExport (tyvars, global, local)
329 = zonkTcSigTyVars tyvars `thenNF_Tc` \ new_tyvars ->
330 -- This isn't the binding occurrence of these tyvars
331 -- but they should *be* tyvars. Hence zonkTcSigTyVars.
332 zonkIdBndr global `thenNF_Tc` \ new_global ->
333 zonkIdOcc local `thenNF_Tc` \ new_local ->
334 returnNF_Tc (new_tyvars, new_global, new_local)
337 %************************************************************************
339 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
341 %************************************************************************
344 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
346 zonkMatch (Match _ pats _ grhss)
347 = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
348 tcExtendGlobalValEnv (bagToList new_ids) $
349 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
350 returnNF_Tc (Match [] new_pats Nothing new_grhss)
352 -------------------------------------------------------------------------
354 -> NF_TcM TypecheckedGRHSs
356 zonkGRHSs (GRHSs grhss binds ty)
357 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
360 zonk_grhs (GRHS guarded locn)
361 = zonkStmts guarded `thenNF_Tc` \ new_guarded ->
362 returnNF_Tc (GRHS new_guarded locn)
364 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
365 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
366 returnNF_Tc (GRHSs new_grhss new_binds new_ty)
369 %************************************************************************
371 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
373 %************************************************************************
376 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
379 = zonkIdOcc id `thenNF_Tc` \ id' ->
380 returnNF_Tc (HsVar id')
382 zonkExpr (HsIPVar id)
383 = zonkIdOcc id `thenNF_Tc` \ id' ->
384 returnNF_Tc (HsIPVar id')
386 zonkExpr (HsLit (HsRat f ty))
387 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
388 returnNF_Tc (HsLit (HsRat f new_ty))
390 zonkExpr (HsLit (HsLitLit lit ty))
391 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
392 returnNF_Tc (HsLit (HsLitLit lit new_ty))
395 = returnNF_Tc (HsLit lit)
397 -- HsOverLit doesn't appear in typechecker output
399 zonkExpr (HsLam match)
400 = zonkMatch match `thenNF_Tc` \ new_match ->
401 returnNF_Tc (HsLam new_match)
403 zonkExpr (HsApp e1 e2)
404 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
405 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
406 returnNF_Tc (HsApp new_e1 new_e2)
408 zonkExpr (OpApp e1 op fixity e2)
409 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
410 zonkExpr op `thenNF_Tc` \ new_op ->
411 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
412 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
414 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
415 zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
417 zonkExpr (SectionL expr op)
418 = zonkExpr expr `thenNF_Tc` \ new_expr ->
419 zonkExpr op `thenNF_Tc` \ new_op ->
420 returnNF_Tc (SectionL new_expr new_op)
422 zonkExpr (SectionR op expr)
423 = zonkExpr op `thenNF_Tc` \ new_op ->
424 zonkExpr expr `thenNF_Tc` \ new_expr ->
425 returnNF_Tc (SectionR new_op new_expr)
427 zonkExpr (HsCase expr ms src_loc)
428 = zonkExpr expr `thenNF_Tc` \ new_expr ->
429 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
430 returnNF_Tc (HsCase new_expr new_ms src_loc)
432 zonkExpr (HsIf e1 e2 e3 src_loc)
433 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
434 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
435 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
436 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
438 zonkExpr (HsLet binds expr)
439 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
441 zonkExpr expr `thenNF_Tc` \ new_expr ->
442 returnNF_Tc (HsLet new_binds new_expr)
444 zonkExpr (HsWith expr binds)
445 = zonkIPBinds binds `thenNF_Tc` \ new_binds ->
446 tcExtendGlobalValEnv (map fst new_binds) $
447 zonkExpr expr `thenNF_Tc` \ new_expr ->
448 returnNF_Tc (HsWith new_expr new_binds)
450 zonkIPBinds = mapNF_Tc zonkIPBind
452 zonkIdBndr n `thenNF_Tc` \ n' ->
453 zonkExpr e `thenNF_Tc` \ e' ->
456 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
458 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
459 = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
460 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
461 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
462 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
463 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
464 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
467 zonkExpr (ExplicitList ty exprs)
468 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
469 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
470 returnNF_Tc (ExplicitList new_ty new_exprs)
472 zonkExpr (ExplicitTuple exprs boxed)
473 = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
474 returnNF_Tc (ExplicitTuple new_exprs boxed)
476 zonkExpr (RecordConOut data_con con_expr rbinds)
477 = zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
478 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
479 returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
481 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
483 zonkExpr (RecordUpdOut expr in_ty out_ty dicts rbinds)
484 = zonkExpr expr `thenNF_Tc` \ new_expr ->
485 zonkTcTypeToType in_ty `thenNF_Tc` \ new_in_ty ->
486 zonkTcTypeToType out_ty `thenNF_Tc` \ new_out_ty ->
487 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
488 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
489 returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_dicts new_rbinds)
491 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
492 zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
494 zonkExpr (ArithSeqOut expr info)
495 = zonkExpr expr `thenNF_Tc` \ new_expr ->
496 zonkArithSeq info `thenNF_Tc` \ new_info ->
497 returnNF_Tc (ArithSeqOut new_expr new_info)
499 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
500 = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
501 zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
502 returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
504 zonkExpr (HsSCC lbl expr)
505 = zonkExpr expr `thenNF_Tc` \ new_expr ->
506 returnNF_Tc (HsSCC lbl new_expr)
508 zonkExpr (TyLam tyvars expr)
509 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
510 -- No need to extend tyvar env; see AbsBinds
512 zonkExpr expr `thenNF_Tc` \ new_expr ->
513 returnNF_Tc (TyLam new_tyvars new_expr)
515 zonkExpr (TyApp expr tys)
516 = zonkExpr expr `thenNF_Tc` \ new_expr ->
517 mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
518 returnNF_Tc (TyApp new_expr new_tys)
520 zonkExpr (DictLam dicts expr)
521 = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
522 tcExtendGlobalValEnv new_dicts $
523 zonkExpr expr `thenNF_Tc` \ new_expr ->
524 returnNF_Tc (DictLam new_dicts new_expr)
526 zonkExpr (DictApp expr dicts)
527 = zonkExpr expr `thenNF_Tc` \ new_expr ->
528 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
529 returnNF_Tc (DictApp new_expr new_dicts)
533 -------------------------------------------------------------------------
534 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
536 zonkArithSeq (From e)
537 = zonkExpr e `thenNF_Tc` \ new_e ->
538 returnNF_Tc (From new_e)
540 zonkArithSeq (FromThen e1 e2)
541 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
542 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
543 returnNF_Tc (FromThen new_e1 new_e2)
545 zonkArithSeq (FromTo e1 e2)
546 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
547 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
548 returnNF_Tc (FromTo new_e1 new_e2)
550 zonkArithSeq (FromThenTo e1 e2 e3)
551 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
552 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
553 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
554 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
556 -------------------------------------------------------------------------
557 zonkStmts :: [TcStmt]
558 -> NF_TcM [TypecheckedStmt]
560 zonkStmts [] = returnNF_Tc []
562 zonkStmts (ParStmtOut bndrstmtss : stmts)
563 = mapNF_Tc (mapNF_Tc zonkId) bndrss `thenNF_Tc` \ new_bndrss ->
564 let new_binders = concat new_bndrss in
565 mapNF_Tc zonkStmts stmtss `thenNF_Tc` \ new_stmtss ->
566 tcExtendGlobalValEnv new_binders $
567 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
568 returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
569 where (bndrss, stmtss) = unzip bndrstmtss
571 zonkStmts (ResultStmt expr locn : stmts)
572 = zonkExpr expr `thenNF_Tc` \ new_expr ->
573 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
574 returnNF_Tc (ResultStmt new_expr locn : new_stmts)
576 zonkStmts (ExprStmt expr ty locn : stmts)
577 = zonkExpr expr `thenNF_Tc` \ new_expr ->
578 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
579 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
580 returnNF_Tc (ExprStmt new_expr new_ty locn : new_stmts)
582 zonkStmts (LetStmt binds : stmts)
583 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
585 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
586 returnNF_Tc (LetStmt new_binds : new_stmts)
588 zonkStmts (BindStmt pat expr locn : stmts)
589 = zonkExpr expr `thenNF_Tc` \ new_expr ->
590 zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) ->
591 tcExtendGlobalValEnv (bagToList new_ids) $
592 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
593 returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
597 -------------------------------------------------------------------------
598 zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
601 = mapNF_Tc zonk_rbind rbinds
603 zonk_rbind (field, expr, pun)
604 = zonkExpr expr `thenNF_Tc` \ new_expr ->
605 zonkIdOcc field `thenNF_Tc` \ new_field ->
606 returnNF_Tc (new_field, new_expr, pun)
609 %************************************************************************
611 \subsection[BackSubst-Pats]{Patterns}
613 %************************************************************************
616 zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
619 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
620 returnNF_Tc (WildPat new_ty, emptyBag)
623 = zonkIdBndr v `thenNF_Tc` \ new_v ->
624 returnNF_Tc (VarPat new_v, unitBag new_v)
626 zonkPat (LazyPat pat)
627 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
628 returnNF_Tc (LazyPat new_pat, ids)
630 zonkPat (AsPat n pat)
631 = zonkIdBndr n `thenNF_Tc` \ new_n ->
632 zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
633 returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
635 zonkPat (ListPat ty pats)
636 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
637 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
638 returnNF_Tc (ListPat new_ty new_pats, ids)
640 zonkPat (TuplePat pats boxed)
641 = zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
642 returnNF_Tc (TuplePat new_pats boxed, ids)
644 zonkPat (ConPat n ty tvs dicts pats)
645 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
646 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
647 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
648 tcExtendGlobalValEnv new_dicts $
649 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
650 returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
651 listToBag new_dicts `unionBags` ids)
653 zonkPat (RecPat n ty tvs dicts rpats)
654 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
655 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
656 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
657 tcExtendGlobalValEnv new_dicts $
658 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
659 returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
660 listToBag new_dicts `unionBags` unionManyBags ids_s)
662 zonk_rpat (f, pat, pun)
663 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
664 returnNF_Tc ((f, new_pat, pun), ids)
666 zonkPat (LitPat lit ty)
667 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
668 returnNF_Tc (LitPat lit new_ty, emptyBag)
670 zonkPat (NPat lit ty expr)
671 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
672 zonkExpr expr `thenNF_Tc` \ new_expr ->
673 returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
675 zonkPat (NPlusKPat n k ty e1 e2)
676 = zonkIdBndr n `thenNF_Tc` \ new_n ->
677 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
678 zonkExpr e1 `thenNF_Tc` \ new_e1 ->
679 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
680 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
682 zonkPat (DictPat ds ms)
683 = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
684 mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
685 returnNF_Tc (DictPat new_ds new_ms,
686 listToBag new_ds `unionBags` listToBag new_ms)
690 = returnNF_Tc ([], emptyBag)
693 = zonkPat pat `thenNF_Tc` \ (pat', ids1) ->
694 zonkPats pats `thenNF_Tc` \ (pats', ids2) ->
695 returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
698 %************************************************************************
700 \subsection[BackSubst-Foreign]{Foreign exports}
702 %************************************************************************
706 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
707 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
709 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
710 zonkForeignExport (ForeignExport i hs_ty spec src_loc) =
711 zonkIdOcc i `thenNF_Tc` \ i' ->
712 returnNF_Tc (ForeignExport i' undefined spec src_loc)
716 zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
717 zonkRules rs = mapNF_Tc zonkRule rs
719 zonkRule (HsRule name tyvars vars lhs rhs loc)
720 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
721 mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars] `thenNF_Tc` \ new_bndrs ->
722 tcExtendGlobalValEnv new_bndrs $
723 zonkExpr lhs `thenNF_Tc` \ new_lhs ->
724 zonkExpr rhs `thenNF_Tc` \ new_rhs ->
725 returnNF_Tc (HsRule name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
726 -- I hate this map RuleBndr stuff
728 zonkRule (IfaceRuleOut fun rule)
729 = zonkIdOcc fun `thenNF_Tc` \ fun' ->
730 returnNF_Tc (IfaceRuleOut fun' rule)