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, TcDictBinds,
17 TypecheckedHsBinds, TypecheckedRuleDecl,
18 TypecheckedMonoBinds, TypecheckedPat,
19 TypecheckedHsExpr, TypecheckedArithSeqInfo,
20 TypecheckedStmt, TypecheckedForeignDecl,
21 TypecheckedMatch, TypecheckedHsModule,
22 TypecheckedGRHSs, TypecheckedGRHS,
23 TypecheckedRecordBinds, TypecheckedDictBinds,
24 TypecheckedMatchContext, TypecheckedCoreBind,
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, zonkCoreExpr, zonkCoreBinds
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, tcGetTyVar )
52 import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcTyVars )
53 import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
54 doublePrimTy, addrPrimTy
56 import TysWiredIn ( charTy, stringTy, intTy, integerTy,
57 mkListTy, mkPArrTy, mkTupleTy, unitTy )
58 import CoreSyn ( Expr(..), CoreExpr, CoreBind, Bind(..), CoreAlt, Note(..) )
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 TcForeignExportDecl = ForeignDecl TcId
92 type TcRuleDecl = RuleDecl TcId TcPat
94 type TypecheckedPat = OutPat Id
95 type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
96 type TypecheckedDictBinds = TypecheckedMonoBinds
97 type TypecheckedHsBinds = HsBinds Id TypecheckedPat
98 type TypecheckedHsExpr = HsExpr Id TypecheckedPat
99 type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat
100 type TypecheckedStmt = Stmt Id TypecheckedPat
101 type TypecheckedMatch = Match Id TypecheckedPat
102 type TypecheckedMatchContext = HsMatchContext Id
103 type TypecheckedGRHSs = GRHSs Id TypecheckedPat
104 type TypecheckedGRHS = GRHS Id TypecheckedPat
105 type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
106 type TypecheckedHsModule = HsModule Id TypecheckedPat
107 type TypecheckedForeignDecl = ForeignDecl Id
108 type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
109 type TypecheckedCoreBind = (Id, Type, CoreExpr)
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 (PArrPat ty _) = mkPArrTy 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 (PArrPat t pats) = concat (map collectTypedPatBinders pats)
195 collectTypedPatBinders (TuplePat pats _) = concat (map collectTypedPatBinders pats)
196 collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat)
198 collectTypedPatBinders (DictPat ds ms) = ds ++ ms
199 collectTypedPatBinders (NPlusKPat var _ _ _ _) = [var]
200 collectTypedPatBinders any_other_pat = [ {-no binders-} ]
204 %************************************************************************
206 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
208 %************************************************************************
210 This zonking pass runs over the bindings
212 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
213 b) convert unbound TcTyVar to Void
214 c) convert each TcId to an Id by zonking its type
216 The type variables are converted by binding mutable tyvars to immutable ones
217 and then zonking as normal.
219 The Ids are converted by binding them in the normal Tc envt; that
220 way we maintain sharing; eg an Id is zonked at its binding site and they
221 all occurrences of that Id point to the common zonked copy
223 It's all pretty boring stuff, because HsSyn is such a large type, and
224 the environment manipulation is tiresome.
227 -- zonkId is used *during* typechecking just to zonk the Id's type
228 zonkId :: TcId -> NF_TcM TcId
230 = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
231 returnNF_Tc (setIdType id ty')
233 -- zonkIdBndr is used *after* typechecking to get the Id's type
234 -- to its final form. The TyVarEnv give
235 zonkIdBndr :: TcId -> NF_TcM Id
237 = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' ->
238 returnNF_Tc (setIdType id ty')
240 zonkIdOcc :: TcId -> NF_TcM Id
242 = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' ->
243 -- We're even look up up superclass selectors and constructors;
244 -- even though zonking them is a no-op anyway, and the
245 -- superclass selectors aren't in the environment anyway.
246 -- But we don't want to call isLocalId to find out whether
247 -- it's a superclass selector (for example) because that looks
248 -- at the IdInfo field, which in turn be in a knot because of
249 -- the big knot in typecheckModule
251 new_id = case maybe_id' of
252 Just (AnId id') -> id'
253 other -> id -- WARN( isLocalId id, ppr id ) id
254 -- Oops: the warning can give a black hole
255 -- because it looks at the idinfo
262 zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
263 zonkTopBinds binds -- Top level is implicitly recursive
264 = fixNF_Tc (\ ~(_, new_ids) ->
265 tcExtendGlobalValEnv (bagToList new_ids) $
266 zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
267 tcGetEnv `thenNF_Tc` \ env ->
268 returnNF_Tc ((binds', env), new_ids)
269 ) `thenNF_Tc` \ (stuff, _) ->
272 zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
275 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
276 returnNF_Tc (binds', env))
279 -- -> (TypecheckedHsBinds
280 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
282 -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
284 go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
286 thing_inside (b1' `ThenBinds` b2')
288 go EmptyBinds thing_inside = thing_inside EmptyBinds
290 go (MonoBind bind sigs is_rec) thing_inside
291 = ASSERT( null sigs )
292 fixNF_Tc (\ ~(_, new_ids) ->
293 tcExtendGlobalValEnv (bagToList new_ids) $
294 zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
295 thing_inside (mkMonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
296 returnNF_Tc (stuff, new_ids)
297 ) `thenNF_Tc` \ (stuff, _) ->
302 -------------------------------------------------------------------------
303 zonkMonoBinds :: TcMonoBinds
304 -> NF_TcM (TypecheckedMonoBinds, Bag Id)
306 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
308 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
309 = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
310 zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
311 returnNF_Tc (b1' `AndMonoBinds` b2',
312 ids1 `unionBags` ids2)
314 zonkMonoBinds (PatMonoBind pat grhss locn)
315 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
316 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
317 returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
319 zonkMonoBinds (VarMonoBind var expr)
320 = zonkIdBndr var `thenNF_Tc` \ new_var ->
321 zonkExpr expr `thenNF_Tc` \ new_expr ->
322 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
324 zonkMonoBinds (CoreMonoBind var core_expr)
325 = zonkIdBndr var `thenNF_Tc` \ new_var ->
326 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
328 zonkMonoBinds (FunMonoBind var inf ms locn)
329 = zonkIdBndr var `thenNF_Tc` \ new_var ->
330 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
331 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
334 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
335 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
336 -- No need to extend tyvar env: the effects are
337 -- propagated through binding the tyvars themselves
339 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
340 tcExtendGlobalValEnv new_dicts $
342 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
343 tcExtendGlobalValEnv (bagToList val_bind_ids) $
344 zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
345 mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports ->
346 returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
347 ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
349 new_globals = listToBag [global | (_, global, local) <- new_exports]
351 returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
354 zonkExport (tyvars, global, local)
355 = zonkTcTyVars tyvars `thenNF_Tc` \ tys ->
357 new_tyvars = map (tcGetTyVar "zonkExport") tys
358 -- This isn't the binding occurrence of these tyvars
359 -- but they should *be* tyvars. Hence tcGetTyVar.
361 zonkIdBndr global `thenNF_Tc` \ new_global ->
362 zonkIdOcc local `thenNF_Tc` \ new_local ->
363 returnNF_Tc (new_tyvars, new_global, new_local)
366 %************************************************************************
368 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
370 %************************************************************************
373 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
375 zonkMatch (Match pats _ grhss)
376 = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
377 tcExtendGlobalValEnv (bagToList new_ids) $
378 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
379 returnNF_Tc (Match new_pats Nothing new_grhss)
381 -------------------------------------------------------------------------
383 -> NF_TcM TypecheckedGRHSs
385 zonkGRHSs (GRHSs grhss binds ty)
386 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
389 zonk_grhs (GRHS guarded locn)
390 = zonkStmts guarded `thenNF_Tc` \ new_guarded ->
391 returnNF_Tc (GRHS new_guarded locn)
393 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
394 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
395 returnNF_Tc (GRHSs new_grhss new_binds new_ty)
398 %************************************************************************
400 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
402 %************************************************************************
405 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
408 = zonkIdOcc id `thenNF_Tc` \ id' ->
409 returnNF_Tc (HsVar id')
411 zonkExpr (HsIPVar id)
412 = mapIPNameTc zonkIdOcc id `thenNF_Tc` \ id' ->
413 returnNF_Tc (HsIPVar id')
415 zonkExpr (HsLit (HsRat f ty))
416 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
417 returnNF_Tc (HsLit (HsRat f new_ty))
419 zonkExpr (HsLit (HsLitLit lit ty))
420 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
421 returnNF_Tc (HsLit (HsLitLit lit new_ty))
424 = returnNF_Tc (HsLit lit)
426 -- HsOverLit doesn't appear in typechecker output
428 zonkExpr (HsLam match)
429 = zonkMatch match `thenNF_Tc` \ new_match ->
430 returnNF_Tc (HsLam new_match)
432 zonkExpr (HsApp e1 e2)
433 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
434 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
435 returnNF_Tc (HsApp new_e1 new_e2)
437 zonkExpr (OpApp e1 op fixity e2)
438 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
439 zonkExpr op `thenNF_Tc` \ new_op ->
440 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
441 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
443 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
444 zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
446 zonkExpr (SectionL expr op)
447 = zonkExpr expr `thenNF_Tc` \ new_expr ->
448 zonkExpr op `thenNF_Tc` \ new_op ->
449 returnNF_Tc (SectionL new_expr new_op)
451 zonkExpr (SectionR op expr)
452 = zonkExpr op `thenNF_Tc` \ new_op ->
453 zonkExpr expr `thenNF_Tc` \ new_expr ->
454 returnNF_Tc (SectionR new_op new_expr)
456 zonkExpr (HsCase expr ms src_loc)
457 = zonkExpr expr `thenNF_Tc` \ new_expr ->
458 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
459 returnNF_Tc (HsCase new_expr new_ms src_loc)
461 zonkExpr (HsIf e1 e2 e3 src_loc)
462 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
463 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
464 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
465 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
467 zonkExpr (HsLet binds expr)
468 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
470 zonkExpr expr `thenNF_Tc` \ new_expr ->
471 returnNF_Tc (HsLet new_binds new_expr)
473 zonkExpr (HsWith expr binds is_with)
474 = zonkIPBinds binds `thenNF_Tc` \ new_binds ->
475 tcExtendGlobalValEnv (map (ipNameName . fst) new_binds) $
476 zonkExpr expr `thenNF_Tc` \ new_expr ->
477 returnNF_Tc (HsWith new_expr new_binds is_with)
479 zonkIPBinds = mapNF_Tc zonkIPBind
481 = mapIPNameTc zonkIdBndr n `thenNF_Tc` \ n' ->
482 zonkExpr e `thenNF_Tc` \ e' ->
485 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
487 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
488 = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
489 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
490 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
491 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
492 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
493 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
496 zonkExpr (ExplicitList ty exprs)
497 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
498 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
499 returnNF_Tc (ExplicitList new_ty new_exprs)
501 zonkExpr (ExplicitPArr ty exprs)
502 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
503 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
504 returnNF_Tc (ExplicitPArr new_ty new_exprs)
506 zonkExpr (ExplicitTuple exprs boxed)
507 = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
508 returnNF_Tc (ExplicitTuple new_exprs boxed)
510 zonkExpr (RecordConOut data_con con_expr rbinds)
511 = zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
512 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
513 returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
515 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
517 zonkExpr (RecordUpdOut expr in_ty out_ty rbinds)
518 = zonkExpr expr `thenNF_Tc` \ new_expr ->
519 zonkTcTypeToType in_ty `thenNF_Tc` \ new_in_ty ->
520 zonkTcTypeToType out_ty `thenNF_Tc` \ new_out_ty ->
521 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
522 returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
524 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
525 zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
526 zonkExpr (PArrSeqIn _) = panic "zonkExpr:PArrSeqIn"
528 zonkExpr (ArithSeqOut expr info)
529 = zonkExpr expr `thenNF_Tc` \ new_expr ->
530 zonkArithSeq info `thenNF_Tc` \ new_info ->
531 returnNF_Tc (ArithSeqOut new_expr new_info)
533 zonkExpr (PArrSeqOut expr info)
534 = zonkExpr expr `thenNF_Tc` \ new_expr ->
535 zonkArithSeq info `thenNF_Tc` \ new_info ->
536 returnNF_Tc (PArrSeqOut new_expr new_info)
538 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
539 = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
540 zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
541 returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
543 zonkExpr (HsSCC lbl expr)
544 = zonkExpr expr `thenNF_Tc` \ new_expr ->
545 returnNF_Tc (HsSCC lbl new_expr)
547 zonkExpr (TyLam tyvars expr)
548 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
549 -- No need to extend tyvar env; see AbsBinds
551 zonkExpr expr `thenNF_Tc` \ new_expr ->
552 returnNF_Tc (TyLam new_tyvars new_expr)
554 zonkExpr (TyApp expr tys)
555 = zonkExpr expr `thenNF_Tc` \ new_expr ->
556 mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
557 returnNF_Tc (TyApp new_expr new_tys)
559 zonkExpr (DictLam dicts expr)
560 = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
561 tcExtendGlobalValEnv new_dicts $
562 zonkExpr expr `thenNF_Tc` \ new_expr ->
563 returnNF_Tc (DictLam new_dicts new_expr)
565 zonkExpr (DictApp expr dicts)
566 = zonkExpr expr `thenNF_Tc` \ new_expr ->
567 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
568 returnNF_Tc (DictApp new_expr new_dicts)
572 -------------------------------------------------------------------------
573 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
575 zonkArithSeq (From e)
576 = zonkExpr e `thenNF_Tc` \ new_e ->
577 returnNF_Tc (From new_e)
579 zonkArithSeq (FromThen e1 e2)
580 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
581 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
582 returnNF_Tc (FromThen new_e1 new_e2)
584 zonkArithSeq (FromTo e1 e2)
585 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
586 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
587 returnNF_Tc (FromTo new_e1 new_e2)
589 zonkArithSeq (FromThenTo e1 e2 e3)
590 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
591 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
592 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
593 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
595 -------------------------------------------------------------------------
596 zonkStmts :: [TcStmt]
597 -> NF_TcM [TypecheckedStmt]
599 zonkStmts [] = returnNF_Tc []
601 zonkStmts (ParStmtOut bndrstmtss : stmts)
602 = mapNF_Tc (mapNF_Tc zonkId) bndrss `thenNF_Tc` \ new_bndrss ->
603 let new_binders = concat new_bndrss in
604 mapNF_Tc zonkStmts stmtss `thenNF_Tc` \ new_stmtss ->
605 tcExtendGlobalValEnv new_binders $
606 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
607 returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
608 where (bndrss, stmtss) = unzip bndrstmtss
610 zonkStmts (ResultStmt expr locn : stmts)
611 = zonkExpr expr `thenNF_Tc` \ new_expr ->
612 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
613 returnNF_Tc (ResultStmt new_expr locn : new_stmts)
615 zonkStmts (ExprStmt expr ty locn : stmts)
616 = zonkExpr expr `thenNF_Tc` \ new_expr ->
617 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
618 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
619 returnNF_Tc (ExprStmt new_expr new_ty locn : new_stmts)
621 zonkStmts (LetStmt binds : stmts)
622 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
624 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
625 returnNF_Tc (LetStmt new_binds : new_stmts)
627 zonkStmts (BindStmt pat expr locn : stmts)
628 = zonkExpr expr `thenNF_Tc` \ new_expr ->
629 zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) ->
630 tcExtendGlobalValEnv (bagToList new_ids) $
631 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
632 returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
636 -------------------------------------------------------------------------
637 zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
640 = mapNF_Tc zonk_rbind rbinds
642 zonk_rbind (field, expr, pun)
643 = zonkExpr expr `thenNF_Tc` \ new_expr ->
644 zonkIdOcc field `thenNF_Tc` \ new_field ->
645 returnNF_Tc (new_field, new_expr, pun)
647 -------------------------------------------------------------------------
648 mapIPNameTc :: (a -> NF_TcM b) -> IPName a -> NF_TcM (IPName b)
649 mapIPNameTc f (Dupable n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Dupable r)
650 mapIPNameTc f (Linear n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Linear r)
654 %************************************************************************
656 \subsection[BackSubst-Pats]{Patterns}
658 %************************************************************************
661 zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
664 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
665 returnNF_Tc (WildPat new_ty, emptyBag)
668 = zonkIdBndr v `thenNF_Tc` \ new_v ->
669 returnNF_Tc (VarPat new_v, unitBag new_v)
671 zonkPat (LazyPat pat)
672 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
673 returnNF_Tc (LazyPat new_pat, ids)
675 zonkPat (AsPat n pat)
676 = zonkIdBndr n `thenNF_Tc` \ new_n ->
677 zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
678 returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
680 zonkPat (ListPat ty pats)
681 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
682 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
683 returnNF_Tc (ListPat new_ty new_pats, ids)
685 zonkPat (PArrPat ty pats)
686 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
687 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
688 returnNF_Tc (PArrPat new_ty new_pats, ids)
690 zonkPat (TuplePat pats boxed)
691 = zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
692 returnNF_Tc (TuplePat new_pats boxed, ids)
694 zonkPat (ConPat n ty tvs dicts pats)
695 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
696 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
697 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
698 tcExtendGlobalValEnv new_dicts $
699 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
700 returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
701 listToBag new_dicts `unionBags` ids)
703 zonkPat (RecPat n ty tvs dicts rpats)
704 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
705 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
706 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
707 tcExtendGlobalValEnv new_dicts $
708 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
709 returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
710 listToBag new_dicts `unionBags` unionManyBags ids_s)
712 zonk_rpat (f, pat, pun)
713 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
714 returnNF_Tc ((f, new_pat, pun), ids)
716 zonkPat (LitPat lit ty)
717 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
718 returnNF_Tc (LitPat lit new_ty, emptyBag)
720 zonkPat (SigPat pat ty expr)
721 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
722 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
723 zonkExpr expr `thenNF_Tc` \ new_expr ->
724 returnNF_Tc (SigPat new_pat new_ty new_expr, ids)
726 zonkPat (NPat lit ty expr)
727 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
728 zonkExpr expr `thenNF_Tc` \ new_expr ->
729 returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
731 zonkPat (NPlusKPat n k ty e1 e2)
732 = zonkIdBndr n `thenNF_Tc` \ new_n ->
733 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
734 zonkExpr e1 `thenNF_Tc` \ new_e1 ->
735 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
736 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
738 zonkPat (DictPat ds ms)
739 = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
740 mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
741 returnNF_Tc (DictPat new_ds new_ms,
742 listToBag new_ds `unionBags` listToBag new_ms)
746 = returnNF_Tc ([], emptyBag)
749 = zonkPat pat `thenNF_Tc` \ (pat', ids1) ->
750 zonkPats pats `thenNF_Tc` \ (pats', ids2) ->
751 returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
754 %************************************************************************
756 \subsection[BackSubst-Foreign]{Foreign exports}
758 %************************************************************************
762 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
763 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
765 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
766 zonkForeignExport (ForeignExport i hs_ty spec isDeprec src_loc) =
767 zonkIdOcc i `thenNF_Tc` \ i' ->
768 returnNF_Tc (ForeignExport i' undefined spec isDeprec src_loc)
772 zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
773 zonkRules rs = mapNF_Tc zonkRule rs
775 zonkRule (HsRule name act vars lhs rhs loc)
776 = mapNF_Tc zonk_bndr vars `thenNF_Tc` \ new_bndrs ->
777 tcExtendGlobalValEnv (filter isId new_bndrs) $
778 -- Type variables don't need an envt
779 -- They are bound through the mutable mechanism
780 zonkExpr lhs `thenNF_Tc` \ new_lhs ->
781 zonkExpr rhs `thenNF_Tc` \ new_rhs ->
782 returnNF_Tc (HsRule name act (map RuleBndr new_bndrs) new_lhs new_rhs loc)
783 -- I hate this map RuleBndr stuff
785 zonk_bndr (RuleBndr v)
786 | isId v = zonkIdBndr v
787 | otherwise = zonkTcTyVarToTyVar v
789 zonkRule (IfaceRuleOut fun rule)
790 = zonkIdOcc fun `thenNF_Tc` \ fun' ->
791 returnNF_Tc (IfaceRuleOut fun' rule)
795 zonkCoreBinds :: [TypecheckedCoreBind] -> NF_TcM [TypecheckedCoreBind]
796 zonkCoreBinds ls = mapNF_Tc zonkOne ls
799 zonkIdOcc i `thenNF_Tc` \ i' ->
800 zonkTcTypeToType t `thenNF_Tc` \ t' ->
801 zonkCoreExpr e `thenNF_Tc` \ e' ->
802 returnNF_Tc (i',t',e')
805 zonkCoreExpr :: CoreExpr -> NF_TcM CoreExpr
809 zonkIdOcc i `thenNF_Tc` \ i' ->
811 Lit l -> returnNF_Tc (Lit l)
813 zonkCoreExpr f `thenNF_Tc` \ f' ->
814 zonkCoreExpr arg `thenNF_Tc` \ arg' ->
815 returnNF_Tc (App f' arg')
817 zonkIdOcc b `thenNF_Tc` \ b' ->
818 zonkCoreExpr e `thenNF_Tc` \ e' ->
819 returnNF_Tc (Lam b' e')
821 zonkCoreExpr scrut `thenNF_Tc` \ scrut' ->
822 zonkIdOcc n `thenNF_Tc` \ n' ->
823 mapNF_Tc zonkCoreAlt alts `thenNF_Tc` \ alts' ->
824 returnNF_Tc (Case scrut' n' alts')
826 zonkCoreBind b `thenNF_Tc` \ b' ->
827 zonkCoreExpr rhs `thenNF_Tc` \ rhs' ->
828 returnNF_Tc (Let b' rhs')
830 zonkNote note `thenNF_Tc` \ note' ->
831 zonkCoreExpr e `thenNF_Tc` \ e' ->
832 returnNF_Tc (Note note' e')
834 zonkTcTypeToType t `thenNF_Tc` \ t' ->
835 returnNF_Tc (Type t')
837 zonkCoreBind :: CoreBind -> NF_TcM CoreBind
838 zonkCoreBind (NonRec b e) =
839 zonkIdOcc b `thenNF_Tc` \ b' ->
840 zonkCoreExpr e `thenNF_Tc` \ e' ->
841 returnNF_Tc (NonRec b' e')
842 zonkCoreBind (Rec bs) =
843 mapNF_Tc zonkIt bs `thenNF_Tc` \ bs' ->
844 returnNF_Tc (Rec bs')
847 zonkIdOcc b `thenNF_Tc` \ b' ->
848 zonkCoreExpr e `thenNF_Tc` \ e' ->
852 zonkCoreAlt :: CoreAlt -> NF_TcM CoreAlt
853 zonkCoreAlt (ac, bs, rhs) =
854 mapNF_Tc zonkIdOcc bs `thenNF_Tc` \ bs' ->
855 zonkCoreExpr rhs `thenNF_Tc` \ rhs' ->
856 returnNF_Tc (ac, bs', rhs')
858 zonkNote :: Note -> NF_TcM Note
862 zonkTcTypeToType t `thenNF_Tc` \ t' ->
863 zonkTcTypeToType f `thenNF_Tc` \ f' ->
864 returnNF_Tc (Coerce t' f')