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 )
50 import TypeRep ( IPName(..) ) -- For zonking
51 import Type ( Type, ipNameName )
52 import TcType ( TcType )
53 import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars )
54 import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
55 doublePrimTy, addrPrimTy
57 import TysWiredIn ( charTy, stringTy, intTy, integerTy,
58 mkListTy, mkTupleTy, unitTy )
59 import CoreSyn ( Expr )
61 import BasicTypes ( RecFlag(..), Boxity(..) )
64 import HscTypes ( TyThing(..) )
71 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
72 All the types in @Tc...@ things have mutable type-variables in them for
75 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
76 which have immutable type variables in them.
79 type TcHsBinds = HsBinds TcId TcPat
80 type TcMonoBinds = MonoBinds TcId TcPat
81 type TcDictBinds = TcMonoBinds
82 type TcPat = OutPat TcId
83 type TcExpr = HsExpr TcId TcPat
84 type TcGRHSs = GRHSs TcId TcPat
85 type TcGRHS = GRHS TcId TcPat
86 type TcMatch = Match TcId TcPat
87 type TcStmt = Stmt TcId TcPat
88 type TcArithSeqInfo = ArithSeqInfo TcId TcPat
89 type TcRecordBinds = HsRecordBinds TcId TcPat
90 type TcHsModule = HsModule TcId TcPat
92 type TcCoreExpr = Expr TcId
93 type TcForeignExportDecl = ForeignDecl TcId
94 type TcRuleDecl = RuleDecl TcId TcPat
96 type TypecheckedPat = OutPat Id
97 type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
98 type TypecheckedDictBinds = TypecheckedMonoBinds
99 type TypecheckedHsBinds = HsBinds Id TypecheckedPat
100 type TypecheckedHsExpr = HsExpr Id TypecheckedPat
101 type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat
102 type TypecheckedStmt = Stmt Id TypecheckedPat
103 type TypecheckedMatch = Match Id TypecheckedPat
104 type TypecheckedMatchContext = HsMatchContext Id
105 type TypecheckedGRHSs = GRHSs Id TypecheckedPat
106 type TypecheckedGRHS = GRHS Id TypecheckedPat
107 type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
108 type TypecheckedHsModule = HsModule Id TypecheckedPat
109 type TypecheckedForeignDecl = ForeignDecl Id
110 type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
114 mkHsTyApp expr [] = expr
115 mkHsTyApp expr tys = TyApp expr tys
117 mkHsDictApp expr [] = expr
118 mkHsDictApp expr dict_vars = DictApp expr dict_vars
120 mkHsTyLam [] expr = expr
121 mkHsTyLam tyvars expr = TyLam tyvars expr
123 mkHsDictLam [] expr = expr
124 mkHsDictLam dicts expr = DictLam dicts expr
126 mkHsLet EmptyMonoBinds expr = expr
127 mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
129 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
133 ------------------------------------------------------
135 simpleHsLitTy :: HsLit -> TcType
136 simpleHsLitTy (HsCharPrim c) = charPrimTy
137 simpleHsLitTy (HsStringPrim s) = addrPrimTy
138 simpleHsLitTy (HsInt i) = intTy
139 simpleHsLitTy (HsInteger i) = integerTy
140 simpleHsLitTy (HsIntPrim i) = intPrimTy
141 simpleHsLitTy (HsFloatPrim f) = floatPrimTy
142 simpleHsLitTy (HsDoublePrim d) = doublePrimTy
143 simpleHsLitTy (HsChar c) = charTy
144 simpleHsLitTy (HsString str) = stringTy
148 %************************************************************************
150 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
152 %************************************************************************
154 Note: If @outPatType@ doesn't bear a strong resemblance to @exprType@,
155 then something is wrong.
157 outPatType :: TypecheckedPat -> Type
159 outPatType (WildPat ty) = ty
160 outPatType (VarPat var) = idType var
161 outPatType (LazyPat pat) = outPatType pat
162 outPatType (AsPat var pat) = idType var
163 outPatType (ConPat _ ty _ _ _) = ty
164 outPatType (ListPat ty _) = mkListTy ty
165 outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats)
166 outPatType (RecPat _ ty _ _ _) = ty
167 outPatType (SigPat _ ty _) = ty
168 outPatType (LitPat lit ty) = ty
169 outPatType (NPat lit ty _) = ty
170 outPatType (NPlusKPat _ _ ty _ _) = ty
171 outPatType (DictPat ds ms) = case (length ds_ms) of
173 1 -> idType (head ds_ms)
174 n -> mkTupleTy Boxed n (map idType ds_ms)
180 Nota bene: @DsBinds@ relies on the fact that at least for simple
181 tuple patterns @collectTypedPatBinders@ returns the binders in
182 the same order as they appear in the tuple.
184 @collectTypedBinders@ and @collectedTypedPatBinders@ are the exportees.
187 collectTypedPatBinders :: TypecheckedPat -> [Id]
188 collectTypedPatBinders (VarPat var) = [var]
189 collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat
190 collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat
191 collectTypedPatBinders (SigPat pat _ _) = collectTypedPatBinders pat
192 collectTypedPatBinders (ConPat _ _ _ _ pats) = concat (map collectTypedPatBinders pats)
193 collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats)
194 collectTypedPatBinders (TuplePat pats _) = concat (map collectTypedPatBinders pats)
195 collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat)
197 collectTypedPatBinders (DictPat ds ms) = ds ++ ms
198 collectTypedPatBinders (NPlusKPat var _ _ _ _) = [var]
199 collectTypedPatBinders any_other_pat = [ {-no binders-} ]
203 %************************************************************************
205 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
207 %************************************************************************
209 This zonking pass runs over the bindings
211 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
212 b) convert unbound TcTyVar to Void
213 c) convert each TcId to an Id by zonking its type
215 The type variables are converted by binding mutable tyvars to immutable ones
216 and then zonking as normal.
218 The Ids are converted by binding them in the normal Tc envt; that
219 way we maintain sharing; eg an Id is zonked at its binding site and they
220 all occurrences of that Id point to the common zonked copy
222 It's all pretty boring stuff, because HsSyn is such a large type, and
223 the environment manipulation is tiresome.
226 -- zonkId is used *during* typechecking just to zonk the Id's type
227 zonkId :: TcId -> NF_TcM TcId
229 = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
230 returnNF_Tc (setIdType id ty')
232 -- zonkIdBndr is used *after* typechecking to get the Id's type
233 -- to its final form. The TyVarEnv give
234 zonkIdBndr :: TcId -> NF_TcM Id
236 = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' ->
237 returnNF_Tc (setIdType id ty')
239 zonkIdOcc :: TcId -> NF_TcM Id
241 = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' ->
242 -- We're even look up up superclass selectors and constructors;
243 -- even though zonking them is a no-op anyway, and the
244 -- superclass selectors aren't in the environment anyway.
245 -- But we don't want to call isLocalId to find out whether
246 -- it's a superclass selector (for example) because that looks
247 -- at the IdInfo field, which in turn be in a knot because of
248 -- the big knot in typecheckModule
250 new_id = case maybe_id' of
251 Just (AnId id') -> id'
252 other -> id -- WARN( isLocalId id, ppr id ) id
253 -- Oops: the warning can give a black hole
254 -- because it looks at the idinfo
261 zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
262 zonkTopBinds binds -- Top level is implicitly recursive
263 = fixNF_Tc (\ ~(_, new_ids) ->
264 tcExtendGlobalValEnv (bagToList new_ids) $
265 zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
266 tcGetEnv `thenNF_Tc` \ env ->
267 returnNF_Tc ((binds', env), new_ids)
268 ) `thenNF_Tc` \ (stuff, _) ->
271 zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
274 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
275 returnNF_Tc (binds', env))
278 -- -> (TypecheckedHsBinds
279 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
281 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
283 go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
285 thing_inside (b1' `ThenBinds` b2')
287 go EmptyBinds thing_inside = thing_inside EmptyBinds
289 go (MonoBind bind sigs is_rec) thing_inside
290 = ASSERT( null sigs )
291 fixNF_Tc (\ ~(_, new_ids) ->
292 tcExtendGlobalValEnv (bagToList new_ids) $
293 zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
294 thing_inside (mkMonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
295 returnNF_Tc (stuff, new_ids)
296 ) `thenNF_Tc` \ (stuff, _) ->
301 -------------------------------------------------------------------------
302 zonkMonoBinds :: TcMonoBinds
303 -> NF_TcM (TypecheckedMonoBinds, Bag Id)
305 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
307 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
308 = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
309 zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
310 returnNF_Tc (b1' `AndMonoBinds` b2',
311 ids1 `unionBags` ids2)
313 zonkMonoBinds (PatMonoBind pat grhss locn)
314 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
315 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
316 returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
318 zonkMonoBinds (VarMonoBind var expr)
319 = zonkIdBndr var `thenNF_Tc` \ new_var ->
320 zonkExpr expr `thenNF_Tc` \ new_expr ->
321 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
323 zonkMonoBinds (CoreMonoBind var core_expr)
324 = zonkIdBndr var `thenNF_Tc` \ new_var ->
325 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
327 zonkMonoBinds (FunMonoBind var inf ms locn)
328 = zonkIdBndr var `thenNF_Tc` \ new_var ->
329 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
330 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
333 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
334 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
335 -- No need to extend tyvar env: the effects are
336 -- propagated through binding the tyvars themselves
338 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
339 tcExtendGlobalValEnv new_dicts $
341 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
342 tcExtendGlobalValEnv (bagToList val_bind_ids) $
343 zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
344 mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports ->
345 returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
346 ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
348 new_globals = listToBag [global | (_, global, local) <- new_exports]
350 returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
353 zonkExport (tyvars, global, local)
354 = zonkTcSigTyVars tyvars `thenNF_Tc` \ new_tyvars ->
355 -- This isn't the binding occurrence of these tyvars
356 -- but they should *be* tyvars. Hence zonkTcSigTyVars.
357 zonkIdBndr global `thenNF_Tc` \ new_global ->
358 zonkIdOcc local `thenNF_Tc` \ new_local ->
359 returnNF_Tc (new_tyvars, new_global, new_local)
362 %************************************************************************
364 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
366 %************************************************************************
369 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
371 zonkMatch (Match pats _ grhss)
372 = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
373 tcExtendGlobalValEnv (bagToList new_ids) $
374 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
375 returnNF_Tc (Match new_pats Nothing new_grhss)
377 -------------------------------------------------------------------------
379 -> NF_TcM TypecheckedGRHSs
381 zonkGRHSs (GRHSs grhss binds ty)
382 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
385 zonk_grhs (GRHS guarded locn)
386 = zonkStmts guarded `thenNF_Tc` \ new_guarded ->
387 returnNF_Tc (GRHS new_guarded locn)
389 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
390 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
391 returnNF_Tc (GRHSs new_grhss new_binds new_ty)
394 %************************************************************************
396 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
398 %************************************************************************
401 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
404 = zonkIdOcc id `thenNF_Tc` \ id' ->
405 returnNF_Tc (HsVar id')
407 zonkExpr (HsIPVar id)
408 = mapIPNameTc zonkIdOcc id `thenNF_Tc` \ id' ->
409 returnNF_Tc (HsIPVar id')
411 zonkExpr (HsLit (HsRat f ty))
412 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
413 returnNF_Tc (HsLit (HsRat f new_ty))
415 zonkExpr (HsLit (HsLitLit lit ty))
416 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
417 returnNF_Tc (HsLit (HsLitLit lit new_ty))
420 = returnNF_Tc (HsLit lit)
422 -- HsOverLit doesn't appear in typechecker output
424 zonkExpr (HsLam match)
425 = zonkMatch match `thenNF_Tc` \ new_match ->
426 returnNF_Tc (HsLam new_match)
428 zonkExpr (HsApp e1 e2)
429 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
430 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
431 returnNF_Tc (HsApp new_e1 new_e2)
433 zonkExpr (OpApp e1 op fixity e2)
434 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
435 zonkExpr op `thenNF_Tc` \ new_op ->
436 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
437 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
439 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
440 zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
442 zonkExpr (SectionL expr op)
443 = zonkExpr expr `thenNF_Tc` \ new_expr ->
444 zonkExpr op `thenNF_Tc` \ new_op ->
445 returnNF_Tc (SectionL new_expr new_op)
447 zonkExpr (SectionR op expr)
448 = zonkExpr op `thenNF_Tc` \ new_op ->
449 zonkExpr expr `thenNF_Tc` \ new_expr ->
450 returnNF_Tc (SectionR new_op new_expr)
452 zonkExpr (HsCase expr ms src_loc)
453 = zonkExpr expr `thenNF_Tc` \ new_expr ->
454 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
455 returnNF_Tc (HsCase new_expr new_ms src_loc)
457 zonkExpr (HsIf e1 e2 e3 src_loc)
458 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
459 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
460 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
461 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
463 zonkExpr (HsLet binds expr)
464 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
466 zonkExpr expr `thenNF_Tc` \ new_expr ->
467 returnNF_Tc (HsLet new_binds new_expr)
469 zonkExpr (HsWith expr binds)
470 = zonkIPBinds binds `thenNF_Tc` \ new_binds ->
471 tcExtendGlobalValEnv (map (ipNameName . fst) new_binds) $
472 zonkExpr expr `thenNF_Tc` \ new_expr ->
473 returnNF_Tc (HsWith new_expr new_binds)
475 zonkIPBinds = mapNF_Tc zonkIPBind
477 = mapIPNameTc zonkIdBndr n `thenNF_Tc` \ n' ->
478 zonkExpr e `thenNF_Tc` \ e' ->
481 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
483 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
484 = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
485 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
486 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
487 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
488 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
489 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
492 zonkExpr (ExplicitList ty exprs)
493 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
494 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
495 returnNF_Tc (ExplicitList new_ty new_exprs)
497 zonkExpr (ExplicitTuple exprs boxed)
498 = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
499 returnNF_Tc (ExplicitTuple new_exprs boxed)
501 zonkExpr (RecordConOut data_con con_expr rbinds)
502 = zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
503 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
504 returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
506 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
508 zonkExpr (RecordUpdOut expr in_ty out_ty dicts rbinds)
509 = zonkExpr expr `thenNF_Tc` \ new_expr ->
510 zonkTcTypeToType in_ty `thenNF_Tc` \ new_in_ty ->
511 zonkTcTypeToType out_ty `thenNF_Tc` \ new_out_ty ->
512 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
513 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
514 returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_dicts new_rbinds)
516 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
517 zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
519 zonkExpr (ArithSeqOut expr info)
520 = zonkExpr expr `thenNF_Tc` \ new_expr ->
521 zonkArithSeq info `thenNF_Tc` \ new_info ->
522 returnNF_Tc (ArithSeqOut new_expr new_info)
524 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
525 = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
526 zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
527 returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
529 zonkExpr (HsSCC lbl expr)
530 = zonkExpr expr `thenNF_Tc` \ new_expr ->
531 returnNF_Tc (HsSCC lbl new_expr)
533 zonkExpr (TyLam tyvars expr)
534 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
535 -- No need to extend tyvar env; see AbsBinds
537 zonkExpr expr `thenNF_Tc` \ new_expr ->
538 returnNF_Tc (TyLam new_tyvars new_expr)
540 zonkExpr (TyApp expr tys)
541 = zonkExpr expr `thenNF_Tc` \ new_expr ->
542 mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
543 returnNF_Tc (TyApp new_expr new_tys)
545 zonkExpr (DictLam dicts expr)
546 = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
547 tcExtendGlobalValEnv new_dicts $
548 zonkExpr expr `thenNF_Tc` \ new_expr ->
549 returnNF_Tc (DictLam new_dicts new_expr)
551 zonkExpr (DictApp expr dicts)
552 = zonkExpr expr `thenNF_Tc` \ new_expr ->
553 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
554 returnNF_Tc (DictApp new_expr new_dicts)
558 -------------------------------------------------------------------------
559 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
561 zonkArithSeq (From e)
562 = zonkExpr e `thenNF_Tc` \ new_e ->
563 returnNF_Tc (From new_e)
565 zonkArithSeq (FromThen e1 e2)
566 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
567 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
568 returnNF_Tc (FromThen new_e1 new_e2)
570 zonkArithSeq (FromTo e1 e2)
571 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
572 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
573 returnNF_Tc (FromTo new_e1 new_e2)
575 zonkArithSeq (FromThenTo e1 e2 e3)
576 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
577 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
578 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
579 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
581 -------------------------------------------------------------------------
582 zonkStmts :: [TcStmt]
583 -> NF_TcM [TypecheckedStmt]
585 zonkStmts [] = returnNF_Tc []
587 zonkStmts (ParStmtOut bndrstmtss : stmts)
588 = mapNF_Tc (mapNF_Tc zonkId) bndrss `thenNF_Tc` \ new_bndrss ->
589 let new_binders = concat new_bndrss in
590 mapNF_Tc zonkStmts stmtss `thenNF_Tc` \ new_stmtss ->
591 tcExtendGlobalValEnv new_binders $
592 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
593 returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
594 where (bndrss, stmtss) = unzip bndrstmtss
596 zonkStmts (ResultStmt expr locn : stmts)
597 = zonkExpr expr `thenNF_Tc` \ new_expr ->
598 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
599 returnNF_Tc (ResultStmt new_expr locn : new_stmts)
601 zonkStmts (ExprStmt expr ty locn : stmts)
602 = zonkExpr expr `thenNF_Tc` \ new_expr ->
603 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
604 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
605 returnNF_Tc (ExprStmt new_expr new_ty locn : new_stmts)
607 zonkStmts (LetStmt binds : stmts)
608 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
610 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
611 returnNF_Tc (LetStmt new_binds : new_stmts)
613 zonkStmts (BindStmt pat expr locn : stmts)
614 = zonkExpr expr `thenNF_Tc` \ new_expr ->
615 zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) ->
616 tcExtendGlobalValEnv (bagToList new_ids) $
617 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
618 returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
622 -------------------------------------------------------------------------
623 zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
626 = mapNF_Tc zonk_rbind rbinds
628 zonk_rbind (field, expr, pun)
629 = zonkExpr expr `thenNF_Tc` \ new_expr ->
630 zonkIdOcc field `thenNF_Tc` \ new_field ->
631 returnNF_Tc (new_field, new_expr, pun)
633 -------------------------------------------------------------------------
634 mapIPNameTc :: (a -> NF_TcM b) -> IPName a -> NF_TcM (IPName b)
635 mapIPNameTc f (Dupable n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Dupable r)
636 mapIPNameTc f (MustSplit n) = f n `thenNF_Tc` \ r -> returnNF_Tc (MustSplit r)
640 %************************************************************************
642 \subsection[BackSubst-Pats]{Patterns}
644 %************************************************************************
647 zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
650 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
651 returnNF_Tc (WildPat new_ty, emptyBag)
654 = zonkIdBndr v `thenNF_Tc` \ new_v ->
655 returnNF_Tc (VarPat new_v, unitBag new_v)
657 zonkPat (LazyPat pat)
658 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
659 returnNF_Tc (LazyPat new_pat, ids)
661 zonkPat (AsPat n pat)
662 = zonkIdBndr n `thenNF_Tc` \ new_n ->
663 zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
664 returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
666 zonkPat (ListPat ty pats)
667 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
668 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
669 returnNF_Tc (ListPat new_ty new_pats, ids)
671 zonkPat (TuplePat pats boxed)
672 = zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
673 returnNF_Tc (TuplePat new_pats boxed, ids)
675 zonkPat (ConPat n ty tvs dicts pats)
676 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
677 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
678 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
679 tcExtendGlobalValEnv new_dicts $
680 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
681 returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
682 listToBag new_dicts `unionBags` ids)
684 zonkPat (RecPat n ty tvs dicts rpats)
685 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
686 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
687 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
688 tcExtendGlobalValEnv new_dicts $
689 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
690 returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
691 listToBag new_dicts `unionBags` unionManyBags ids_s)
693 zonk_rpat (f, pat, pun)
694 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
695 returnNF_Tc ((f, new_pat, pun), ids)
697 zonkPat (LitPat lit ty)
698 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
699 returnNF_Tc (LitPat lit new_ty, emptyBag)
701 zonkPat (SigPat pat ty expr)
702 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
703 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
704 zonkExpr expr `thenNF_Tc` \ new_expr ->
705 returnNF_Tc (SigPat new_pat new_ty new_expr, ids)
707 zonkPat (NPat lit ty expr)
708 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
709 zonkExpr expr `thenNF_Tc` \ new_expr ->
710 returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
712 zonkPat (NPlusKPat n k ty e1 e2)
713 = zonkIdBndr n `thenNF_Tc` \ new_n ->
714 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
715 zonkExpr e1 `thenNF_Tc` \ new_e1 ->
716 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
717 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
719 zonkPat (DictPat ds ms)
720 = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
721 mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
722 returnNF_Tc (DictPat new_ds new_ms,
723 listToBag new_ds `unionBags` listToBag new_ms)
727 = returnNF_Tc ([], emptyBag)
730 = zonkPat pat `thenNF_Tc` \ (pat', ids1) ->
731 zonkPats pats `thenNF_Tc` \ (pats', ids2) ->
732 returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
735 %************************************************************************
737 \subsection[BackSubst-Foreign]{Foreign exports}
739 %************************************************************************
743 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
744 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
746 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
747 zonkForeignExport (ForeignExport i hs_ty spec src_loc) =
748 zonkIdOcc i `thenNF_Tc` \ i' ->
749 returnNF_Tc (ForeignExport i' undefined spec src_loc)
753 zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
754 zonkRules rs = mapNF_Tc zonkRule rs
756 zonkRule (HsRule name act vars lhs rhs loc)
757 = mapNF_Tc zonk_bndr vars `thenNF_Tc` \ new_bndrs ->
758 tcExtendGlobalValEnv (filter isId new_bndrs) $
759 -- Type variables don't need an envt
760 -- They are bound through the mutable mechanism
761 zonkExpr lhs `thenNF_Tc` \ new_lhs ->
762 zonkExpr rhs `thenNF_Tc` \ new_rhs ->
763 returnNF_Tc (HsRule name act (map RuleBndr new_bndrs) new_lhs new_rhs loc)
764 -- I hate this map RuleBndr stuff
766 zonk_bndr (RuleBndr v)
767 | isId v = zonkIdBndr v
768 | otherwise = zonkTcTyVarToTyVar v
770 zonkRule (IfaceRuleOut fun rule)
771 = zonkIdOcc fun `thenNF_Tc` \ fun' ->
772 returnNF_Tc (IfaceRuleOut fun' rule)