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
11 TcMonoBinds, TcHsBinds, TcPat,
12 TcExpr, TcGRHSsAndBinds, TcGRHS, TcMatch,
13 TcStmt, TcArithSeqInfo, TcRecordBinds,
14 TcHsModule, TcCoreExpr, TcDictBinds,
17 TypecheckedMonoBinds, TypecheckedPat,
18 TypecheckedHsExpr, TypecheckedArithSeqInfo,
20 TypecheckedMatch, TypecheckedHsModule,
21 TypecheckedGRHSsAndBinds, TypecheckedGRHS,
22 TypecheckedRecordBinds, TypecheckedDictBinds,
24 mkHsTyApp, mkHsDictApp,
25 mkHsTyLam, mkHsDictLam,
27 -- re-exported from TcEnv
28 TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId,
32 zonkTopBinds, zonkBinds, zonkMonoBinds, zonkTcId
35 #include "HsVersions.h"
38 import HsSyn -- oodles of it
39 import Id ( GenId(..), IdDetails, -- Can meddle modestly with Ids
40 DictVar, idType, dataConArgTys,
45 import Name ( NamedThing(..) )
46 import BasicTypes ( IfaceFlavour, Unused )
47 import TcEnv ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv,
48 TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId
52 import TcType ( TcType, TcMaybe, TcTyVar, TcBox,
53 zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType
55 import TyCon ( isDataTyCon )
56 import Type ( mkTyVarTy, tyVarsOfType, splitAlgTyConApp_maybe, isUnpointedType, Type )
57 import TyVar ( TyVar, TyVarEnv, emptyTyVarEnv, growTyVarEnvList, emptyTyVarSet )
58 import TysPrim ( voidTy )
59 import CoreSyn ( GenCoreExpr )
60 import Unique ( Unique ) -- instances
63 import Util ( zipEqual )
71 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
72 All the types in @Tc...@ things have mutable type-variables in them for
75 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
76 which have immutable type variables in them.
79 type TcHsBinds s = HsBinds (TcBox s) (TcIdOcc s) (TcPat s)
80 type TcMonoBinds s = MonoBinds (TcBox s) (TcIdOcc s) (TcPat s)
81 type TcDictBinds s = TcMonoBinds s
82 type TcPat s = OutPat (TcBox s) (TcIdOcc s)
83 type TcExpr s = HsExpr (TcBox s) (TcIdOcc s) (TcPat s)
84 type TcGRHSsAndBinds s = GRHSsAndBinds (TcBox s) (TcIdOcc s) (TcPat s)
85 type TcGRHS s = GRHS (TcBox s) (TcIdOcc s) (TcPat s)
86 type TcMatch s = Match (TcBox s) (TcIdOcc s) (TcPat s)
87 type TcStmt s = Stmt (TcBox s) (TcIdOcc s) (TcPat s)
88 type TcArithSeqInfo s = ArithSeqInfo (TcBox s) (TcIdOcc s) (TcPat s)
89 type TcRecordBinds s = HsRecordBinds (TcBox s) (TcIdOcc s) (TcPat s)
90 type TcHsModule s = HsModule (TcBox s) (TcIdOcc s) (TcPat s)
92 type TcCoreExpr s = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcBox s)
94 type TypecheckedPat = OutPat Unused Id
95 type TypecheckedMonoBinds = MonoBinds Unused Id TypecheckedPat
96 type TypecheckedDictBinds = TypecheckedMonoBinds
97 type TypecheckedHsBinds = HsBinds Unused Id TypecheckedPat
98 type TypecheckedHsExpr = HsExpr Unused Id TypecheckedPat
99 type TypecheckedArithSeqInfo = ArithSeqInfo Unused Id TypecheckedPat
100 type TypecheckedStmt = Stmt Unused Id TypecheckedPat
101 type TypecheckedMatch = Match Unused Id TypecheckedPat
102 type TypecheckedGRHSsAndBinds = GRHSsAndBinds Unused Id TypecheckedPat
103 type TypecheckedGRHS = GRHS Unused Id TypecheckedPat
104 type TypecheckedRecordBinds = HsRecordBinds Unused Id TypecheckedPat
105 type TypecheckedHsModule = HsModule Unused Id TypecheckedPat
109 mkHsTyApp expr [] = expr
110 mkHsTyApp expr tys = TyApp expr tys
112 mkHsDictApp expr [] = expr
113 mkHsDictApp expr dict_vars = DictApp expr dict_vars
115 mkHsTyLam [] expr = expr
116 mkHsTyLam tyvars expr = TyLam tyvars expr
118 mkHsDictLam [] expr = expr
119 mkHsDictLam dicts expr = DictLam dicts expr
122 %************************************************************************
124 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
126 %************************************************************************
128 Some gruesome hackery for desugaring ccalls. It's here because if we put it
129 in Type.lhs we get irritating loops, and it's only used by TcInstDcls.lhs and
133 maybeBoxedPrimType :: Type -> Maybe (Id, Type)
134 maybeBoxedPrimType ty
135 = case splitAlgTyConApp_maybe ty of -- Data type,
136 Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon -- with exactly one constructor
137 -> case (dataConArgTys data_con tys_applied) of
138 [data_con_arg_ty] -- Applied to exactly one type,
139 | isUnpointedType data_con_arg_ty -- which is primitive
140 -> Just (data_con, data_con_arg_ty)
141 other_cases -> Nothing
142 other_cases -> Nothing
145 %************************************************************************
147 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
149 %************************************************************************
151 @zonkTcId@ just works on TcIdOccs. It's used when zonking Method insts.
154 zonkTcId :: TcIdOcc s -> NF_TcM s (TcIdOcc s)
155 zonkTcId tc_id@(RealId id) = returnNF_Tc tc_id
156 zonkTcId (TcId (Id u n ty details prags info))
157 = zonkTcType ty `thenNF_Tc` \ ty' ->
158 returnNF_Tc (TcId (Id u n ty' details prags info))
161 This zonking pass runs over the bindings
163 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
164 b) convert unbound TcTyVar to Void
165 c) convert each TcIdBndr to an Id by zonking its type
167 We pass an environment around so that
169 a) we know which TyVars are unbound
170 b) we maintain sharing; eg an Id is zonked at its binding site and they
171 all occurrences of that Id point to the common zonked copy
173 Actually, since this is all in the Tc monad, it's convenient to keep the
174 mapping from TcIds to Ids in the GVE of the Tc monad. (Those TcIds
175 were previously in the LVE of the Tc monad.)
177 It's all pretty boring stuff, because HsSyn is such a large type, and
178 the environment manipulation is tiresome.
181 extend_te te tyvars = growTyVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars]
183 zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id
184 zonkIdBndr te (RealId id) = returnNF_Tc id
185 zonkIdBndr te (TcId (Id u n ty details prags info))
186 = zonkTcTypeToType te ty `thenNF_Tc` \ ty' ->
187 returnNF_Tc (Id u n ty' details prags info)
190 zonkIdOcc :: TcIdOcc s -> NF_TcM s Id
191 zonkIdOcc (RealId id) = returnNF_Tc id
193 = tcLookupGlobalValueMaybe (getName id) `thenNF_Tc` \ maybe_id' ->
195 new_id = case maybe_id' of
197 Nothing -> pprTrace "zonkIdOcc: " (ppr id) $
198 Id u n voidTy details prags info
200 Id u n _ details prags info = id
207 zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, TcEnv s)
208 zonkTopBinds binds -- Top level is implicitly recursive
209 = fixNF_Tc (\ ~(_, new_ids) ->
210 tcExtendGlobalValEnv (bagToList new_ids) $
211 zonkMonoBinds emptyTyVarEnv binds `thenNF_Tc` \ (binds', new_ids) ->
212 tcGetEnv `thenNF_Tc` \ env ->
213 returnNF_Tc ((binds', env), new_ids)
214 ) `thenNF_Tc` \ (stuff, _) ->
218 zonkBinds :: TyVarEnv Type
220 -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
223 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env -> returnNF_Tc (binds', env))
225 -- go :: TcHsBinds s -> (TypecheckedHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv s))
226 -- -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
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 te bind `thenNF_Tc` \ (new_bind, new_ids) ->
238 thing_inside (MonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
239 returnNF_Tc (stuff, new_ids)
240 ) `thenNF_Tc` \ (stuff, _) ->
245 -------------------------------------------------------------------------
246 zonkMonoBinds :: TyVarEnv Type
248 -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
250 zonkMonoBinds te EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
252 zonkMonoBinds te (AndMonoBinds mbinds1 mbinds2)
253 = zonkMonoBinds te mbinds1 `thenNF_Tc` \ (b1', ids1) ->
254 zonkMonoBinds te mbinds2 `thenNF_Tc` \ (b2', ids2) ->
255 returnNF_Tc (b1' `AndMonoBinds` b2', ids1 `unionBags` ids2)
257 zonkMonoBinds te (PatMonoBind pat grhss_w_binds locn)
258 = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
259 zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
260 returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, ids)
262 zonkMonoBinds te (VarMonoBind var expr)
263 = zonkIdBndr te var `thenNF_Tc` \ new_var ->
264 zonkExpr te expr `thenNF_Tc` \ new_expr ->
265 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
267 zonkMonoBinds te (CoreMonoBind var core_expr)
268 = zonkIdBndr te var `thenNF_Tc` \ new_var ->
269 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
271 zonkMonoBinds te (FunMonoBind var inf ms locn)
272 = zonkIdBndr te var `thenNF_Tc` \ new_var ->
273 mapNF_Tc (zonkMatch te) ms `thenNF_Tc` \ new_ms ->
274 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
277 zonkMonoBinds te (AbsBinds tyvars dicts exports val_bind)
278 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
280 new_te = extend_te te new_tyvars
282 mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts ->
284 tcExtendGlobalValEnv new_dicts $
285 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
286 tcExtendGlobalValEnv (bagToList val_bind_ids) $
287 zonkMonoBinds new_te val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
288 mapNF_Tc (zonkExport new_te) 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 new_val_bind,
297 zonkExport te (tyvars, global, local)
298 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
299 zonkIdBndr te 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 GRHSsAndBinds}
308 %************************************************************************
311 zonkMatch :: TyVarEnv Type
312 -> TcMatch s -> NF_TcM s TypecheckedMatch
314 zonkMatch te (PatMatch pat match)
315 = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
316 tcExtendGlobalValEnv (bagToList ids) $
317 zonkMatch te match `thenNF_Tc` \ new_match ->
318 returnNF_Tc (PatMatch new_pat new_match)
320 zonkMatch te (GRHSMatch grhss_w_binds)
321 = zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
322 returnNF_Tc (GRHSMatch new_grhss_w_binds)
324 zonkMatch te (SimpleMatch expr)
325 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
326 returnNF_Tc (SimpleMatch new_expr)
328 -------------------------------------------------------------------------
329 zonkGRHSsAndBinds :: TyVarEnv Type
331 -> NF_TcM s TypecheckedGRHSsAndBinds
333 zonkGRHSsAndBinds te (GRHSsAndBindsOut grhss binds ty)
334 = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) ->
337 zonk_grhs (GRHS guard expr locn)
338 = zonkStmts te guard `thenNF_Tc` \ (new_guard, new_env) ->
340 zonkExpr te expr `thenNF_Tc` \ new_expr ->
341 returnNF_Tc (GRHS new_guard new_expr locn)
343 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
344 zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
345 returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
348 %************************************************************************
350 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
352 %************************************************************************
355 zonkExpr :: TyVarEnv Type
356 -> TcExpr s -> NF_TcM s TypecheckedHsExpr
358 zonkExpr te (HsVar id)
359 = zonkIdOcc id `thenNF_Tc` \ id' ->
360 returnNF_Tc (HsVar id')
362 zonkExpr te (HsLit _) = panic "zonkExpr te:HsLit"
364 zonkExpr te (HsLitOut lit ty)
365 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
366 returnNF_Tc (HsLitOut lit new_ty)
368 zonkExpr te (HsLam match)
369 = zonkMatch te match `thenNF_Tc` \ new_match ->
370 returnNF_Tc (HsLam new_match)
372 zonkExpr te (HsApp e1 e2)
373 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
374 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
375 returnNF_Tc (HsApp new_e1 new_e2)
377 zonkExpr te (OpApp e1 op fixity e2)
378 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
379 zonkExpr te op `thenNF_Tc` \ new_op ->
380 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
381 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
383 zonkExpr te (NegApp _ _) = panic "zonkExpr te:NegApp"
384 zonkExpr te (HsPar _) = panic "zonkExpr te:HsPar"
386 zonkExpr te (SectionL expr op)
387 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
388 zonkExpr te op `thenNF_Tc` \ new_op ->
389 returnNF_Tc (SectionL new_expr new_op)
391 zonkExpr te (SectionR op expr)
392 = zonkExpr te op `thenNF_Tc` \ new_op ->
393 zonkExpr te expr `thenNF_Tc` \ new_expr ->
394 returnNF_Tc (SectionR new_op new_expr)
396 zonkExpr te (HsCase expr ms src_loc)
397 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
398 mapNF_Tc (zonkMatch te) ms `thenNF_Tc` \ new_ms ->
399 returnNF_Tc (HsCase new_expr new_ms src_loc)
401 zonkExpr te (HsIf e1 e2 e3 src_loc)
402 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
403 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
404 zonkExpr te e3 `thenNF_Tc` \ new_e3 ->
405 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
407 zonkExpr te (HsLet binds expr)
408 = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) ->
410 zonkExpr te expr `thenNF_Tc` \ new_expr ->
411 returnNF_Tc (HsLet new_binds new_expr)
413 zonkExpr te (HsDo _ _ _) = panic "zonkExpr te:HsDo"
415 zonkExpr te (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
416 = zonkStmts te stmts `thenNF_Tc` \ (new_stmts, _) ->
417 zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
418 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
419 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
420 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
421 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
424 zonkExpr te (ExplicitList _) = panic "zonkExpr te:ExplicitList"
426 zonkExpr te (ExplicitListOut ty exprs)
427 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
428 mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs ->
429 returnNF_Tc (ExplicitListOut new_ty new_exprs)
431 zonkExpr te (ExplicitTuple exprs)
432 = mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs ->
433 returnNF_Tc (ExplicitTuple new_exprs)
435 zonkExpr te (HsCon con_id tys exprs)
436 = mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
437 mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs ->
438 returnNF_Tc (HsCon con_id new_tys new_exprs)
440 zonkExpr te (RecordCon con_id con_expr rbinds)
441 = zonkIdOcc con_id `thenNF_Tc` \ new_con_id ->
442 zonkExpr te con_expr `thenNF_Tc` \ new_con_expr ->
443 zonkRbinds te rbinds `thenNF_Tc` \ new_rbinds ->
444 returnNF_Tc (RecordCon new_con_id new_con_expr new_rbinds)
446 zonkExpr te (RecordUpd _ _) = panic "zonkExpr te:RecordUpd"
448 zonkExpr te (RecordUpdOut expr ty dicts rbinds)
449 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
450 zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
451 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
452 zonkRbinds te rbinds `thenNF_Tc` \ new_rbinds ->
453 returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
455 zonkExpr te (ExprWithTySig _ _) = panic "zonkExpr te:ExprWithTySig"
456 zonkExpr te (ArithSeqIn _) = panic "zonkExpr te:ArithSeqIn"
458 zonkExpr te (ArithSeqOut expr info)
459 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
460 zonkArithSeq te info `thenNF_Tc` \ new_info ->
461 returnNF_Tc (ArithSeqOut new_expr new_info)
463 zonkExpr te (CCall fun args may_gc is_casm result_ty)
464 = mapNF_Tc (zonkExpr te) args `thenNF_Tc` \ new_args ->
465 zonkTcTypeToType te result_ty `thenNF_Tc` \ new_result_ty ->
466 returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
468 zonkExpr te (HsSCC label expr)
469 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
470 returnNF_Tc (HsSCC label new_expr)
472 zonkExpr te (TyLam tyvars expr)
473 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
475 new_te = extend_te te new_tyvars
477 zonkExpr new_te expr `thenNF_Tc` \ new_expr ->
478 returnNF_Tc (TyLam new_tyvars new_expr)
480 zonkExpr te (TyApp expr tys)
481 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
482 mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
483 returnNF_Tc (TyApp new_expr new_tys)
485 zonkExpr te (DictLam dicts expr)
486 = mapNF_Tc (zonkIdBndr te) dicts `thenNF_Tc` \ new_dicts ->
487 tcExtendGlobalValEnv new_dicts $
488 zonkExpr te expr `thenNF_Tc` \ new_expr ->
489 returnNF_Tc (DictLam new_dicts new_expr)
491 zonkExpr te (DictApp expr dicts)
492 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
493 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
494 returnNF_Tc (DictApp new_expr new_dicts)
498 -------------------------------------------------------------------------
499 zonkArithSeq :: TyVarEnv Type
500 -> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
502 zonkArithSeq te (From e)
503 = zonkExpr te e `thenNF_Tc` \ new_e ->
504 returnNF_Tc (From new_e)
506 zonkArithSeq te (FromThen e1 e2)
507 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
508 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
509 returnNF_Tc (FromThen new_e1 new_e2)
511 zonkArithSeq te (FromTo e1 e2)
512 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
513 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
514 returnNF_Tc (FromTo new_e1 new_e2)
516 zonkArithSeq te (FromThenTo e1 e2 e3)
517 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
518 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
519 zonkExpr te e3 `thenNF_Tc` \ new_e3 ->
520 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
522 -------------------------------------------------------------------------
523 zonkStmts :: TyVarEnv Type
524 -> [TcStmt s] -> NF_TcM s ([TypecheckedStmt], TcEnv s)
526 zonkStmts te [] = tcGetEnv `thenNF_Tc` \ env ->
527 returnNF_Tc ([], env)
529 zonkStmts te [ReturnStmt expr]
530 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
531 tcGetEnv `thenNF_Tc` \ env ->
532 returnNF_Tc ([ReturnStmt new_expr], env)
534 zonkStmts te (ExprStmt expr locn : stmts)
535 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
536 zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) ->
537 returnNF_Tc (ExprStmt new_expr locn : new_stmts, new_env)
539 zonkStmts te (GuardStmt expr locn : stmts)
540 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
541 zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) ->
542 returnNF_Tc (GuardStmt new_expr locn : new_stmts, new_env)
544 zonkStmts te (LetStmt binds : stmts)
545 = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) ->
547 zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env2) ->
548 returnNF_Tc (LetStmt new_binds : new_stmts, new_env2)
550 zonkStmts te (BindStmt pat expr locn : stmts)
551 = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
552 zonkExpr te expr `thenNF_Tc` \ new_expr ->
553 tcExtendGlobalValEnv (bagToList ids) $
554 zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) ->
555 returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts, new_env)
559 -------------------------------------------------------------------------
560 zonkRbinds :: TyVarEnv Type
561 -> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds
564 = mapNF_Tc zonk_rbind rbinds
566 zonk_rbind (field, expr, pun)
567 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
568 zonkIdOcc field `thenNF_Tc` \ new_field ->
569 returnNF_Tc (new_field, new_expr, pun)
572 %************************************************************************
574 \subsection[BackSubst-Pats]{Patterns}
576 %************************************************************************
579 zonkPat :: TyVarEnv Type
580 -> TcPat s -> NF_TcM s (TypecheckedPat, Bag Id)
582 zonkPat te (WildPat ty)
583 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
584 returnNF_Tc (WildPat new_ty, emptyBag)
586 zonkPat te (VarPat v)
587 = zonkIdBndr te v `thenNF_Tc` \ new_v ->
588 returnNF_Tc (VarPat new_v, unitBag new_v)
590 zonkPat te (LazyPat pat)
591 = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
592 returnNF_Tc (LazyPat new_pat, ids)
594 zonkPat te (AsPat n pat)
595 = zonkIdBndr te n `thenNF_Tc` \ new_n ->
596 zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
597 returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
599 zonkPat te (ConPat n ty pats)
600 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
601 zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
602 returnNF_Tc (ConPat n new_ty new_pats, ids)
604 zonkPat te (ConOpPat pat1 op pat2 ty)
605 = zonkPat te pat1 `thenNF_Tc` \ (new_pat1, ids1) ->
606 zonkPat te pat2 `thenNF_Tc` \ (new_pat2, ids2) ->
607 zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
608 returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty, ids1 `unionBags` ids2)
610 zonkPat te (ListPat ty pats)
611 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
612 zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
613 returnNF_Tc (ListPat new_ty new_pats, ids)
615 zonkPat te (TuplePat pats)
616 = zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
617 returnNF_Tc (TuplePat new_pats, ids)
619 zonkPat te (RecPat n ty rpats)
620 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
621 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
622 returnNF_Tc (RecPat n new_ty new_rpats, unionManyBags ids_s)
624 zonk_rpat (f, pat, pun)
625 = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
626 returnNF_Tc ((f, new_pat, pun), ids)
628 zonkPat te (LitPat lit ty)
629 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
630 returnNF_Tc (LitPat lit new_ty, emptyBag)
632 zonkPat te (NPat lit ty expr)
633 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
634 zonkExpr te expr `thenNF_Tc` \ new_expr ->
635 returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
637 zonkPat te (NPlusKPat n k ty e1 e2)
638 = zonkIdBndr te n `thenNF_Tc` \ new_n ->
639 zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
640 zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
641 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
642 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
644 zonkPat te (DictPat ds ms)
645 = mapNF_Tc (zonkIdBndr te) ds `thenNF_Tc` \ new_ds ->
646 mapNF_Tc (zonkIdBndr te) ms `thenNF_Tc` \ new_ms ->
647 returnNF_Tc (DictPat new_ds new_ms,
648 listToBag new_ds `unionBags` listToBag new_ms)
652 = returnNF_Tc ([], emptyBag)
653 zonkPats te (pat:pats)
654 = zonkPat te pat `thenNF_Tc` \ (pat', ids1) ->
655 zonkPats te pats `thenNF_Tc` \ (pats', ids2) ->
656 returnNF_Tc (pat':pats', ids1 `unionBags` ids2)