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,
30 collectTypedPatBinders, outPatType,
32 -- re-exported from TcEnv
35 zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
36 zonkForeignExports, zonkRules
39 #include "HsVersions.h"
42 import HsSyn -- oodles of it
45 import Id ( idName, idType, setIdType, Id )
46 import DataCon ( dataConWrapId )
47 import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId )
51 import TcType ( TcType )
52 import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars )
53 import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
54 doublePrimTy, addrPrimTy
56 import TysWiredIn ( charTy, stringTy, intTy, integerTy,
57 mkListTy, mkTupleTy, unitTy )
58 import CoreSyn ( Expr )
60 import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName )
63 import HscTypes ( TyThing(..) )
70 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
71 All the types in @Tc...@ things have mutable type-variables in them for
74 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
75 which have immutable type variables in them.
78 type TcHsBinds = HsBinds TcId TcPat
79 type TcMonoBinds = MonoBinds TcId TcPat
80 type TcDictBinds = TcMonoBinds
81 type TcPat = OutPat TcId
82 type TcExpr = HsExpr TcId TcPat
83 type TcGRHSs = GRHSs TcId TcPat
84 type TcGRHS = GRHS TcId TcPat
85 type TcMatch = Match TcId TcPat
86 type TcStmt = Stmt TcId TcPat
87 type TcArithSeqInfo = ArithSeqInfo TcId TcPat
88 type TcRecordBinds = HsRecordBinds TcId TcPat
89 type TcHsModule = HsModule TcId TcPat
91 type TcCoreExpr = Expr TcId
92 type TcForeignExportDecl = ForeignDecl TcId
93 type TcRuleDecl = RuleDecl TcId TcPat
95 type TypecheckedPat = OutPat Id
96 type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
97 type TypecheckedDictBinds = TypecheckedMonoBinds
98 type TypecheckedHsBinds = HsBinds Id TypecheckedPat
99 type TypecheckedHsExpr = HsExpr Id TypecheckedPat
100 type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat
101 type TypecheckedStmt = Stmt Id TypecheckedPat
102 type TypecheckedMatch = Match Id TypecheckedPat
103 type TypecheckedMatchContext = HsMatchContext Id
104 type TypecheckedGRHSs = GRHSs Id TypecheckedPat
105 type TypecheckedGRHS = GRHS Id TypecheckedPat
106 type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
107 type TypecheckedHsModule = HsModule Id TypecheckedPat
108 type TypecheckedForeignDecl = ForeignDecl Id
109 type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
113 mkHsTyApp expr [] = expr
114 mkHsTyApp expr tys = TyApp expr tys
116 mkHsDictApp expr [] = expr
117 mkHsDictApp expr dict_vars = DictApp expr dict_vars
119 mkHsTyLam [] expr = expr
120 mkHsTyLam tyvars expr = TyLam tyvars expr
122 mkHsDictLam [] expr = expr
123 mkHsDictLam dicts expr = DictLam dicts expr
125 mkHsLet EmptyMonoBinds expr = expr
126 mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
128 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
132 ------------------------------------------------------
134 simpleHsLitTy :: HsLit -> TcType
135 simpleHsLitTy (HsCharPrim c) = charPrimTy
136 simpleHsLitTy (HsStringPrim s) = addrPrimTy
137 simpleHsLitTy (HsInt i) = intTy
138 simpleHsLitTy (HsInteger i) = integerTy
139 simpleHsLitTy (HsIntPrim i) = intPrimTy
140 simpleHsLitTy (HsFloatPrim f) = floatPrimTy
141 simpleHsLitTy (HsDoublePrim d) = doublePrimTy
142 simpleHsLitTy (HsChar c) = charTy
143 simpleHsLitTy (HsString str) = stringTy
147 %************************************************************************
149 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
151 %************************************************************************
153 Note: If @outPatType@ doesn't bear a strong resemblance to @exprType@,
154 then something is wrong.
156 outPatType :: TypecheckedPat -> Type
158 outPatType (WildPat ty) = ty
159 outPatType (VarPat var) = idType var
160 outPatType (LazyPat pat) = outPatType pat
161 outPatType (AsPat var pat) = idType var
162 outPatType (ConPat _ ty _ _ _) = ty
163 outPatType (ListPat ty _) = mkListTy ty
164 outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats)
165 outPatType (RecPat _ ty _ _ _) = ty
166 outPatType (SigPat _ ty _) = ty
167 outPatType (LitPat lit ty) = ty
168 outPatType (NPat lit ty _) = ty
169 outPatType (NPlusKPat _ _ ty _ _) = ty
170 outPatType (DictPat ds ms) = case (length ds_ms) of
172 1 -> idType (head ds_ms)
173 n -> mkTupleTy Boxed n (map idType ds_ms)
179 Nota bene: @DsBinds@ relies on the fact that at least for simple
180 tuple patterns @collectTypedPatBinders@ returns the binders in
181 the same order as they appear in the tuple.
183 @collectTypedBinders@ and @collectedTypedPatBinders@ are the exportees.
186 collectTypedPatBinders :: TypecheckedPat -> [Id]
187 collectTypedPatBinders (VarPat var) = [var]
188 collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat
189 collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat
190 collectTypedPatBinders (SigPat pat _ _) = collectTypedPatBinders pat
191 collectTypedPatBinders (ConPat _ _ _ _ pats) = concat (map collectTypedPatBinders pats)
192 collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats)
193 collectTypedPatBinders (TuplePat pats _) = concat (map collectTypedPatBinders pats)
194 collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat)
196 collectTypedPatBinders (DictPat ds ms) = ds ++ ms
197 collectTypedPatBinders (NPlusKPat var _ _ _ _) = [var]
198 collectTypedPatBinders any_other_pat = [ {-no binders-} ]
202 %************************************************************************
204 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
206 %************************************************************************
208 This zonking pass runs over the bindings
210 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
211 b) convert unbound TcTyVar to Void
212 c) convert each TcId to an Id by zonking its type
214 The type variables are converted by binding mutable tyvars to immutable ones
215 and then zonking as normal.
217 The Ids are converted by binding them in the normal Tc envt; that
218 way we maintain sharing; eg an Id is zonked at its binding site and they
219 all occurrences of that Id point to the common zonked copy
221 It's all pretty boring stuff, because HsSyn is such a large type, and
222 the environment manipulation is tiresome.
225 -- zonkId is used *during* typechecking just to zonk the Id's type
226 zonkId :: TcId -> NF_TcM TcId
228 = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
229 returnNF_Tc (setIdType id ty')
231 -- zonkIdBndr is used *after* typechecking to get the Id's type
232 -- to its final form. The TyVarEnv give
233 zonkIdBndr :: TcId -> NF_TcM Id
235 = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' ->
236 returnNF_Tc (setIdType id ty')
238 zonkIdOcc :: TcId -> NF_TcM Id
240 = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' ->
241 -- We're even look up up superclass selectors and constructors;
242 -- even though zonking them is a no-op anyway, and the
243 -- superclass selectors aren't in the environment anyway.
244 -- But we don't want to call isLocalId to find out whether
245 -- it's a superclass selector (for example) because that looks
246 -- at the IdInfo field, which in turn be in a knot because of
247 -- the big knot in typecheckModule
249 new_id = case maybe_id' of
250 Just (AnId id') -> id'
251 other -> id -- WARN( isLocalId id, ppr id ) id
252 -- Oops: the warning can give a black hole
253 -- because it looks at the idinfo
260 zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
261 zonkTopBinds binds -- Top level is implicitly recursive
262 = fixNF_Tc (\ ~(_, new_ids) ->
263 tcExtendGlobalValEnv (bagToList new_ids) $
264 zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
265 tcGetEnv `thenNF_Tc` \ env ->
266 returnNF_Tc ((binds', env), new_ids)
267 ) `thenNF_Tc` \ (stuff, _) ->
270 zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
273 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
274 returnNF_Tc (binds', env))
277 -- -> (TypecheckedHsBinds
278 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
280 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
282 go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
284 thing_inside (b1' `ThenBinds` b2')
286 go EmptyBinds thing_inside = thing_inside EmptyBinds
288 go (MonoBind bind sigs is_rec) thing_inside
289 = ASSERT( null sigs )
290 fixNF_Tc (\ ~(_, new_ids) ->
291 tcExtendGlobalValEnv (bagToList new_ids) $
292 zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
293 thing_inside (mkMonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
294 returnNF_Tc (stuff, new_ids)
295 ) `thenNF_Tc` \ (stuff, _) ->
300 -------------------------------------------------------------------------
301 zonkMonoBinds :: TcMonoBinds
302 -> NF_TcM (TypecheckedMonoBinds, Bag Id)
304 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
306 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
307 = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
308 zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
309 returnNF_Tc (b1' `AndMonoBinds` b2',
310 ids1 `unionBags` ids2)
312 zonkMonoBinds (PatMonoBind pat grhss locn)
313 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
314 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
315 returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
317 zonkMonoBinds (VarMonoBind var expr)
318 = zonkIdBndr var `thenNF_Tc` \ new_var ->
319 zonkExpr expr `thenNF_Tc` \ new_expr ->
320 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
322 zonkMonoBinds (CoreMonoBind var core_expr)
323 = zonkIdBndr var `thenNF_Tc` \ new_var ->
324 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
326 zonkMonoBinds (FunMonoBind var inf ms locn)
327 = zonkIdBndr var `thenNF_Tc` \ new_var ->
328 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
329 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
332 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
333 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
334 -- No need to extend tyvar env: the effects are
335 -- propagated through binding the tyvars themselves
337 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
338 tcExtendGlobalValEnv new_dicts $
340 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
341 tcExtendGlobalValEnv (bagToList val_bind_ids) $
342 zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
343 mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports ->
344 returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
345 ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
347 new_globals = listToBag [global | (_, global, local) <- new_exports]
349 returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
352 zonkExport (tyvars, global, local)
353 = zonkTcSigTyVars tyvars `thenNF_Tc` \ new_tyvars ->
354 -- This isn't the binding occurrence of these tyvars
355 -- but they should *be* tyvars. Hence zonkTcSigTyVars.
356 zonkIdBndr global `thenNF_Tc` \ new_global ->
357 zonkIdOcc local `thenNF_Tc` \ new_local ->
358 returnNF_Tc (new_tyvars, new_global, new_local)
361 %************************************************************************
363 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
365 %************************************************************************
368 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
370 zonkMatch (Match pats _ grhss)
371 = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
372 tcExtendGlobalValEnv (bagToList new_ids) $
373 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
374 returnNF_Tc (Match new_pats Nothing new_grhss)
376 -------------------------------------------------------------------------
378 -> NF_TcM TypecheckedGRHSs
380 zonkGRHSs (GRHSs grhss binds ty)
381 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
384 zonk_grhs (GRHS guarded locn)
385 = zonkStmts guarded `thenNF_Tc` \ new_guarded ->
386 returnNF_Tc (GRHS new_guarded locn)
388 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
389 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
390 returnNF_Tc (GRHSs new_grhss new_binds new_ty)
393 %************************************************************************
395 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
397 %************************************************************************
400 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
403 = zonkIdOcc id `thenNF_Tc` \ id' ->
404 returnNF_Tc (HsVar id')
406 zonkExpr (HsIPVar id)
407 = mapIPNameTc zonkIdOcc id `thenNF_Tc` \ id' ->
408 returnNF_Tc (HsIPVar id')
410 zonkExpr (HsLit (HsRat f ty))
411 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
412 returnNF_Tc (HsLit (HsRat f new_ty))
414 zonkExpr (HsLit (HsLitLit lit ty))
415 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
416 returnNF_Tc (HsLit (HsLitLit lit new_ty))
419 = returnNF_Tc (HsLit lit)
421 -- HsOverLit doesn't appear in typechecker output
423 zonkExpr (HsLam match)
424 = zonkMatch match `thenNF_Tc` \ new_match ->
425 returnNF_Tc (HsLam new_match)
427 zonkExpr (HsApp e1 e2)
428 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
429 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
430 returnNF_Tc (HsApp new_e1 new_e2)
432 zonkExpr (OpApp e1 op fixity e2)
433 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
434 zonkExpr op `thenNF_Tc` \ new_op ->
435 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
436 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
438 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
439 zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
441 zonkExpr (SectionL expr op)
442 = zonkExpr expr `thenNF_Tc` \ new_expr ->
443 zonkExpr op `thenNF_Tc` \ new_op ->
444 returnNF_Tc (SectionL new_expr new_op)
446 zonkExpr (SectionR op expr)
447 = zonkExpr op `thenNF_Tc` \ new_op ->
448 zonkExpr expr `thenNF_Tc` \ new_expr ->
449 returnNF_Tc (SectionR new_op new_expr)
451 zonkExpr (HsCase expr ms src_loc)
452 = zonkExpr expr `thenNF_Tc` \ new_expr ->
453 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
454 returnNF_Tc (HsCase new_expr new_ms src_loc)
456 zonkExpr (HsIf e1 e2 e3 src_loc)
457 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
458 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
459 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
460 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
462 zonkExpr (HsLet binds expr)
463 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
465 zonkExpr expr `thenNF_Tc` \ new_expr ->
466 returnNF_Tc (HsLet new_binds new_expr)
468 zonkExpr (HsWith expr binds)
469 = zonkIPBinds binds `thenNF_Tc` \ new_binds ->
470 tcExtendGlobalValEnv (map (ipNameName . fst) new_binds) $
471 zonkExpr expr `thenNF_Tc` \ new_expr ->
472 returnNF_Tc (HsWith new_expr new_binds)
474 zonkIPBinds = mapNF_Tc zonkIPBind
476 = mapIPNameTc zonkIdBndr n `thenNF_Tc` \ n' ->
477 zonkExpr e `thenNF_Tc` \ e' ->
480 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
482 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
483 = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
484 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
485 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
486 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
487 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
488 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
491 zonkExpr (ExplicitList ty exprs)
492 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
493 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
494 returnNF_Tc (ExplicitList new_ty new_exprs)
496 zonkExpr (ExplicitTuple exprs boxed)
497 = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
498 returnNF_Tc (ExplicitTuple new_exprs boxed)
500 zonkExpr (RecordConOut data_con con_expr rbinds)
501 = zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
502 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
503 returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
505 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
507 zonkExpr (RecordUpdOut expr in_ty out_ty dicts rbinds)
508 = zonkExpr expr `thenNF_Tc` \ new_expr ->
509 zonkTcTypeToType in_ty `thenNF_Tc` \ new_in_ty ->
510 zonkTcTypeToType out_ty `thenNF_Tc` \ new_out_ty ->
511 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
512 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
513 returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_dicts new_rbinds)
515 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
516 zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
518 zonkExpr (ArithSeqOut expr info)
519 = zonkExpr expr `thenNF_Tc` \ new_expr ->
520 zonkArithSeq info `thenNF_Tc` \ new_info ->
521 returnNF_Tc (ArithSeqOut new_expr new_info)
523 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
524 = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
525 zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
526 returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
528 zonkExpr (HsSCC lbl expr)
529 = zonkExpr expr `thenNF_Tc` \ new_expr ->
530 returnNF_Tc (HsSCC lbl new_expr)
532 zonkExpr (TyLam tyvars expr)
533 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
534 -- No need to extend tyvar env; see AbsBinds
536 zonkExpr expr `thenNF_Tc` \ new_expr ->
537 returnNF_Tc (TyLam new_tyvars new_expr)
539 zonkExpr (TyApp expr tys)
540 = zonkExpr expr `thenNF_Tc` \ new_expr ->
541 mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
542 returnNF_Tc (TyApp new_expr new_tys)
544 zonkExpr (DictLam dicts expr)
545 = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
546 tcExtendGlobalValEnv new_dicts $
547 zonkExpr expr `thenNF_Tc` \ new_expr ->
548 returnNF_Tc (DictLam new_dicts new_expr)
550 zonkExpr (DictApp expr dicts)
551 = zonkExpr expr `thenNF_Tc` \ new_expr ->
552 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
553 returnNF_Tc (DictApp new_expr new_dicts)
557 -------------------------------------------------------------------------
558 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
560 zonkArithSeq (From e)
561 = zonkExpr e `thenNF_Tc` \ new_e ->
562 returnNF_Tc (From new_e)
564 zonkArithSeq (FromThen e1 e2)
565 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
566 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
567 returnNF_Tc (FromThen new_e1 new_e2)
569 zonkArithSeq (FromTo e1 e2)
570 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
571 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
572 returnNF_Tc (FromTo new_e1 new_e2)
574 zonkArithSeq (FromThenTo e1 e2 e3)
575 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
576 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
577 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
578 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
580 -------------------------------------------------------------------------
581 zonkStmts :: [TcStmt]
582 -> NF_TcM [TypecheckedStmt]
584 zonkStmts [] = returnNF_Tc []
586 zonkStmts (ParStmtOut bndrstmtss : stmts)
587 = mapNF_Tc (mapNF_Tc zonkId) bndrss `thenNF_Tc` \ new_bndrss ->
588 let new_binders = concat new_bndrss in
589 mapNF_Tc zonkStmts stmtss `thenNF_Tc` \ new_stmtss ->
590 tcExtendGlobalValEnv new_binders $
591 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
592 returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
593 where (bndrss, stmtss) = unzip bndrstmtss
595 zonkStmts (ResultStmt expr locn : stmts)
596 = zonkExpr expr `thenNF_Tc` \ new_expr ->
597 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
598 returnNF_Tc (ResultStmt new_expr locn : new_stmts)
600 zonkStmts (ExprStmt expr ty locn : stmts)
601 = zonkExpr expr `thenNF_Tc` \ new_expr ->
602 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
603 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
604 returnNF_Tc (ExprStmt new_expr new_ty locn : new_stmts)
606 zonkStmts (LetStmt binds : stmts)
607 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
609 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
610 returnNF_Tc (LetStmt new_binds : new_stmts)
612 zonkStmts (BindStmt pat expr locn : stmts)
613 = zonkExpr expr `thenNF_Tc` \ new_expr ->
614 zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) ->
615 tcExtendGlobalValEnv (bagToList new_ids) $
616 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
617 returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
621 -------------------------------------------------------------------------
622 zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
625 = mapNF_Tc zonk_rbind rbinds
627 zonk_rbind (field, expr, pun)
628 = zonkExpr expr `thenNF_Tc` \ new_expr ->
629 zonkIdOcc field `thenNF_Tc` \ new_field ->
630 returnNF_Tc (new_field, new_expr, pun)
632 -------------------------------------------------------------------------
633 mapIPNameTc :: (a -> NF_TcM b) -> IPName a -> NF_TcM (IPName b)
634 mapIPNameTc f (Dupable n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Dupable r)
635 mapIPNameTc f (Linear n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Linear r)
639 %************************************************************************
641 \subsection[BackSubst-Pats]{Patterns}
643 %************************************************************************
646 zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
649 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
650 returnNF_Tc (WildPat new_ty, emptyBag)
653 = zonkIdBndr v `thenNF_Tc` \ new_v ->
654 returnNF_Tc (VarPat new_v, unitBag new_v)
656 zonkPat (LazyPat pat)
657 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
658 returnNF_Tc (LazyPat new_pat, ids)
660 zonkPat (AsPat n pat)
661 = zonkIdBndr n `thenNF_Tc` \ new_n ->
662 zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
663 returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
665 zonkPat (ListPat ty pats)
666 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
667 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
668 returnNF_Tc (ListPat new_ty new_pats, ids)
670 zonkPat (TuplePat pats boxed)
671 = zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
672 returnNF_Tc (TuplePat new_pats boxed, ids)
674 zonkPat (ConPat n ty tvs dicts pats)
675 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
676 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
677 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
678 tcExtendGlobalValEnv new_dicts $
679 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
680 returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
681 listToBag new_dicts `unionBags` ids)
683 zonkPat (RecPat n ty tvs dicts rpats)
684 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
685 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
686 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
687 tcExtendGlobalValEnv new_dicts $
688 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
689 returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
690 listToBag new_dicts `unionBags` unionManyBags ids_s)
692 zonk_rpat (f, pat, pun)
693 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
694 returnNF_Tc ((f, new_pat, pun), ids)
696 zonkPat (LitPat lit ty)
697 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
698 returnNF_Tc (LitPat lit new_ty, emptyBag)
700 zonkPat (SigPat pat ty expr)
701 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
702 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
703 zonkExpr expr `thenNF_Tc` \ new_expr ->
704 returnNF_Tc (SigPat new_pat new_ty new_expr, ids)
706 zonkPat (NPat lit ty expr)
707 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
708 zonkExpr expr `thenNF_Tc` \ new_expr ->
709 returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
711 zonkPat (NPlusKPat n k ty e1 e2)
712 = zonkIdBndr n `thenNF_Tc` \ new_n ->
713 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
714 zonkExpr e1 `thenNF_Tc` \ new_e1 ->
715 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
716 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
718 zonkPat (DictPat ds ms)
719 = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
720 mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
721 returnNF_Tc (DictPat new_ds new_ms,
722 listToBag new_ds `unionBags` listToBag new_ms)
726 = returnNF_Tc ([], emptyBag)
729 = zonkPat pat `thenNF_Tc` \ (pat', ids1) ->
730 zonkPats pats `thenNF_Tc` \ (pats', ids2) ->
731 returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
734 %************************************************************************
736 \subsection[BackSubst-Foreign]{Foreign exports}
738 %************************************************************************
742 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
743 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
745 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
746 zonkForeignExport (ForeignExport i hs_ty spec isDeprec src_loc) =
747 zonkIdOcc i `thenNF_Tc` \ i' ->
748 returnNF_Tc (ForeignExport i' undefined spec isDeprec src_loc)
752 zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
753 zonkRules rs = mapNF_Tc zonkRule rs
755 zonkRule (HsRule name act vars lhs rhs loc)
756 = mapNF_Tc zonk_bndr vars `thenNF_Tc` \ new_bndrs ->
757 tcExtendGlobalValEnv (filter isId new_bndrs) $
758 -- Type variables don't need an envt
759 -- They are bound through the mutable mechanism
760 zonkExpr lhs `thenNF_Tc` \ new_lhs ->
761 zonkExpr rhs `thenNF_Tc` \ new_rhs ->
762 returnNF_Tc (HsRule name act (map RuleBndr new_bndrs) new_lhs new_rhs loc)
763 -- I hate this map RuleBndr stuff
765 zonk_bndr (RuleBndr v)
766 | isId v = zonkIdBndr v
767 | otherwise = zonkTcTyVarToTyVar v
769 zonkRule (IfaceRuleOut fun rule)
770 = zonkIdOcc fun `thenNF_Tc` \ fun' ->
771 returnNF_Tc (IfaceRuleOut fun' rule)