2 % (c) The AQUA Project, Glasgow University, 1996
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
10 #include "HsVersions.h"
13 SYN_IE(TcMonoBinds), SYN_IE(TcHsBinds), SYN_IE(TcPat),
14 SYN_IE(TcExpr), SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), SYN_IE(TcMatch),
15 SYN_IE(TcStmt), SYN_IE(TcArithSeqInfo), SYN_IE(TcRecordBinds),
16 SYN_IE(TcHsModule), SYN_IE(TcCoreExpr), SYN_IE(TcDictBinds),
18 SYN_IE(TypecheckedHsBinds),
19 SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedPat),
20 SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedArithSeqInfo),
21 SYN_IE(TypecheckedStmt),
22 SYN_IE(TypecheckedMatch), SYN_IE(TypecheckedHsModule),
23 SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS),
24 SYN_IE(TypecheckedRecordBinds), SYN_IE(TypecheckedDictBinds),
26 mkHsTyApp, mkHsDictApp,
27 mkHsTyLam, mkHsDictLam,
30 zonkTopBinds, zonkBinds, zonkMonoBinds
36 import HsSyn -- oodles of it
37 import Id ( GenId(..), IdDetails, -- Can meddle modestly with Ids
38 SYN_IE(DictVar), idType,
43 import Name ( Name{--O only-}, NamedThing(..) )
44 import BasicTypes ( IfaceFlavour )
45 import TcEnv ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv )
47 import TcType ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar),
48 zonkTcTypeToType, zonkTcTyVarToTyVar
50 import Usage ( SYN_IE(UVar) )
51 import Util ( zipEqual, panic,
58 import PprType ( GenType, GenTyVar ) -- instances
59 import Type ( mkTyVarTy, tyVarsOfType, SYN_IE(Type) )
60 import TyVar ( GenTyVar {- instances -}, SYN_IE(TyVar),
61 SYN_IE(TyVarEnv), nullTyVarEnv, growTyVarEnvList, emptyTyVarSet )
62 import TysPrim ( voidTy )
63 import CoreSyn ( GenCoreExpr )
64 import Unique ( Unique ) -- instances
75 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
76 All the types in @Tc...@ things have mutable type-variables in them for
79 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
80 which have immutable type variables in them.
83 type TcHsBinds s = HsBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
84 type TcMonoBinds s = MonoBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
85 type TcDictBinds s = TcMonoBinds s
86 type TcPat s = OutPat (TcTyVar s) UVar (TcIdOcc s)
87 type TcExpr s = HsExpr (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
88 type TcGRHSsAndBinds s = GRHSsAndBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
89 type TcGRHS s = GRHS (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
90 type TcMatch s = Match (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
91 type TcStmt s = Stmt (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
92 type TcArithSeqInfo s = ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
93 type TcRecordBinds s = HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
94 type TcHsModule s = HsModule (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
96 type TcCoreExpr s = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcTyVar s) UVar
98 type TypecheckedPat = OutPat TyVar UVar Id
99 type TypecheckedMonoBinds = MonoBinds TyVar UVar Id TypecheckedPat
100 type TypecheckedDictBinds = TypecheckedMonoBinds
101 type TypecheckedHsBinds = HsBinds TyVar UVar Id TypecheckedPat
102 type TypecheckedHsExpr = HsExpr TyVar UVar Id TypecheckedPat
103 type TypecheckedArithSeqInfo = ArithSeqInfo TyVar UVar Id TypecheckedPat
104 type TypecheckedStmt = Stmt TyVar UVar Id TypecheckedPat
105 type TypecheckedMatch = Match TyVar UVar Id TypecheckedPat
106 type TypecheckedGRHSsAndBinds = GRHSsAndBinds TyVar UVar Id TypecheckedPat
107 type TypecheckedGRHS = GRHS TyVar UVar Id TypecheckedPat
108 type TypecheckedRecordBinds = HsRecordBinds TyVar UVar Id TypecheckedPat
109 type TypecheckedHsModule = HsModule TyVar UVar Id TypecheckedPat
113 mkHsTyApp expr [] = expr
114 mkHsTyApp expr tys = TyApp expr tys
116 mkHsDictApp expr [] = expr
117 mkHsDictApp expr dict_vars = DictApp expr dict_vars
119 mkHsTyLam [] expr = expr
120 mkHsTyLam tyvars expr = TyLam tyvars expr
122 mkHsDictLam [] expr = expr
123 mkHsDictLam dicts expr = DictLam dicts expr
125 tcIdType :: TcIdOcc s -> TcType s
126 tcIdType (TcId id) = idType id
127 tcIdType (RealId id) = pprPanic "tcIdType:" (ppr PprDebug id)
129 tcIdTyVars (TcId id) = tyVarsOfType (idType id)
130 tcIdTyVars (RealId _) = emptyTyVarSet -- Top level Ids have no free type variables
133 %************************************************************************
135 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
137 %************************************************************************
139 This zonking pass runs over the bindings
141 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
142 b) convert unbound TcTyVar to Void
143 c) convert each TcIdBndr to an Id by zonking its type
145 We pass an environment around so that
147 a) we know which TyVars are unbound
148 b) we maintain sharing; eg an Id is zonked at its binding site and they
149 all occurrences of that Id point to the common zonked copy
151 Actually, since this is all in the Tc monad, it's convenient to keep the
152 mapping from TcIds to Ids in the GVE of the Tc monad. (Those TcIds
153 were previously in the LVE of the Tc monad.)
155 It's all pretty boring stuff, because HsSyn is such a large type, and
156 the environment manipulation is tiresome.
160 extend_te te tyvars = growTyVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars]
162 zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id
163 zonkIdBndr te (TcId (Id u n ty details prags info))
164 = zonkTcTypeToType te ty `thenNF_Tc` \ ty' ->
165 returnNF_Tc (Id u n ty' details prags info)
167 zonkIdBndr te (RealId id) = returnNF_Tc id
169 zonkIdOcc :: TcIdOcc s -> NF_TcM s Id
170 zonkIdOcc (RealId id) = returnNF_Tc id
172 = tcLookupGlobalValueMaybe (getName id) `thenNF_Tc` \ maybe_id' ->
174 new_id = case maybe_id' of
176 Nothing -> pprTrace "zonkIdOcc: " (ppr PprDebug id) $
177 Id u n voidTy details prags info
179 Id u n _ details prags info = id
186 zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, TcEnv s)
187 zonkTopBinds binds -- Top level is implicitly recursive
188 = fixNF_Tc (\ ~(_, new_ids) ->
189 tcExtendGlobalValEnv (bagToList new_ids) $
190 zonkMonoBinds nullTyVarEnv binds `thenNF_Tc` \ (binds', new_ids) ->
191 tcGetEnv `thenNF_Tc` \ env ->
192 returnNF_Tc ((binds', env), new_ids)
193 ) `thenNF_Tc` \ (stuff, _) ->
197 zonkBinds :: TyVarEnv Type
199 -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
202 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env -> returnNF_Tc (binds', env))
204 -- go :: TcHsBinds s -> (TypecheckedHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv s))
205 -- -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
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 te bind `thenNF_Tc` \ (new_bind, new_ids) ->
217 thing_inside (MonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
218 returnNF_Tc (stuff, new_ids)
219 ) `thenNF_Tc` \ (stuff, _) ->
224 -------------------------------------------------------------------------
225 zonkMonoBinds :: TyVarEnv Type
227 -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
229 zonkMonoBinds te EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
231 zonkMonoBinds te (AndMonoBinds mbinds1 mbinds2)
232 = zonkMonoBinds te mbinds1 `thenNF_Tc` \ (b1', ids1) ->
233 zonkMonoBinds te mbinds2 `thenNF_Tc` \ (b2', ids2) ->
234 returnNF_Tc (b1' `AndMonoBinds` b2', ids1 `unionBags` ids2)
236 zonkMonoBinds te (PatMonoBind pat grhss_w_binds locn)
237 = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
238 zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
239 returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, ids)
241 zonkMonoBinds te (VarMonoBind var expr)
242 = zonkIdBndr te var `thenNF_Tc` \ new_var ->
243 zonkExpr te expr `thenNF_Tc` \ new_expr ->
244 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
246 zonkMonoBinds te (CoreMonoBind var core_expr)
247 = zonkIdBndr te var `thenNF_Tc` \ new_var ->
248 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
250 zonkMonoBinds te (FunMonoBind var inf ms locn)
251 = zonkIdBndr te var `thenNF_Tc` \ new_var ->
252 mapNF_Tc (zonkMatch te) ms `thenNF_Tc` \ new_ms ->
253 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
256 zonkMonoBinds te (AbsBinds tyvars dicts exports val_bind)
257 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
259 new_te = extend_te te new_tyvars
261 mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts ->
263 tcExtendGlobalValEnv new_dicts $
264 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
265 tcExtendGlobalValEnv (bagToList val_bind_ids) $
266 zonkMonoBinds new_te val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
267 mapNF_Tc (zonkExport new_te) 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 new_val_bind,
276 zonkExport te (tyvars, global, local)
277 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
278 zonkIdBndr te global `thenNF_Tc` \ new_global ->
279 zonkIdOcc local `thenNF_Tc` \ new_local ->
280 returnNF_Tc (new_tyvars, new_global, new_local)
283 %************************************************************************
285 \subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds}
287 %************************************************************************
290 zonkMatch :: TyVarEnv Type
291 -> TcMatch s -> NF_TcM s TypecheckedMatch
293 zonkMatch te (PatMatch pat match)
294 = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
295 tcExtendGlobalValEnv (bagToList ids) $
296 zonkMatch te match `thenNF_Tc` \ new_match ->
297 returnNF_Tc (PatMatch new_pat new_match)
299 zonkMatch te (GRHSMatch grhss_w_binds)
300 = zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
301 returnNF_Tc (GRHSMatch new_grhss_w_binds)
303 zonkMatch te (SimpleMatch expr)
304 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
305 returnNF_Tc (SimpleMatch new_expr)
307 -------------------------------------------------------------------------
308 zonkGRHSsAndBinds :: TyVarEnv Type
310 -> NF_TcM s TypecheckedGRHSsAndBinds
312 zonkGRHSsAndBinds te (GRHSsAndBindsOut grhss binds ty)
313 = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) ->
316 zonk_grhs (GRHS guard expr locn)
317 = zonkStmts te guard `thenNF_Tc` \ (new_guard, new_env) ->
319 zonkExpr te expr `thenNF_Tc` \ new_expr ->
320 returnNF_Tc (GRHS new_guard new_expr locn)
322 zonk_grhs (OtherwiseGRHS expr locn)
323 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
324 returnNF_Tc (OtherwiseGRHS new_expr locn)
326 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
327 zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
328 returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
331 %************************************************************************
333 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
335 %************************************************************************
338 zonkExpr :: TyVarEnv Type
339 -> TcExpr s -> NF_TcM s TypecheckedHsExpr
341 zonkExpr te (HsVar id)
342 = zonkIdOcc id `thenNF_Tc` \ id' ->
343 returnNF_Tc (HsVar id')
345 zonkExpr te (HsLit _) = panic "zonkExpr te:HsLit"
347 zonkExpr te (HsLitOut lit ty)
348 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
349 returnNF_Tc (HsLitOut lit new_ty)
351 zonkExpr te (HsLam match)
352 = zonkMatch te match `thenNF_Tc` \ new_match ->
353 returnNF_Tc (HsLam new_match)
355 zonkExpr te (HsApp e1 e2)
356 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
357 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
358 returnNF_Tc (HsApp new_e1 new_e2)
360 zonkExpr te (OpApp e1 op fixity e2)
361 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
362 zonkExpr te op `thenNF_Tc` \ new_op ->
363 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
364 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
366 zonkExpr te (NegApp _ _) = panic "zonkExpr te:NegApp"
367 zonkExpr te (HsPar _) = panic "zonkExpr te:HsPar"
369 zonkExpr te (SectionL expr op)
370 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
371 zonkExpr te op `thenNF_Tc` \ new_op ->
372 returnNF_Tc (SectionL new_expr new_op)
374 zonkExpr te (SectionR op expr)
375 = zonkExpr te op `thenNF_Tc` \ new_op ->
376 zonkExpr te expr `thenNF_Tc` \ new_expr ->
377 returnNF_Tc (SectionR new_op new_expr)
379 zonkExpr te (HsCase expr ms src_loc)
380 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
381 mapNF_Tc (zonkMatch te) ms `thenNF_Tc` \ new_ms ->
382 returnNF_Tc (HsCase new_expr new_ms src_loc)
384 zonkExpr te (HsIf e1 e2 e3 src_loc)
385 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
386 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
387 zonkExpr te e3 `thenNF_Tc` \ new_e3 ->
388 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
390 zonkExpr te (HsLet binds expr)
391 = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) ->
393 zonkExpr te expr `thenNF_Tc` \ new_expr ->
394 returnNF_Tc (HsLet new_binds new_expr)
396 zonkExpr te (HsDo _ _ _) = panic "zonkExpr te:HsDo"
398 zonkExpr te (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
399 = zonkStmts te stmts `thenNF_Tc` \ (new_stmts, _) ->
400 zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
401 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
402 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
403 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
404 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
407 zonkExpr te (ExplicitList _) = panic "zonkExpr te:ExplicitList"
409 zonkExpr te (ExplicitListOut ty exprs)
410 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
411 mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs ->
412 returnNF_Tc (ExplicitListOut new_ty new_exprs)
414 zonkExpr te (ExplicitTuple exprs)
415 = mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs ->
416 returnNF_Tc (ExplicitTuple new_exprs)
418 zonkExpr te (RecordCon con rbinds)
419 = zonkExpr te con `thenNF_Tc` \ new_con ->
420 zonkRbinds te rbinds `thenNF_Tc` \ new_rbinds ->
421 returnNF_Tc (RecordCon new_con new_rbinds)
423 zonkExpr te (RecordUpd _ _) = panic "zonkExpr te:RecordUpd"
425 zonkExpr te (RecordUpdOut expr ty dicts rbinds)
426 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
427 zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
428 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
429 zonkRbinds te rbinds `thenNF_Tc` \ new_rbinds ->
430 returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
432 zonkExpr te (ExprWithTySig _ _) = panic "zonkExpr te:ExprWithTySig"
433 zonkExpr te (ArithSeqIn _) = panic "zonkExpr te:ArithSeqIn"
435 zonkExpr te (ArithSeqOut expr info)
436 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
437 zonkArithSeq te info `thenNF_Tc` \ new_info ->
438 returnNF_Tc (ArithSeqOut new_expr new_info)
440 zonkExpr te (CCall fun args may_gc is_casm result_ty)
441 = mapNF_Tc (zonkExpr te) args `thenNF_Tc` \ new_args ->
442 zonkTcTypeToType te result_ty `thenNF_Tc` \ new_result_ty ->
443 returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
445 zonkExpr te (HsSCC label expr)
446 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
447 returnNF_Tc (HsSCC label new_expr)
449 zonkExpr te (TyLam tyvars expr)
450 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
452 new_te = extend_te te new_tyvars
454 zonkExpr new_te expr `thenNF_Tc` \ new_expr ->
455 returnNF_Tc (TyLam new_tyvars new_expr)
457 zonkExpr te (TyApp expr tys)
458 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
459 mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
460 returnNF_Tc (TyApp new_expr new_tys)
462 zonkExpr te (DictLam dicts expr)
463 = mapNF_Tc (zonkIdBndr te) dicts `thenNF_Tc` \ new_dicts ->
464 tcExtendGlobalValEnv new_dicts $
465 zonkExpr te expr `thenNF_Tc` \ new_expr ->
466 returnNF_Tc (DictLam new_dicts new_expr)
468 zonkExpr te (DictApp expr dicts)
469 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
470 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
471 returnNF_Tc (DictApp new_expr new_dicts)
473 zonkExpr te (ClassDictLam dicts methods expr)
474 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
475 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
476 mapNF_Tc zonkIdOcc methods `thenNF_Tc` \ new_methods ->
477 returnNF_Tc (ClassDictLam new_dicts new_methods new_expr)
479 zonkExpr te (Dictionary dicts methods)
480 = mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
481 mapNF_Tc zonkIdOcc methods `thenNF_Tc` \ new_methods ->
482 returnNF_Tc (Dictionary new_dicts new_methods)
484 zonkExpr te (SingleDict name)
485 = zonkIdOcc name `thenNF_Tc` \ name' ->
486 returnNF_Tc (SingleDict name')
489 -------------------------------------------------------------------------
490 zonkArithSeq :: TyVarEnv Type
491 -> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
493 zonkArithSeq te (From e)
494 = zonkExpr te e `thenNF_Tc` \ new_e ->
495 returnNF_Tc (From new_e)
497 zonkArithSeq te (FromThen e1 e2)
498 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
499 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
500 returnNF_Tc (FromThen new_e1 new_e2)
502 zonkArithSeq te (FromTo e1 e2)
503 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
504 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
505 returnNF_Tc (FromTo new_e1 new_e2)
507 zonkArithSeq te (FromThenTo e1 e2 e3)
508 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
509 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
510 zonkExpr te e3 `thenNF_Tc` \ new_e3 ->
511 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
513 -------------------------------------------------------------------------
514 zonkStmts :: TyVarEnv Type
515 -> [TcStmt s] -> NF_TcM s ([TypecheckedStmt], TcEnv s)
517 zonkStmts te [] = tcGetEnv `thenNF_Tc` \ env ->
518 returnNF_Tc ([], env)
520 zonkStmts te [ReturnStmt expr]
521 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
522 tcGetEnv `thenNF_Tc` \ env ->
523 returnNF_Tc ([ReturnStmt new_expr], env)
525 zonkStmts te (ExprStmt expr locn : stmts)
526 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
527 zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) ->
528 returnNF_Tc (ExprStmt new_expr locn : new_stmts, new_env)
530 zonkStmts te (GuardStmt expr locn : stmts)
531 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
532 zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) ->
533 returnNF_Tc (GuardStmt new_expr locn : new_stmts, new_env)
535 zonkStmts te (LetStmt binds : stmts)
536 = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) ->
538 zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env2) ->
539 returnNF_Tc (LetStmt new_binds : new_stmts, new_env2)
541 zonkStmts te (BindStmt pat expr locn : stmts)
542 = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
543 zonkExpr te expr `thenNF_Tc` \ new_expr ->
544 tcExtendGlobalValEnv (bagToList ids) $
545 zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) ->
546 returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts, new_env)
550 -------------------------------------------------------------------------
551 zonkRbinds :: TyVarEnv Type
552 -> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds
555 = mapNF_Tc zonk_rbind rbinds
557 zonk_rbind (field, expr, pun)
558 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
559 zonkIdOcc field `thenNF_Tc` \ new_field ->
560 returnNF_Tc (new_field, new_expr, pun)
563 %************************************************************************
565 \subsection[BackSubst-Pats]{Patterns}
567 %************************************************************************
570 zonkPat :: TyVarEnv Type
571 -> TcPat s -> NF_TcM s (TypecheckedPat, Bag Id)
573 zonkPat te (WildPat ty)
574 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
575 returnNF_Tc (WildPat new_ty, emptyBag)
577 zonkPat te (VarPat v)
578 = zonkIdBndr te v `thenNF_Tc` \ new_v ->
579 returnNF_Tc (VarPat new_v, unitBag new_v)
581 zonkPat te (LazyPat pat)
582 = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
583 returnNF_Tc (LazyPat new_pat, ids)
585 zonkPat te (AsPat n pat)
586 = zonkIdBndr te n `thenNF_Tc` \ new_n ->
587 zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
588 returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
590 zonkPat te (ConPat n ty pats)
591 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
592 zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
593 returnNF_Tc (ConPat n new_ty new_pats, ids)
595 zonkPat te (ConOpPat pat1 op pat2 ty)
596 = zonkPat te pat1 `thenNF_Tc` \ (new_pat1, ids1) ->
597 zonkPat te pat2 `thenNF_Tc` \ (new_pat2, ids2) ->
598 zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
599 returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty, ids1 `unionBags` ids2)
601 zonkPat te (ListPat ty pats)
602 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
603 zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
604 returnNF_Tc (ListPat new_ty new_pats, ids)
606 zonkPat te (TuplePat pats)
607 = zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
608 returnNF_Tc (TuplePat new_pats, ids)
610 zonkPat te (RecPat n ty rpats)
611 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
612 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
613 returnNF_Tc (RecPat n new_ty new_rpats, unionManyBags ids_s)
615 zonk_rpat (f, pat, pun)
616 = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
617 returnNF_Tc ((f, new_pat, pun), ids)
619 zonkPat te (LitPat lit ty)
620 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
621 returnNF_Tc (LitPat lit new_ty, emptyBag)
623 zonkPat te (NPat lit ty expr)
624 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
625 zonkExpr te expr `thenNF_Tc` \ new_expr ->
626 returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
628 zonkPat te (NPlusKPat n k ty e1 e2)
629 = zonkIdBndr te n `thenNF_Tc` \ new_n ->
630 zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
631 zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
632 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
633 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
635 zonkPat te (DictPat ds ms)
636 = mapNF_Tc (zonkIdBndr te) ds `thenNF_Tc` \ new_ds ->
637 mapNF_Tc (zonkIdBndr te) ms `thenNF_Tc` \ new_ms ->
638 returnNF_Tc (DictPat new_ds new_ms,
639 listToBag new_ds `unionBags` listToBag new_ms)
643 = returnNF_Tc ([], emptyBag)
644 zonkPats te (pat:pats)
645 = zonkPat te pat `thenNF_Tc` \ (pat', ids1) ->
646 zonkPats te pats `thenNF_Tc` \ (pats', ids2) ->
647 returnNF_Tc (pat':pats', ids1 `unionBags` ids2)