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 ( idType, dataConArgTys, mkIdWithNewType, Id
43 import Name ( NamedThing(..) )
44 import BasicTypes ( IfaceFlavour, Unused )
45 import TcEnv ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv,
46 TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId
50 import TcType ( TcType, TcMaybe, TcTyVar, TcBox,
51 zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType
53 import TyCon ( isDataTyCon )
54 import Type ( mkTyVarTy, splitAlgTyConApp_maybe, isUnpointedType, Type )
55 import TyVar ( TyVar, TyVarEnv, emptyTyVarEnv, growTyVarEnvList )
56 import TysPrim ( voidTy )
57 import CoreSyn ( GenCoreExpr )
58 import Unique ( Unique ) -- instances
68 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
69 All the types in @Tc...@ things have mutable type-variables in them for
72 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
73 which have immutable type variables in them.
76 type TcHsBinds s = HsBinds (TcBox s) (TcIdOcc s) (TcPat s)
77 type TcMonoBinds s = MonoBinds (TcBox s) (TcIdOcc s) (TcPat s)
78 type TcDictBinds s = TcMonoBinds s
79 type TcPat s = OutPat (TcBox s) (TcIdOcc s)
80 type TcExpr s = HsExpr (TcBox s) (TcIdOcc s) (TcPat s)
81 type TcGRHSsAndBinds s = GRHSsAndBinds (TcBox s) (TcIdOcc s) (TcPat s)
82 type TcGRHS s = GRHS (TcBox s) (TcIdOcc s) (TcPat s)
83 type TcMatch s = Match (TcBox s) (TcIdOcc s) (TcPat s)
84 type TcStmt s = Stmt (TcBox s) (TcIdOcc s) (TcPat s)
85 type TcArithSeqInfo s = ArithSeqInfo (TcBox s) (TcIdOcc s) (TcPat s)
86 type TcRecordBinds s = HsRecordBinds (TcBox s) (TcIdOcc s) (TcPat s)
87 type TcHsModule s = HsModule (TcBox s) (TcIdOcc s) (TcPat s)
89 type TcCoreExpr s = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcBox s)
91 type TypecheckedPat = OutPat Unused Id
92 type TypecheckedMonoBinds = MonoBinds Unused Id TypecheckedPat
93 type TypecheckedDictBinds = TypecheckedMonoBinds
94 type TypecheckedHsBinds = HsBinds Unused Id TypecheckedPat
95 type TypecheckedHsExpr = HsExpr Unused Id TypecheckedPat
96 type TypecheckedArithSeqInfo = ArithSeqInfo Unused Id TypecheckedPat
97 type TypecheckedStmt = Stmt Unused Id TypecheckedPat
98 type TypecheckedMatch = Match Unused Id TypecheckedPat
99 type TypecheckedGRHSsAndBinds = GRHSsAndBinds Unused Id TypecheckedPat
100 type TypecheckedGRHS = GRHS Unused Id TypecheckedPat
101 type TypecheckedRecordBinds = HsRecordBinds Unused Id TypecheckedPat
102 type TypecheckedHsModule = HsModule Unused 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
119 %************************************************************************
121 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
123 %************************************************************************
125 Some gruesome hackery for desugaring ccalls. It's here because if we put it
126 in Type.lhs we get irritating loops, and it's only used by TcInstDcls.lhs and
130 maybeBoxedPrimType :: Type -> Maybe (Id, Type)
131 maybeBoxedPrimType ty
132 = case splitAlgTyConApp_maybe ty of -- Data type,
133 Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon -- with exactly one constructor
134 -> case (dataConArgTys data_con tys_applied) of
135 [data_con_arg_ty] -- Applied to exactly one type,
136 | isUnpointedType data_con_arg_ty -- which is primitive
137 -> Just (data_con, data_con_arg_ty)
138 other_cases -> Nothing
139 other_cases -> Nothing
142 %************************************************************************
144 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
146 %************************************************************************
148 @zonkTcId@ just works on TcIdOccs. It's used when zonking Method insts.
151 zonkTcId :: TcIdOcc s -> NF_TcM s (TcIdOcc s)
152 zonkTcId tc_id@(RealId id) = returnNF_Tc tc_id
154 = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
155 returnNF_Tc (TcId (mkIdWithNewType id ty'))
158 This zonking pass runs over the bindings
160 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
161 b) convert unbound TcTyVar to Void
162 c) convert each TcIdBndr to an Id by zonking its type
164 We pass an environment around so that
166 a) we know which TyVars are unbound
167 b) we maintain sharing; eg an Id is zonked at its binding site and they
168 all occurrences of that Id point to the common zonked copy
170 Actually, since this is all in the Tc monad, it's convenient to keep the
171 mapping from TcIds to Ids in the GVE of the Tc monad. (Those TcIds
172 were previously in the LVE of the Tc monad.)
174 It's all pretty boring stuff, because HsSyn is such a large type, and
175 the environment manipulation is tiresome.
178 extend_te te tyvars = growTyVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars]
180 zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id
181 zonkIdBndr te (RealId id) = returnNF_Tc id
182 zonkIdBndr te (TcId id)
183 = zonkTcTypeToType te (idType id) `thenNF_Tc` \ ty' ->
184 returnNF_Tc (mkIdWithNewType id ty')
187 zonkIdOcc :: TcIdOcc s -> NF_TcM s Id
188 zonkIdOcc (RealId id) = returnNF_Tc id
190 = tcLookupGlobalValueMaybe (getName id) `thenNF_Tc` \ maybe_id' ->
192 new_id = case maybe_id' of
194 Nothing -> pprTrace "zonkIdOcc: " (ppr id) $
195 mkIdWithNewType id voidTy
202 zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, TcEnv s)
203 zonkTopBinds binds -- Top level is implicitly recursive
204 = fixNF_Tc (\ ~(_, new_ids) ->
205 tcExtendGlobalValEnv (bagToList new_ids) $
206 zonkMonoBinds emptyTyVarEnv binds `thenNF_Tc` \ (binds', new_ids) ->
207 tcGetEnv `thenNF_Tc` \ env ->
208 returnNF_Tc ((binds', env), new_ids)
209 ) `thenNF_Tc` \ (stuff, _) ->
213 zonkBinds :: TyVarEnv Type
215 -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
218 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env -> returnNF_Tc (binds', env))
220 -- go :: TcHsBinds s -> (TypecheckedHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv s))
221 -- -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
222 go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
224 thing_inside (b1' `ThenBinds` b2')
226 go EmptyBinds thing_inside = thing_inside EmptyBinds
228 go (MonoBind bind sigs is_rec) thing_inside
229 = ASSERT( null sigs )
230 fixNF_Tc (\ ~(_, new_ids) ->
231 tcExtendGlobalValEnv (bagToList new_ids) $
232 zonkMonoBinds te bind `thenNF_Tc` \ (new_bind, new_ids) ->
233 thing_inside (MonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
234 returnNF_Tc (stuff, new_ids)
235 ) `thenNF_Tc` \ (stuff, _) ->
240 -------------------------------------------------------------------------
241 zonkMonoBinds :: TyVarEnv Type
243 -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
245 zonkMonoBinds te EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
247 zonkMonoBinds te (AndMonoBinds mbinds1 mbinds2)
248 = zonkMonoBinds te mbinds1 `thenNF_Tc` \ (b1', ids1) ->
249 zonkMonoBinds te mbinds2 `thenNF_Tc` \ (b2', ids2) ->
250 returnNF_Tc (b1' `AndMonoBinds` b2', ids1 `unionBags` ids2)
252 zonkMonoBinds te (PatMonoBind pat grhss_w_binds locn)
253 = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
254 zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
255 returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, ids)
257 zonkMonoBinds te (VarMonoBind var expr)
258 = zonkIdBndr te var `thenNF_Tc` \ new_var ->
259 zonkExpr te expr `thenNF_Tc` \ new_expr ->
260 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
262 zonkMonoBinds te (CoreMonoBind var core_expr)
263 = zonkIdBndr te var `thenNF_Tc` \ new_var ->
264 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
266 zonkMonoBinds te (FunMonoBind var inf ms locn)
267 = zonkIdBndr te var `thenNF_Tc` \ new_var ->
268 mapNF_Tc (zonkMatch te) ms `thenNF_Tc` \ new_ms ->
269 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
272 zonkMonoBinds te (AbsBinds tyvars dicts exports val_bind)
273 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
275 new_te = extend_te te new_tyvars
277 mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts ->
279 tcExtendGlobalValEnv new_dicts $
280 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
281 tcExtendGlobalValEnv (bagToList val_bind_ids) $
282 zonkMonoBinds new_te val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
283 mapNF_Tc (zonkExport new_te) exports `thenNF_Tc` \ new_exports ->
284 returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
285 ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
287 new_globals = listToBag [global | (_, global, local) <- new_exports]
289 returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports new_val_bind,
292 zonkExport te (tyvars, global, local)
293 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
294 zonkIdBndr te global `thenNF_Tc` \ new_global ->
295 zonkIdOcc local `thenNF_Tc` \ new_local ->
296 returnNF_Tc (new_tyvars, new_global, new_local)
299 %************************************************************************
301 \subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds}
303 %************************************************************************
306 zonkMatch :: TyVarEnv Type
307 -> TcMatch s -> NF_TcM s TypecheckedMatch
309 zonkMatch te (PatMatch pat match)
310 = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
311 tcExtendGlobalValEnv (bagToList ids) $
312 zonkMatch te match `thenNF_Tc` \ new_match ->
313 returnNF_Tc (PatMatch new_pat new_match)
315 zonkMatch te (GRHSMatch grhss_w_binds)
316 = zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
317 returnNF_Tc (GRHSMatch new_grhss_w_binds)
319 zonkMatch te (SimpleMatch expr)
320 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
321 returnNF_Tc (SimpleMatch new_expr)
323 -------------------------------------------------------------------------
324 zonkGRHSsAndBinds :: TyVarEnv Type
326 -> NF_TcM s TypecheckedGRHSsAndBinds
328 zonkGRHSsAndBinds te (GRHSsAndBindsOut grhss binds ty)
329 = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) ->
332 zonk_grhs (GRHS guard expr locn)
333 = zonkStmts te guard `thenNF_Tc` \ (new_guard, new_env) ->
335 zonkExpr te expr `thenNF_Tc` \ new_expr ->
336 returnNF_Tc (GRHS new_guard new_expr locn)
338 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
339 zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
340 returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
343 %************************************************************************
345 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
347 %************************************************************************
350 zonkExpr :: TyVarEnv Type
351 -> TcExpr s -> NF_TcM s TypecheckedHsExpr
353 zonkExpr te (HsVar id)
354 = zonkIdOcc id `thenNF_Tc` \ id' ->
355 returnNF_Tc (HsVar id')
357 zonkExpr te (HsLit _) = panic "zonkExpr te:HsLit"
359 zonkExpr te (HsLitOut lit ty)
360 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
361 returnNF_Tc (HsLitOut lit new_ty)
363 zonkExpr te (HsLam match)
364 = zonkMatch te match `thenNF_Tc` \ new_match ->
365 returnNF_Tc (HsLam new_match)
367 zonkExpr te (HsApp e1 e2)
368 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
369 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
370 returnNF_Tc (HsApp new_e1 new_e2)
372 zonkExpr te (OpApp e1 op fixity e2)
373 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
374 zonkExpr te op `thenNF_Tc` \ new_op ->
375 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
376 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
378 zonkExpr te (NegApp _ _) = panic "zonkExpr te:NegApp"
379 zonkExpr te (HsPar _) = panic "zonkExpr te:HsPar"
381 zonkExpr te (SectionL expr op)
382 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
383 zonkExpr te op `thenNF_Tc` \ new_op ->
384 returnNF_Tc (SectionL new_expr new_op)
386 zonkExpr te (SectionR op expr)
387 = zonkExpr te op `thenNF_Tc` \ new_op ->
388 zonkExpr te expr `thenNF_Tc` \ new_expr ->
389 returnNF_Tc (SectionR new_op new_expr)
391 zonkExpr te (HsCase expr ms src_loc)
392 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
393 mapNF_Tc (zonkMatch te) ms `thenNF_Tc` \ new_ms ->
394 returnNF_Tc (HsCase new_expr new_ms src_loc)
396 zonkExpr te (HsIf e1 e2 e3 src_loc)
397 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
398 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
399 zonkExpr te e3 `thenNF_Tc` \ new_e3 ->
400 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
402 zonkExpr te (HsLet binds expr)
403 = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) ->
405 zonkExpr te expr `thenNF_Tc` \ new_expr ->
406 returnNF_Tc (HsLet new_binds new_expr)
408 zonkExpr te (HsDo _ _ _) = panic "zonkExpr te:HsDo"
410 zonkExpr te (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
411 = zonkStmts te stmts `thenNF_Tc` \ (new_stmts, _) ->
412 zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
413 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
414 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
415 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
416 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
419 zonkExpr te (ExplicitList _) = panic "zonkExpr te:ExplicitList"
421 zonkExpr te (ExplicitListOut ty exprs)
422 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
423 mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs ->
424 returnNF_Tc (ExplicitListOut new_ty new_exprs)
426 zonkExpr te (ExplicitTuple exprs)
427 = mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs ->
428 returnNF_Tc (ExplicitTuple new_exprs)
430 zonkExpr te (HsCon con_id tys exprs)
431 = mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
432 mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs ->
433 returnNF_Tc (HsCon con_id new_tys new_exprs)
435 zonkExpr te (RecordCon con_id con_expr rbinds)
436 = zonkIdOcc con_id `thenNF_Tc` \ new_con_id ->
437 zonkExpr te con_expr `thenNF_Tc` \ new_con_expr ->
438 zonkRbinds te rbinds `thenNF_Tc` \ new_rbinds ->
439 returnNF_Tc (RecordCon new_con_id new_con_expr new_rbinds)
441 zonkExpr te (RecordUpd _ _) = panic "zonkExpr te:RecordUpd"
443 zonkExpr te (RecordUpdOut expr ty dicts rbinds)
444 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
445 zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
446 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
447 zonkRbinds te rbinds `thenNF_Tc` \ new_rbinds ->
448 returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
450 zonkExpr te (ExprWithTySig _ _) = panic "zonkExpr te:ExprWithTySig"
451 zonkExpr te (ArithSeqIn _) = panic "zonkExpr te:ArithSeqIn"
453 zonkExpr te (ArithSeqOut expr info)
454 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
455 zonkArithSeq te info `thenNF_Tc` \ new_info ->
456 returnNF_Tc (ArithSeqOut new_expr new_info)
458 zonkExpr te (CCall fun args may_gc is_casm result_ty)
459 = mapNF_Tc (zonkExpr te) args `thenNF_Tc` \ new_args ->
460 zonkTcTypeToType te result_ty `thenNF_Tc` \ new_result_ty ->
461 returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
463 zonkExpr te (HsSCC label expr)
464 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
465 returnNF_Tc (HsSCC label new_expr)
467 zonkExpr te (TyLam tyvars expr)
468 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
470 new_te = extend_te te new_tyvars
472 zonkExpr new_te expr `thenNF_Tc` \ new_expr ->
473 returnNF_Tc (TyLam new_tyvars new_expr)
475 zonkExpr te (TyApp expr tys)
476 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
477 mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
478 returnNF_Tc (TyApp new_expr new_tys)
480 zonkExpr te (DictLam dicts expr)
481 = mapNF_Tc (zonkIdBndr te) dicts `thenNF_Tc` \ new_dicts ->
482 tcExtendGlobalValEnv new_dicts $
483 zonkExpr te expr `thenNF_Tc` \ new_expr ->
484 returnNF_Tc (DictLam new_dicts new_expr)
486 zonkExpr te (DictApp expr dicts)
487 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
488 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
489 returnNF_Tc (DictApp new_expr new_dicts)
493 -------------------------------------------------------------------------
494 zonkArithSeq :: TyVarEnv Type
495 -> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
497 zonkArithSeq te (From e)
498 = zonkExpr te e `thenNF_Tc` \ new_e ->
499 returnNF_Tc (From new_e)
501 zonkArithSeq te (FromThen e1 e2)
502 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
503 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
504 returnNF_Tc (FromThen new_e1 new_e2)
506 zonkArithSeq te (FromTo e1 e2)
507 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
508 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
509 returnNF_Tc (FromTo new_e1 new_e2)
511 zonkArithSeq te (FromThenTo e1 e2 e3)
512 = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
513 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
514 zonkExpr te e3 `thenNF_Tc` \ new_e3 ->
515 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
517 -------------------------------------------------------------------------
518 zonkStmts :: TyVarEnv Type
519 -> [TcStmt s] -> NF_TcM s ([TypecheckedStmt], TcEnv s)
521 zonkStmts te [] = tcGetEnv `thenNF_Tc` \ env ->
522 returnNF_Tc ([], env)
524 zonkStmts te [ReturnStmt expr]
525 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
526 tcGetEnv `thenNF_Tc` \ env ->
527 returnNF_Tc ([ReturnStmt new_expr], env)
529 zonkStmts te (ExprStmt expr locn : stmts)
530 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
531 zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) ->
532 returnNF_Tc (ExprStmt new_expr locn : new_stmts, new_env)
534 zonkStmts te (GuardStmt expr locn : stmts)
535 = zonkExpr te expr `thenNF_Tc` \ new_expr ->
536 zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) ->
537 returnNF_Tc (GuardStmt new_expr locn : new_stmts, new_env)
539 zonkStmts te (LetStmt binds : stmts)
540 = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) ->
542 zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env2) ->
543 returnNF_Tc (LetStmt new_binds : new_stmts, new_env2)
545 zonkStmts te (BindStmt pat expr locn : stmts)
546 = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
547 zonkExpr te expr `thenNF_Tc` \ new_expr ->
548 tcExtendGlobalValEnv (bagToList ids) $
549 zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) ->
550 returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts, new_env)
554 -------------------------------------------------------------------------
555 zonkRbinds :: TyVarEnv Type
556 -> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds
559 = mapNF_Tc zonk_rbind rbinds
561 zonk_rbind (field, expr, pun)
562 = zonkExpr te 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 :: TyVarEnv Type
575 -> TcPat s -> NF_TcM s (TypecheckedPat, Bag Id)
577 zonkPat te (WildPat ty)
578 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
579 returnNF_Tc (WildPat new_ty, emptyBag)
581 zonkPat te (VarPat v)
582 = zonkIdBndr te v `thenNF_Tc` \ new_v ->
583 returnNF_Tc (VarPat new_v, unitBag new_v)
585 zonkPat te (LazyPat pat)
586 = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
587 returnNF_Tc (LazyPat new_pat, ids)
589 zonkPat te (AsPat n pat)
590 = zonkIdBndr te n `thenNF_Tc` \ new_n ->
591 zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
592 returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
594 zonkPat te (ConPat n ty pats)
595 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
596 zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
597 returnNF_Tc (ConPat n new_ty new_pats, ids)
599 zonkPat te (ConOpPat pat1 op pat2 ty)
600 = zonkPat te pat1 `thenNF_Tc` \ (new_pat1, ids1) ->
601 zonkPat te pat2 `thenNF_Tc` \ (new_pat2, ids2) ->
602 zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
603 returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty, ids1 `unionBags` ids2)
605 zonkPat te (ListPat ty pats)
606 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
607 zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
608 returnNF_Tc (ListPat new_ty new_pats, ids)
610 zonkPat te (TuplePat pats)
611 = zonkPats te pats `thenNF_Tc` \ (new_pats, ids) ->
612 returnNF_Tc (TuplePat new_pats, ids)
614 zonkPat te (RecPat n ty rpats)
615 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
616 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
617 returnNF_Tc (RecPat n new_ty new_rpats, unionManyBags ids_s)
619 zonk_rpat (f, pat, pun)
620 = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) ->
621 returnNF_Tc ((f, new_pat, pun), ids)
623 zonkPat te (LitPat lit ty)
624 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
625 returnNF_Tc (LitPat lit new_ty, emptyBag)
627 zonkPat te (NPat lit ty expr)
628 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
629 zonkExpr te expr `thenNF_Tc` \ new_expr ->
630 returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
632 zonkPat te (NPlusKPat n k ty e1 e2)
633 = zonkIdBndr te n `thenNF_Tc` \ new_n ->
634 zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
635 zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
636 zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
637 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
639 zonkPat te (DictPat ds ms)
640 = mapNF_Tc (zonkIdBndr te) ds `thenNF_Tc` \ new_ds ->
641 mapNF_Tc (zonkIdBndr te) ms `thenNF_Tc` \ new_ms ->
642 returnNF_Tc (DictPat new_ds new_ms,
643 listToBag new_ds `unionBags` listToBag new_ms)
647 = returnNF_Tc ([], emptyBag)
648 zonkPats te (pat:pats)
649 = zonkPat te pat `thenNF_Tc` \ (pat', ids1) ->
650 zonkPats te pats `thenNF_Tc` \ (pats', ids2) ->
651 returnNF_Tc (pat':pats', ids1 `unionBags` ids2)