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 )
54 import BasicTypes ( RecFlag(..), Boxity(..) )
57 import HscTypes ( TyThing(..) )
64 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
65 All the types in @Tc...@ things have mutable type-variables in them for
68 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
69 which have immutable type variables in them.
72 type TcHsBinds = HsBinds TcId TcPat
73 type TcMonoBinds = MonoBinds TcId TcPat
74 type TcDictBinds = TcMonoBinds
75 type TcPat = OutPat TcId
76 type TcExpr = HsExpr TcId TcPat
77 type TcGRHSs = GRHSs TcId TcPat
78 type TcGRHS = GRHS TcId TcPat
79 type TcMatch = Match TcId TcPat
80 type TcStmt = Stmt TcId TcPat
81 type TcArithSeqInfo = ArithSeqInfo TcId TcPat
82 type TcRecordBinds = HsRecordBinds TcId TcPat
83 type TcHsModule = HsModule TcId TcPat
85 type TcCoreExpr = Expr TcId
86 type TcForeignExportDecl = ForeignDecl TcId
87 type TcRuleDecl = RuleDecl TcId TcPat
89 type TypecheckedPat = OutPat Id
90 type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
91 type TypecheckedDictBinds = TypecheckedMonoBinds
92 type TypecheckedHsBinds = HsBinds Id TypecheckedPat
93 type TypecheckedHsExpr = HsExpr Id TypecheckedPat
94 type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat
95 type TypecheckedStmt = Stmt Id TypecheckedPat
96 type TypecheckedMatch = Match Id TypecheckedPat
97 type TypecheckedMatchContext = HsMatchContext Id
98 type TypecheckedGRHSs = GRHSs Id TypecheckedPat
99 type TypecheckedGRHS = GRHS Id TypecheckedPat
100 type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
101 type TypecheckedHsModule = HsModule Id TypecheckedPat
102 type TypecheckedForeignDecl = ForeignDecl Id
103 type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
107 mkHsTyApp expr [] = expr
108 mkHsTyApp expr tys = TyApp expr tys
110 mkHsDictApp expr [] = expr
111 mkHsDictApp expr dict_vars = DictApp expr dict_vars
113 mkHsTyLam [] expr = expr
114 mkHsTyLam tyvars expr = TyLam tyvars expr
116 mkHsDictLam [] expr = expr
117 mkHsDictLam dicts expr = DictLam dicts expr
119 mkHsLet EmptyMonoBinds expr = expr
120 mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
122 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
126 %************************************************************************
128 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
130 %************************************************************************
132 Note: If @outPatType@ doesn't bear a strong resemblance to @exprType@,
133 then something is wrong.
135 outPatType :: TypecheckedPat -> Type
137 outPatType (WildPat ty) = ty
138 outPatType (VarPat var) = idType var
139 outPatType (LazyPat pat) = outPatType pat
140 outPatType (AsPat var pat) = idType var
141 outPatType (ConPat _ ty _ _ _) = ty
142 outPatType (ListPat ty _) = mkListTy ty
143 outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats)
144 outPatType (RecPat _ ty _ _ _) = ty
145 outPatType (LitPat lit ty) = ty
146 outPatType (NPat lit ty _) = ty
147 outPatType (NPlusKPat _ _ ty _ _) = ty
148 outPatType (DictPat ds ms) = case (length ds_ms) of
150 1 -> idType (head ds_ms)
151 n -> mkTupleTy Boxed n (map idType ds_ms)
157 Nota bene: @DsBinds@ relies on the fact that at least for simple
158 tuple patterns @collectTypedPatBinders@ returns the binders in
159 the same order as they appear in the tuple.
161 @collectTypedBinders@ and @collectedTypedPatBinders@ are the exportees.
164 collectTypedPatBinders :: TypecheckedPat -> [Id]
165 collectTypedPatBinders (VarPat var) = [var]
166 collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat
167 collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat
168 collectTypedPatBinders (ConPat _ _ _ _ pats) = concat (map collectTypedPatBinders pats)
169 collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats)
170 collectTypedPatBinders (TuplePat pats _) = concat (map collectTypedPatBinders pats)
171 collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat)
173 collectTypedPatBinders (DictPat ds ms) = ds ++ ms
174 collectTypedPatBinders (NPlusKPat var _ _ _ _) = [var]
175 collectTypedPatBinders any_other_pat = [ {-no binders-} ]
179 %************************************************************************
181 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
183 %************************************************************************
185 This zonking pass runs over the bindings
187 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
188 b) convert unbound TcTyVar to Void
189 c) convert each TcId to an Id by zonking its type
191 The type variables are converted by binding mutable tyvars to immutable ones
192 and then zonking as normal.
194 The Ids are converted by binding them in the normal Tc envt; that
195 way we maintain sharing; eg an Id is zonked at its binding site and they
196 all occurrences of that Id point to the common zonked copy
198 It's all pretty boring stuff, because HsSyn is such a large type, and
199 the environment manipulation is tiresome.
202 -- zonkId is used *during* typechecking just to zonk the Id's type
203 zonkId :: TcId -> NF_TcM TcId
205 = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
206 returnNF_Tc (setIdType id ty')
208 -- zonkIdBndr is used *after* typechecking to get the Id's type
209 -- to its final form. The TyVarEnv give
210 zonkIdBndr :: TcId -> NF_TcM Id
212 = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' ->
213 returnNF_Tc (setIdType id ty')
215 zonkIdOcc :: TcId -> NF_TcM Id
217 = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' ->
218 -- We're even look up up superclass selectors and constructors;
219 -- even though zonking them is a no-op anyway, and the
220 -- superclass selectors aren't in the environment anyway.
221 -- But we don't want to call isLocalId to find out whether
222 -- it's a superclass selector (for example) because that looks
223 -- at the IdInfo field, which in turn be in a knot because of
224 -- the big knot in typecheckModule
226 new_id = case maybe_id' of
227 Just (AnId id') -> id'
228 other -> id -- WARN( isLocalId id, ppr id ) id
229 -- Oops: the warning can give a black hole
230 -- because it looks at the idinfo
237 zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
238 zonkTopBinds binds -- Top level is implicitly recursive
239 = fixNF_Tc (\ ~(_, new_ids) ->
240 tcExtendGlobalValEnv (bagToList new_ids) $
241 zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
242 tcGetEnv `thenNF_Tc` \ env ->
243 returnNF_Tc ((binds', env), new_ids)
244 ) `thenNF_Tc` \ (stuff, _) ->
247 zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
250 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
251 returnNF_Tc (binds', env))
254 -- -> (TypecheckedHsBinds
255 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
257 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
259 go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
261 thing_inside (b1' `ThenBinds` b2')
263 go EmptyBinds thing_inside = thing_inside EmptyBinds
265 go (MonoBind bind sigs is_rec) thing_inside
266 = ASSERT( null sigs )
267 fixNF_Tc (\ ~(_, new_ids) ->
268 tcExtendGlobalValEnv (bagToList new_ids) $
269 zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
270 thing_inside (mkMonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
271 returnNF_Tc (stuff, new_ids)
272 ) `thenNF_Tc` \ (stuff, _) ->
277 -------------------------------------------------------------------------
278 zonkMonoBinds :: TcMonoBinds
279 -> NF_TcM (TypecheckedMonoBinds, Bag Id)
281 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
283 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
284 = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
285 zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
286 returnNF_Tc (b1' `AndMonoBinds` b2',
287 ids1 `unionBags` ids2)
289 zonkMonoBinds (PatMonoBind pat grhss locn)
290 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
291 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
292 returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
294 zonkMonoBinds (VarMonoBind var expr)
295 = zonkIdBndr var `thenNF_Tc` \ new_var ->
296 zonkExpr expr `thenNF_Tc` \ new_expr ->
297 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
299 zonkMonoBinds (CoreMonoBind var core_expr)
300 = zonkIdBndr var `thenNF_Tc` \ new_var ->
301 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
303 zonkMonoBinds (FunMonoBind var inf ms locn)
304 = zonkIdBndr var `thenNF_Tc` \ new_var ->
305 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
306 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
309 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
310 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
311 -- No need to extend tyvar env: the effects are
312 -- propagated through binding the tyvars themselves
314 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
315 tcExtendGlobalValEnv new_dicts $
317 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
318 tcExtendGlobalValEnv (bagToList val_bind_ids) $
319 zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
320 mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports ->
321 returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
322 ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
324 new_globals = listToBag [global | (_, global, local) <- new_exports]
326 returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
329 zonkExport (tyvars, global, local)
330 = zonkTcSigTyVars tyvars `thenNF_Tc` \ new_tyvars ->
331 -- This isn't the binding occurrence of these tyvars
332 -- but they should *be* tyvars. Hence zonkTcSigTyVars.
333 zonkIdBndr global `thenNF_Tc` \ new_global ->
334 zonkIdOcc local `thenNF_Tc` \ new_local ->
335 returnNF_Tc (new_tyvars, new_global, new_local)
338 %************************************************************************
340 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
342 %************************************************************************
345 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
347 zonkMatch (Match pats _ grhss)
348 = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
349 tcExtendGlobalValEnv (bagToList new_ids) $
350 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
351 returnNF_Tc (Match new_pats Nothing new_grhss)
353 -------------------------------------------------------------------------
355 -> NF_TcM TypecheckedGRHSs
357 zonkGRHSs (GRHSs grhss binds ty)
358 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
361 zonk_grhs (GRHS guarded locn)
362 = zonkStmts guarded `thenNF_Tc` \ new_guarded ->
363 returnNF_Tc (GRHS new_guarded locn)
365 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
366 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
367 returnNF_Tc (GRHSs new_grhss new_binds new_ty)
370 %************************************************************************
372 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
374 %************************************************************************
377 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
380 = zonkIdOcc id `thenNF_Tc` \ id' ->
381 returnNF_Tc (HsVar id')
383 zonkExpr (HsIPVar id)
384 = zonkIdOcc id `thenNF_Tc` \ id' ->
385 returnNF_Tc (HsIPVar id')
387 zonkExpr (HsLit (HsRat f ty))
388 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
389 returnNF_Tc (HsLit (HsRat f new_ty))
391 zonkExpr (HsLit (HsLitLit lit ty))
392 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
393 returnNF_Tc (HsLit (HsLitLit lit new_ty))
396 = returnNF_Tc (HsLit lit)
398 -- HsOverLit doesn't appear in typechecker output
400 zonkExpr (HsLam match)
401 = zonkMatch match `thenNF_Tc` \ new_match ->
402 returnNF_Tc (HsLam new_match)
404 zonkExpr (HsApp e1 e2)
405 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
406 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
407 returnNF_Tc (HsApp new_e1 new_e2)
409 zonkExpr (OpApp e1 op fixity e2)
410 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
411 zonkExpr op `thenNF_Tc` \ new_op ->
412 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
413 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
415 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
416 zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
418 zonkExpr (SectionL expr op)
419 = zonkExpr expr `thenNF_Tc` \ new_expr ->
420 zonkExpr op `thenNF_Tc` \ new_op ->
421 returnNF_Tc (SectionL new_expr new_op)
423 zonkExpr (SectionR op expr)
424 = zonkExpr op `thenNF_Tc` \ new_op ->
425 zonkExpr expr `thenNF_Tc` \ new_expr ->
426 returnNF_Tc (SectionR new_op new_expr)
428 zonkExpr (HsCase expr ms src_loc)
429 = zonkExpr expr `thenNF_Tc` \ new_expr ->
430 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
431 returnNF_Tc (HsCase new_expr new_ms src_loc)
433 zonkExpr (HsIf e1 e2 e3 src_loc)
434 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
435 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
436 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
437 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
439 zonkExpr (HsLet binds expr)
440 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
442 zonkExpr expr `thenNF_Tc` \ new_expr ->
443 returnNF_Tc (HsLet new_binds new_expr)
445 zonkExpr (HsWith expr binds)
446 = zonkIPBinds binds `thenNF_Tc` \ new_binds ->
447 tcExtendGlobalValEnv (map fst new_binds) $
448 zonkExpr expr `thenNF_Tc` \ new_expr ->
449 returnNF_Tc (HsWith new_expr new_binds)
451 zonkIPBinds = mapNF_Tc zonkIPBind
453 zonkIdBndr n `thenNF_Tc` \ n' ->
454 zonkExpr e `thenNF_Tc` \ e' ->
457 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
459 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
460 = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
461 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
462 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
463 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
464 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
465 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
468 zonkExpr (ExplicitList ty exprs)
469 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
470 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
471 returnNF_Tc (ExplicitList new_ty new_exprs)
473 zonkExpr (ExplicitTuple exprs boxed)
474 = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
475 returnNF_Tc (ExplicitTuple new_exprs boxed)
477 zonkExpr (RecordConOut data_con con_expr rbinds)
478 = zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
479 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
480 returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
482 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
484 zonkExpr (RecordUpdOut expr in_ty out_ty dicts rbinds)
485 = zonkExpr expr `thenNF_Tc` \ new_expr ->
486 zonkTcTypeToType in_ty `thenNF_Tc` \ new_in_ty ->
487 zonkTcTypeToType out_ty `thenNF_Tc` \ new_out_ty ->
488 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
489 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
490 returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_dicts new_rbinds)
492 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
493 zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
495 zonkExpr (ArithSeqOut expr info)
496 = zonkExpr expr `thenNF_Tc` \ new_expr ->
497 zonkArithSeq info `thenNF_Tc` \ new_info ->
498 returnNF_Tc (ArithSeqOut new_expr new_info)
500 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
501 = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
502 zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
503 returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
505 zonkExpr (HsSCC lbl expr)
506 = zonkExpr expr `thenNF_Tc` \ new_expr ->
507 returnNF_Tc (HsSCC lbl new_expr)
509 zonkExpr (TyLam tyvars expr)
510 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
511 -- No need to extend tyvar env; see AbsBinds
513 zonkExpr expr `thenNF_Tc` \ new_expr ->
514 returnNF_Tc (TyLam new_tyvars new_expr)
516 zonkExpr (TyApp expr tys)
517 = zonkExpr expr `thenNF_Tc` \ new_expr ->
518 mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
519 returnNF_Tc (TyApp new_expr new_tys)
521 zonkExpr (DictLam dicts expr)
522 = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
523 tcExtendGlobalValEnv new_dicts $
524 zonkExpr expr `thenNF_Tc` \ new_expr ->
525 returnNF_Tc (DictLam new_dicts new_expr)
527 zonkExpr (DictApp expr dicts)
528 = zonkExpr expr `thenNF_Tc` \ new_expr ->
529 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
530 returnNF_Tc (DictApp new_expr new_dicts)
534 -------------------------------------------------------------------------
535 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
537 zonkArithSeq (From e)
538 = zonkExpr e `thenNF_Tc` \ new_e ->
539 returnNF_Tc (From new_e)
541 zonkArithSeq (FromThen e1 e2)
542 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
543 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
544 returnNF_Tc (FromThen new_e1 new_e2)
546 zonkArithSeq (FromTo e1 e2)
547 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
548 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
549 returnNF_Tc (FromTo new_e1 new_e2)
551 zonkArithSeq (FromThenTo e1 e2 e3)
552 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
553 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
554 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
555 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
557 -------------------------------------------------------------------------
558 zonkStmts :: [TcStmt]
559 -> NF_TcM [TypecheckedStmt]
561 zonkStmts [] = returnNF_Tc []
563 zonkStmts (ParStmtOut bndrstmtss : stmts)
564 = mapNF_Tc (mapNF_Tc zonkId) bndrss `thenNF_Tc` \ new_bndrss ->
565 let new_binders = concat new_bndrss in
566 mapNF_Tc zonkStmts stmtss `thenNF_Tc` \ new_stmtss ->
567 tcExtendGlobalValEnv new_binders $
568 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
569 returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
570 where (bndrss, stmtss) = unzip bndrstmtss
572 zonkStmts (ResultStmt expr locn : stmts)
573 = zonkExpr expr `thenNF_Tc` \ new_expr ->
574 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
575 returnNF_Tc (ResultStmt new_expr locn : new_stmts)
577 zonkStmts (ExprStmt expr ty locn : stmts)
578 = zonkExpr expr `thenNF_Tc` \ new_expr ->
579 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
580 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
581 returnNF_Tc (ExprStmt new_expr new_ty locn : new_stmts)
583 zonkStmts (LetStmt binds : stmts)
584 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
586 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
587 returnNF_Tc (LetStmt new_binds : new_stmts)
589 zonkStmts (BindStmt pat expr locn : stmts)
590 = zonkExpr expr `thenNF_Tc` \ new_expr ->
591 zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) ->
592 tcExtendGlobalValEnv (bagToList new_ids) $
593 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
594 returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
598 -------------------------------------------------------------------------
599 zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
602 = mapNF_Tc zonk_rbind rbinds
604 zonk_rbind (field, expr, pun)
605 = zonkExpr expr `thenNF_Tc` \ new_expr ->
606 zonkIdOcc field `thenNF_Tc` \ new_field ->
607 returnNF_Tc (new_field, new_expr, pun)
610 %************************************************************************
612 \subsection[BackSubst-Pats]{Patterns}
614 %************************************************************************
617 zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
620 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
621 returnNF_Tc (WildPat new_ty, emptyBag)
624 = zonkIdBndr v `thenNF_Tc` \ new_v ->
625 returnNF_Tc (VarPat new_v, unitBag new_v)
627 zonkPat (LazyPat pat)
628 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
629 returnNF_Tc (LazyPat new_pat, ids)
631 zonkPat (AsPat n pat)
632 = zonkIdBndr n `thenNF_Tc` \ new_n ->
633 zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
634 returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
636 zonkPat (ListPat ty pats)
637 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
638 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
639 returnNF_Tc (ListPat new_ty new_pats, ids)
641 zonkPat (TuplePat pats boxed)
642 = zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
643 returnNF_Tc (TuplePat new_pats boxed, ids)
645 zonkPat (ConPat n ty tvs dicts pats)
646 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
647 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
648 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
649 tcExtendGlobalValEnv new_dicts $
650 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
651 returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
652 listToBag new_dicts `unionBags` ids)
654 zonkPat (RecPat n ty tvs dicts rpats)
655 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
656 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
657 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
658 tcExtendGlobalValEnv new_dicts $
659 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
660 returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
661 listToBag new_dicts `unionBags` unionManyBags ids_s)
663 zonk_rpat (f, pat, pun)
664 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
665 returnNF_Tc ((f, new_pat, pun), ids)
667 zonkPat (LitPat lit ty)
668 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
669 returnNF_Tc (LitPat lit new_ty, emptyBag)
671 zonkPat (NPat lit ty expr)
672 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
673 zonkExpr expr `thenNF_Tc` \ new_expr ->
674 returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
676 zonkPat (NPlusKPat n k ty e1 e2)
677 = zonkIdBndr n `thenNF_Tc` \ new_n ->
678 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
679 zonkExpr e1 `thenNF_Tc` \ new_e1 ->
680 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
681 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
683 zonkPat (DictPat ds ms)
684 = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
685 mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
686 returnNF_Tc (DictPat new_ds new_ms,
687 listToBag new_ds `unionBags` listToBag new_ms)
691 = returnNF_Tc ([], emptyBag)
694 = zonkPat pat `thenNF_Tc` \ (pat', ids1) ->
695 zonkPats pats `thenNF_Tc` \ (pats', ids2) ->
696 returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
699 %************************************************************************
701 \subsection[BackSubst-Foreign]{Foreign exports}
703 %************************************************************************
707 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
708 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
710 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
711 zonkForeignExport (ForeignExport i hs_ty spec src_loc) =
712 zonkIdOcc i `thenNF_Tc` \ i' ->
713 returnNF_Tc (ForeignExport i' undefined spec src_loc)
717 zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
718 zonkRules rs = mapNF_Tc zonkRule rs
720 zonkRule (HsRule name act vars lhs rhs loc)
721 = mapNF_Tc zonk_bndr vars `thenNF_Tc` \ new_bndrs ->
722 tcExtendGlobalValEnv (filter isId new_bndrs) $
723 -- Type variables don't need an envt
724 -- They are bound through the mutable mechanism
725 zonkExpr lhs `thenNF_Tc` \ new_lhs ->
726 zonkExpr rhs `thenNF_Tc` \ new_rhs ->
727 returnNF_Tc (HsRule name act (map RuleBndr new_bndrs) new_lhs new_rhs loc)
728 -- I hate this map RuleBndr stuff
730 zonk_bndr (RuleBndr v)
731 | isId v = zonkIdBndr v
732 | otherwise = zonkTcTyVarToTyVar v
734 zonkRule (IfaceRuleOut fun rule)
735 = zonkIdOcc fun `thenNF_Tc` \ fun' ->
736 returnNF_Tc (IfaceRuleOut fun' rule)