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(TcIdBndr), TcIdOcc(..),
15 SYN_IE(TcMonoBinds), SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcPat),
16 SYN_IE(TcExpr), SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), SYN_IE(TcMatch),
17 SYN_IE(TcQual), SYN_IE(TcStmt), SYN_IE(TcArithSeqInfo), SYN_IE(TcRecordBinds),
20 SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedBind),
21 SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedPat),
22 SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedArithSeqInfo),
23 SYN_IE(TypecheckedQual), SYN_IE(TypecheckedStmt),
24 SYN_IE(TypecheckedMatch), SYN_IE(TypecheckedHsModule),
25 SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS),
26 SYN_IE(TypecheckedRecordBinds),
28 mkHsTyApp, mkHsDictApp,
29 mkHsTyLam, mkHsDictLam,
39 import HsSyn -- oodles of it
40 import Id ( GenId(..), IdDetails, -- Can meddle modestly with Ids
41 SYN_IE(DictVar), idType,
42 SYN_IE(IdEnv), growIdEnvList, lookupIdEnv
46 import Name ( Name{--O only-} )
47 import TcMonad hiding ( rnMtoTcM )
48 import TcType ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar),
49 zonkTcTypeToType, zonkTcTyVarToTyVar
51 import Usage ( SYN_IE(UVar) )
52 import Util ( zipEqual, panic, pprPanic, pprTrace )
54 import PprType ( GenType, GenTyVar ) -- instances
55 import Type ( mkTyVarTy, tyVarsOfType )
56 import TyVar ( GenTyVar {- instances -},
57 SYN_IE(TyVarEnv), growTyVarEnvList, emptyTyVarSet )
58 import TysPrim ( voidTy )
59 import Unique ( Unique ) -- instances
69 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
70 All the types in @Tc...@ things have mutable type-variables in them for
73 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
74 which have immutable type variables in them.
77 type TcIdBndr s = GenId (TcType s) -- Binders are all TcTypes
78 data TcIdOcc s = TcId (TcIdBndr s) -- Bindees may be either
81 type TcHsBinds s = HsBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
82 type TcBind s = Bind (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
83 type TcMonoBinds s = MonoBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
84 type TcPat s = OutPat (TcTyVar s) UVar (TcIdOcc s)
85 type TcExpr s = HsExpr (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
86 type TcGRHSsAndBinds s = GRHSsAndBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
87 type TcGRHS s = GRHS (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
88 type TcMatch s = Match (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
89 type TcQual s = Qualifier (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
90 type TcStmt s = Stmt (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
91 type TcArithSeqInfo s = ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
92 type TcRecordBinds s = HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
93 type TcHsModule s = HsModule (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
95 type TypecheckedPat = OutPat TyVar UVar Id
96 type TypecheckedMonoBinds = MonoBinds TyVar UVar Id TypecheckedPat
97 type TypecheckedHsBinds = HsBinds TyVar UVar Id TypecheckedPat
98 type TypecheckedBind = Bind TyVar UVar Id TypecheckedPat
99 type TypecheckedHsExpr = HsExpr TyVar UVar Id TypecheckedPat
100 type TypecheckedArithSeqInfo = ArithSeqInfo TyVar UVar Id TypecheckedPat
101 type TypecheckedQual = Qualifier TyVar UVar Id TypecheckedPat
102 type TypecheckedStmt = Stmt TyVar UVar Id TypecheckedPat
103 type TypecheckedMatch = Match TyVar UVar Id TypecheckedPat
104 type TypecheckedGRHSsAndBinds = GRHSsAndBinds TyVar UVar Id TypecheckedPat
105 type TypecheckedGRHS = GRHS TyVar UVar Id TypecheckedPat
106 type TypecheckedRecordBinds = HsRecordBinds TyVar UVar Id TypecheckedPat
107 type TypecheckedHsModule = HsModule TyVar UVar Id TypecheckedPat
111 mkHsTyApp expr [] = expr
112 mkHsTyApp expr tys = TyApp expr tys
114 mkHsDictApp expr [] = expr
115 mkHsDictApp expr dict_vars = DictApp expr dict_vars
117 mkHsTyLam [] expr = expr
118 mkHsTyLam tyvars expr = TyLam tyvars expr
120 mkHsDictLam [] expr = expr
121 mkHsDictLam dicts expr = DictLam dicts expr
123 tcIdType :: TcIdOcc s -> TcType s
124 tcIdType (TcId id) = idType id
125 tcIdType (RealId id) = pprPanic "tcIdType:" (ppr PprDebug id)
127 tcIdTyVars (TcId id) = tyVarsOfType (idType id)
128 tcIdTyVars (RealId _) = emptyTyVarSet -- Top level Ids have no free type variables
132 instance Eq (TcIdOcc s) where
133 (TcId id1) == (TcId id2) = id1 == id2
134 (RealId id1) == (RealId id2) = id1 == id2
137 instance Outputable (TcIdOcc s) where
138 ppr sty (TcId id) = ppr sty id
139 ppr sty (RealId id) = ppr sty id
141 instance NamedThing (TcIdOcc s) where
142 getName (TcId id) = getName id
143 getName (RealId id) = getName id
147 %************************************************************************
149 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
151 %************************************************************************
153 This zonking pass runs over the bindings
155 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
156 b) convert unbound TcTyVar to Void
158 We pass an environment around so that
159 a) we know which TyVars are unbound
160 b) we maintain sharing; eg an Id is zonked at its binding site and they
161 all occurrences of that Id point to the common zonked copy
163 It's all pretty boring stuff, because HsSyn is such a large type, and
164 the environment manipulation is tiresome.
168 zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id
169 zonkIdBndr te (TcId (Id u n ty details prags info))
170 = zonkTcTypeToType te ty `thenNF_Tc` \ ty' ->
171 returnNF_Tc (Id u n ty' details prags info)
173 zonkIdBndr te (RealId id) = returnNF_Tc id
175 zonkIdOcc :: IdEnv Id -> TcIdOcc s -> Id
176 zonkIdOcc ve (RealId id) = id
177 zonkIdOcc ve (TcId id) = case (lookupIdEnv ve id) of
179 Nothing -> pprTrace "zonkIdOcc: " (ppr PprDebug id) $
180 Id u n voidTy details prags info
182 Id u n _ details prags info = id
184 extend_ve ve ids = growIdEnvList ve [(id,id) | id <- ids]
185 extend_te te tyvars = growTyVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars]
189 -- Implicitly mutually recursive, which is overkill,
190 -- but it means that later ones see earlier ones
191 zonkDictBinds te ve dbs
192 = fixNF_Tc (\ ~(_,new_ve) ->
193 zonkDictBindsLocal te new_ve dbs `thenNF_Tc` \ (new_binds, dict_ids) ->
194 returnNF_Tc (new_binds, extend_ve ve dict_ids)
197 -- The ..Local version assumes the caller has set up
198 -- a ve that contains all the things bound here
199 zonkDictBindsLocal te ve [] = returnNF_Tc ([], [])
201 zonkDictBindsLocal te ve ((dict,rhs) : binds)
202 = zonkIdBndr te dict `thenNF_Tc` \ new_dict ->
203 zonkExpr te ve rhs `thenNF_Tc` \ new_rhs ->
204 zonkDictBindsLocal te ve binds `thenNF_Tc` \ (new_binds, dict_ids) ->
205 returnNF_Tc ((new_dict,new_rhs) : new_binds,
210 zonkBinds :: TyVarEnv Type -> IdEnv Id
211 -> TcHsBinds s -> NF_TcM s (TypecheckedHsBinds, IdEnv Id)
213 zonkBinds te ve EmptyBinds = returnNF_Tc (EmptyBinds, ve)
215 zonkBinds te ve (ThenBinds binds1 binds2)
216 = zonkBinds te ve binds1 `thenNF_Tc` \ (new_binds1, ve1) ->
217 zonkBinds te ve1 binds2 `thenNF_Tc` \ (new_binds2, ve2) ->
218 returnNF_Tc (ThenBinds new_binds1 new_binds2, ve2)
220 zonkBinds te ve (SingleBind bind)
221 = fixNF_Tc (\ ~(_,new_ve) ->
222 zonkBind te new_ve bind `thenNF_Tc` \ (new_bind, new_ids) ->
223 returnNF_Tc (SingleBind new_bind, extend_ve ve new_ids)
226 zonkBinds te ve (AbsBinds tyvars dicts locprs dict_binds val_bind)
227 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
229 new_te = extend_te te new_tyvars
231 mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts ->
232 mapNF_Tc (zonkIdBndr new_te) globals `thenNF_Tc` \ new_globals ->
234 ve1 = extend_ve ve new_globals
235 ve2 = extend_ve ve1 new_dicts
237 fixNF_Tc (\ ~(_, ve3) ->
238 zonkDictBindsLocal new_te ve3 dict_binds `thenNF_Tc` \ (new_dict_binds, ds) ->
239 zonkBind new_te ve3 val_bind `thenNF_Tc` \ (new_val_bind, ls) ->
241 new_locprs = zipEqual "zonkBinds" (map (zonkIdOcc ve3) locals) new_globals
243 returnNF_Tc (AbsBinds new_tyvars new_dicts new_locprs new_dict_binds new_val_bind,
244 extend_ve ve2 (ds++ls))
245 ) `thenNF_Tc` \ (binds, _) ->
246 returnNF_Tc (binds, ve1) -- Yes, the "ve1" is right (SLPJ)
248 (locals, globals) = unzip locprs
252 -------------------------------------------------------------------------
253 zonkBind :: TyVarEnv Type -> IdEnv Id
254 -> TcBind s -> NF_TcM s (TypecheckedBind, [Id])
256 zonkBind te ve EmptyBind = returnNF_Tc (EmptyBind, [])
258 zonkBind te ve (NonRecBind mbinds)
259 = zonkMonoBinds te ve mbinds `thenNF_Tc` \ (new_mbinds, new_ids) ->
260 returnNF_Tc (NonRecBind new_mbinds, new_ids)
262 zonkBind te ve (RecBind mbinds)
263 = zonkMonoBinds te ve mbinds `thenNF_Tc` \ (new_mbinds, new_ids) ->
264 returnNF_Tc (RecBind new_mbinds, new_ids)
266 -------------------------------------------------------------------------
267 zonkMonoBinds :: TyVarEnv Type -> IdEnv Id
268 -> TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, [Id])
270 zonkMonoBinds te ve EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, [])
272 zonkMonoBinds te ve (AndMonoBinds mbinds1 mbinds2)
273 = zonkMonoBinds te ve mbinds1 `thenNF_Tc` \ (new_mbinds1, ids1) ->
274 zonkMonoBinds te ve mbinds2 `thenNF_Tc` \ (new_mbinds2, ids2) ->
275 returnNF_Tc (AndMonoBinds new_mbinds1 new_mbinds2, ids1 ++ ids2)
277 zonkMonoBinds te ve (PatMonoBind pat grhss_w_binds locn)
278 = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
279 zonkGRHSsAndBinds te ve grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
280 returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, ids)
282 zonkMonoBinds te ve (VarMonoBind var expr)
283 = zonkIdBndr te var `thenNF_Tc` \ new_var ->
284 zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
285 returnNF_Tc (VarMonoBind new_var new_expr, [new_var])
287 zonkMonoBinds te ve (FunMonoBind var inf ms locn)
288 = zonkIdBndr te var `thenNF_Tc` \ new_var ->
289 mapNF_Tc (zonkMatch te ve) ms `thenNF_Tc` \ new_ms ->
290 returnNF_Tc (FunMonoBind new_var inf new_ms locn, [new_var])
293 %************************************************************************
295 \subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds}
297 %************************************************************************
300 zonkMatch :: TyVarEnv Type -> IdEnv Id
301 -> TcMatch s -> NF_TcM s TypecheckedMatch
303 zonkMatch te ve (PatMatch pat match)
304 = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
306 new_ve = extend_ve ve ids
308 zonkMatch te new_ve match `thenNF_Tc` \ new_match ->
309 returnNF_Tc (PatMatch new_pat new_match)
311 zonkMatch te ve (GRHSMatch grhss_w_binds)
312 = zonkGRHSsAndBinds te ve grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
313 returnNF_Tc (GRHSMatch new_grhss_w_binds)
315 zonkMatch te ve (SimpleMatch expr)
316 = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
317 returnNF_Tc (SimpleMatch new_expr)
319 -------------------------------------------------------------------------
320 zonkGRHSsAndBinds :: TyVarEnv Type -> IdEnv Id
322 -> NF_TcM s TypecheckedGRHSsAndBinds
324 zonkGRHSsAndBinds te ve (GRHSsAndBindsOut grhss binds ty)
325 = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
327 zonk_grhs (GRHS guard expr locn)
328 = zonkExpr te new_ve guard `thenNF_Tc` \ new_guard ->
329 zonkExpr te new_ve expr `thenNF_Tc` \ new_expr ->
330 returnNF_Tc (GRHS new_guard new_expr locn)
332 zonk_grhs (OtherwiseGRHS expr locn)
333 = zonkExpr te new_ve expr `thenNF_Tc` \ new_expr ->
334 returnNF_Tc (OtherwiseGRHS new_expr locn)
336 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
337 zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
338 returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
341 %************************************************************************
343 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
345 %************************************************************************
348 zonkExpr :: TyVarEnv Type -> IdEnv Id
349 -> TcExpr s -> NF_TcM s TypecheckedHsExpr
351 zonkExpr te ve (HsVar name)
352 = returnNF_Tc (HsVar (zonkIdOcc ve name))
354 zonkExpr te ve (HsLit _) = panic "zonkExpr te ve:HsLit"
356 zonkExpr te ve (HsLitOut lit ty)
357 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
358 returnNF_Tc (HsLitOut lit new_ty)
360 zonkExpr te ve (HsLam match)
361 = zonkMatch te ve match `thenNF_Tc` \ new_match ->
362 returnNF_Tc (HsLam new_match)
364 zonkExpr te ve (HsApp e1 e2)
365 = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 ->
366 zonkExpr te ve e2 `thenNF_Tc` \ new_e2 ->
367 returnNF_Tc (HsApp new_e1 new_e2)
369 zonkExpr te ve (OpApp e1 op e2)
370 = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 ->
371 zonkExpr te ve op `thenNF_Tc` \ new_op ->
372 zonkExpr te ve e2 `thenNF_Tc` \ new_e2 ->
373 returnNF_Tc (OpApp new_e1 new_op new_e2)
375 zonkExpr te ve (NegApp _ _) = panic "zonkExpr te ve:NegApp"
376 zonkExpr te ve (HsPar _) = panic "zonkExpr te ve:HsPar"
378 zonkExpr te ve (SectionL expr op)
379 = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
380 zonkExpr te ve op `thenNF_Tc` \ new_op ->
381 returnNF_Tc (SectionL new_expr new_op)
383 zonkExpr te ve (SectionR op expr)
384 = zonkExpr te ve op `thenNF_Tc` \ new_op ->
385 zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
386 returnNF_Tc (SectionR new_op new_expr)
388 zonkExpr te ve (HsCase expr ms src_loc)
389 = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
390 mapNF_Tc (zonkMatch te ve) ms `thenNF_Tc` \ new_ms ->
391 returnNF_Tc (HsCase new_expr new_ms src_loc)
393 zonkExpr te ve (HsIf e1 e2 e3 src_loc)
394 = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 ->
395 zonkExpr te ve e2 `thenNF_Tc` \ new_e2 ->
396 zonkExpr te ve e3 `thenNF_Tc` \ new_e3 ->
397 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
399 zonkExpr te ve (HsLet binds expr)
400 = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
401 zonkExpr te new_ve expr `thenNF_Tc` \ new_expr ->
402 returnNF_Tc (HsLet new_binds new_expr)
404 zonkExpr te ve (HsDo _ _) = panic "zonkExpr te ve:HsDo"
406 zonkExpr te ve (HsDoOut stmts then_id zero_id src_loc)
407 = zonkStmts te ve stmts `thenNF_Tc` \ new_stmts ->
408 returnNF_Tc (HsDoOut new_stmts (zonkIdOcc ve then_id) (zonkIdOcc ve zero_id) src_loc)
410 zonkExpr te ve (ListComp expr quals)
411 = zonkQuals te ve quals `thenNF_Tc` \ (new_quals, new_ve) ->
412 zonkExpr te new_ve expr `thenNF_Tc` \ new_expr ->
413 returnNF_Tc (ListComp new_expr new_quals)
415 zonkExpr te ve (ExplicitList _) = panic "zonkExpr te ve:ExplicitList"
417 zonkExpr te ve (ExplicitListOut ty exprs)
418 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
419 mapNF_Tc (zonkExpr te ve) exprs `thenNF_Tc` \ new_exprs ->
420 returnNF_Tc (ExplicitListOut new_ty new_exprs)
422 zonkExpr te ve (ExplicitTuple exprs)
423 = mapNF_Tc (zonkExpr te ve) exprs `thenNF_Tc` \ new_exprs ->
424 returnNF_Tc (ExplicitTuple new_exprs)
426 zonkExpr te ve (RecordCon con rbinds)
427 = zonkExpr te ve con `thenNF_Tc` \ new_con ->
428 zonkRbinds te ve rbinds `thenNF_Tc` \ new_rbinds ->
429 returnNF_Tc (RecordCon new_con new_rbinds)
431 zonkExpr te ve (RecordUpd _ _) = panic "zonkExpr te ve:RecordUpd"
433 zonkExpr te ve (RecordUpdOut expr dicts rbinds)
434 = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
435 zonkRbinds te ve rbinds `thenNF_Tc` \ new_rbinds ->
436 returnNF_Tc (RecordUpdOut new_expr new_dicts new_rbinds)
438 new_dicts = map (zonkIdOcc ve) dicts
440 zonkExpr te ve (ExprWithTySig _ _) = panic "zonkExpr te ve:ExprWithTySig"
441 zonkExpr te ve (ArithSeqIn _) = panic "zonkExpr te ve:ArithSeqIn"
443 zonkExpr te ve (ArithSeqOut expr info)
444 = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
445 zonkArithSeq te ve info `thenNF_Tc` \ new_info ->
446 returnNF_Tc (ArithSeqOut new_expr new_info)
448 zonkExpr te ve (CCall fun args may_gc is_casm result_ty)
449 = mapNF_Tc (zonkExpr te ve) args `thenNF_Tc` \ new_args ->
450 zonkTcTypeToType te result_ty `thenNF_Tc` \ new_result_ty ->
451 returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
453 zonkExpr te ve (HsSCC label expr)
454 = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
455 returnNF_Tc (HsSCC label new_expr)
457 zonkExpr te ve (TyLam tyvars expr)
458 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
460 new_te = extend_te te new_tyvars
462 zonkExpr new_te ve expr `thenNF_Tc` \ new_expr ->
463 returnNF_Tc (TyLam new_tyvars new_expr)
465 zonkExpr te ve (TyApp expr tys)
466 = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
467 mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
468 returnNF_Tc (TyApp new_expr new_tys)
470 zonkExpr te ve (DictLam dicts expr)
471 = mapNF_Tc (zonkIdBndr te) dicts `thenNF_Tc` \ new_dicts ->
473 new_ve = extend_ve ve new_dicts
475 zonkExpr te new_ve expr `thenNF_Tc` \ new_expr ->
476 returnNF_Tc (DictLam new_dicts new_expr)
478 zonkExpr te ve (DictApp expr dicts)
479 = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
480 returnNF_Tc (DictApp new_expr new_dicts)
482 new_dicts = map (zonkIdOcc ve) dicts
484 zonkExpr te ve (ClassDictLam dicts methods expr)
485 = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
486 returnNF_Tc (ClassDictLam new_dicts new_methods new_expr)
488 new_dicts = map (zonkIdOcc ve) dicts
489 new_methods = map (zonkIdOcc ve) methods
492 zonkExpr te ve (Dictionary dicts methods)
493 = returnNF_Tc (Dictionary new_dicts new_methods)
495 new_dicts = map (zonkIdOcc ve) dicts
496 new_methods = map (zonkIdOcc ve) methods
498 zonkExpr te ve (SingleDict name)
499 = returnNF_Tc (SingleDict (zonkIdOcc ve name))
501 zonkExpr te ve (HsCon con tys vargs)
502 = mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
503 mapNF_Tc (zonkExpr te ve) vargs `thenNF_Tc` \ new_vargs ->
504 returnNF_Tc (HsCon con new_tys new_vargs)
506 -------------------------------------------------------------------------
507 zonkArithSeq :: TyVarEnv Type -> IdEnv Id
508 -> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
510 zonkArithSeq te ve (From e)
511 = zonkExpr te ve e `thenNF_Tc` \ new_e ->
512 returnNF_Tc (From new_e)
514 zonkArithSeq te ve (FromThen e1 e2)
515 = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 ->
516 zonkExpr te ve e2 `thenNF_Tc` \ new_e2 ->
517 returnNF_Tc (FromThen new_e1 new_e2)
519 zonkArithSeq te ve (FromTo e1 e2)
520 = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 ->
521 zonkExpr te ve e2 `thenNF_Tc` \ new_e2 ->
522 returnNF_Tc (FromTo new_e1 new_e2)
524 zonkArithSeq te ve (FromThenTo e1 e2 e3)
525 = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 ->
526 zonkExpr te ve e2 `thenNF_Tc` \ new_e2 ->
527 zonkExpr te ve e3 `thenNF_Tc` \ new_e3 ->
528 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
530 -------------------------------------------------------------------------
531 zonkQuals :: TyVarEnv Type -> IdEnv Id
532 -> [TcQual s] -> NF_TcM s ([TypecheckedQual], IdEnv Id)
535 = returnNF_Tc ([], ve)
537 zonkQuals te ve (GeneratorQual pat expr : quals)
538 = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
539 zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
541 new_ve = extend_ve ve ids
543 zonkQuals te new_ve quals `thenNF_Tc` \ (new_quals, final_ve) ->
544 returnNF_Tc (GeneratorQual new_pat new_expr : new_quals, final_ve)
546 zonkQuals te ve (FilterQual expr : quals)
547 = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
548 zonkQuals te ve quals `thenNF_Tc` \ (new_quals, final_ve) ->
549 returnNF_Tc (FilterQual new_expr : new_quals, final_ve)
551 zonkQuals te ve (LetQual binds : quals)
552 = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
553 zonkQuals te new_ve quals `thenNF_Tc` \ (new_quals, final_ve) ->
554 returnNF_Tc (LetQual new_binds : new_quals, final_ve)
556 -------------------------------------------------------------------------
557 zonkStmts :: TyVarEnv Type -> IdEnv Id
558 -> [TcStmt s] -> NF_TcM s [TypecheckedStmt]
560 zonkStmts te ve [] = returnNF_Tc []
562 zonkStmts te ve [ExprStmt expr locn]
563 = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
564 returnNF_Tc [ExprStmt new_expr locn]
566 zonkStmts te ve (ExprStmtOut expr locn a b : stmts)
567 = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
568 zonkTcTypeToType te a `thenNF_Tc` \ new_a ->
569 zonkTcTypeToType te b `thenNF_Tc` \ new_b ->
570 zonkStmts te ve stmts `thenNF_Tc` \ new_stmts ->
571 returnNF_Tc (ExprStmtOut new_expr locn new_a new_b : new_stmts)
573 zonkStmts te ve (LetStmt binds : stmts)
574 = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
575 zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts ->
576 returnNF_Tc (LetStmt new_binds : new_stmts)
578 zonkStmts te ve (BindStmtOut pat expr locn a b : stmts)
579 = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
580 zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
581 zonkTcTypeToType te a `thenNF_Tc` \ new_a ->
582 zonkTcTypeToType te b `thenNF_Tc` \ new_b ->
584 new_ve = extend_ve ve ids
586 zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts ->
587 returnNF_Tc (BindStmtOut new_pat new_expr locn new_a new_b : new_stmts)
591 -------------------------------------------------------------------------
592 zonkRbinds :: TyVarEnv Type -> IdEnv Id
593 -> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds
595 zonkRbinds te ve rbinds
596 = mapNF_Tc zonk_rbind rbinds
598 zonk_rbind (field, expr, pun)
599 = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
600 returnNF_Tc (zonkIdOcc ve field, new_expr, pun)
603 %************************************************************************
605 \subsection[BackSubst-Pats]{Patterns}
607 %************************************************************************
610 zonkPat :: TyVarEnv Type -> IdEnv Id
611 -> TcPat s -> NF_TcM s (TypecheckedPat, [Id])
613 zonkPat te ve (WildPat ty)
614 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
615 returnNF_Tc (WildPat new_ty, [])
617 zonkPat te ve (VarPat v)
618 = zonkIdBndr te v `thenNF_Tc` \ new_v ->
619 returnNF_Tc (VarPat new_v, [new_v])
621 zonkPat te ve (LazyPat pat)
622 = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
623 returnNF_Tc (LazyPat new_pat, ids)
625 zonkPat te ve (AsPat n pat)
626 = zonkIdBndr te n `thenNF_Tc` \ new_n ->
627 zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
628 returnNF_Tc (AsPat new_n new_pat, new_n:ids)
630 zonkPat te ve (ConPat n ty pats)
631 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
632 zonkPats te ve pats `thenNF_Tc` \ (new_pats, ids) ->
633 returnNF_Tc (ConPat n new_ty new_pats, ids)
635 zonkPat te ve (ConOpPat pat1 op pat2 ty)
636 = zonkPat te ve pat1 `thenNF_Tc` \ (new_pat1, ids1) ->
637 zonkPat te ve pat2 `thenNF_Tc` \ (new_pat2, ids2) ->
638 zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
639 returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty, ids1 ++ ids2)
641 zonkPat te ve (ListPat ty pats)
642 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
643 zonkPats te ve pats `thenNF_Tc` \ (new_pats, ids) ->
644 returnNF_Tc (ListPat new_ty new_pats, ids)
646 zonkPat te ve (TuplePat pats)
647 = zonkPats te ve pats `thenNF_Tc` \ (new_pats, ids) ->
648 returnNF_Tc (TuplePat new_pats, ids)
650 zonkPat te ve (RecPat n ty rpats)
651 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
652 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
653 returnNF_Tc (RecPat n new_ty new_rpats, concat ids_s)
655 zonk_rpat (f, pat, pun)
656 = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
657 returnNF_Tc ((f, new_pat, pun), ids)
659 zonkPat te ve (LitPat lit ty)
660 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
661 returnNF_Tc (LitPat lit new_ty, [])
663 zonkPat te ve (NPat lit ty expr)
664 = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
665 zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
666 returnNF_Tc (NPat lit new_ty new_expr, [])
668 zonkPat te ve (DictPat ds ms)
669 = mapNF_Tc (zonkIdBndr te) ds `thenNF_Tc` \ new_ds ->
670 mapNF_Tc (zonkIdBndr te) ms `thenNF_Tc` \ new_ms ->
671 returnNF_Tc (DictPat new_ds new_ms, new_ds ++ new_ms)
675 = returnNF_Tc ([], [])
676 zonkPats te ve (pat:pats)
677 = zonkPat te ve pat `thenNF_Tc` \ (pat', ids1) ->
678 zonkPats te ve pats `thenNF_Tc` \ (pats', ids2) ->
679 returnNF_Tc (pat':pats', ids1 ++ ids2)