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,
25 mkHsTyApp, mkHsDictApp,
26 mkHsTyLam, mkHsDictLam, mkHsLet,
28 -- re-exported from TcEnv
33 zonkTopBinds, zonkId, zonkIdOcc,
34 zonkForeignExports, zonkRules
37 #include "HsVersions.h"
40 import HsSyn -- oodles of it
43 import Id ( idName, idType, setIdType, omitIfaceSigForId, Id )
44 import DataCon ( DataCon, dataConArgTys )
45 import TcEnv ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv,
46 ValueEnv, TcId, tcInstId
50 import TcType ( TcType, TcTyVar,
51 zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
53 import TyCon ( isDataTyCon )
54 import Type ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type )
55 import Name ( isLocallyDefined )
57 import VarEnv ( TyVarEnv, emptyVarEnv, extendVarEnvList )
58 import VarSet ( isEmptyVarSet )
59 import CoreSyn ( Expr )
60 import BasicTypes ( RecFlag(..) )
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 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
112 mkHsTyApp expr [] = expr
113 mkHsTyApp expr tys = TyApp expr tys
115 mkHsDictApp expr [] = expr
116 mkHsDictApp expr dict_vars = DictApp expr dict_vars
118 mkHsTyLam [] expr = expr
119 mkHsTyLam tyvars expr = TyLam tyvars expr
121 mkHsDictLam [] expr = expr
122 mkHsDictLam dicts expr = DictLam dicts expr
124 mkHsLet EmptyMonoBinds expr = expr
125 mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
128 %************************************************************************
130 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
132 %************************************************************************
134 Some gruesome hackery for desugaring ccalls. It's here because if we put it
135 in Type.lhs we get irritating loops, and it's only used by TcInstDcls.lhs and
139 maybeBoxedPrimType :: Type -> Maybe (DataCon, Type)
140 maybeBoxedPrimType ty
141 = case splitAlgTyConApp_maybe ty of -- Data type,
142 Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon -- with exactly one constructor
143 -> case (dataConArgTys data_con tys_applied) of
144 [data_con_arg_ty] -- Applied to exactly one type,
145 | isUnLiftedType data_con_arg_ty -- which is primitive
146 -> Just (data_con, data_con_arg_ty)
147 other_cases -> Nothing
148 other_cases -> Nothing
151 %************************************************************************
153 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
155 %************************************************************************
157 This zonking pass runs over the bindings
159 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
160 b) convert unbound TcTyVar to Void
161 c) convert each TcId to an Id by zonking its type
163 The type variables are converted by binding mutable tyvars to immutable ones
164 and then zonking as normal.
166 The Ids are converted by binding them in the normal Tc envt; that
167 way we maintain sharing; eg an Id is zonked at its binding site and they
168 all occurrences of that Id point to the common zonked copy
170 It's all pretty boring stuff, because HsSyn is such a large type, and
171 the environment manipulation is tiresome.
174 -- zonkId is used *during* typechecking just to zonk the Id's type
175 zonkId :: TcId -> NF_TcM s TcId
177 = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
178 returnNF_Tc (setIdType id ty')
180 -- zonkIdBndr is used *after* typechecking to get the Id's type
181 -- to its final form. The TyVarEnv give
182 zonkIdBndr :: TcId -> NF_TcM s Id
184 = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' ->
185 returnNF_Tc (setIdType id ty')
187 zonkIdOcc :: TcId -> NF_TcM s Id
189 | not (isLocallyDefined id) || omitIfaceSigForId id
190 -- The omitIfaceSigForId thing may look wierd but it's quite
191 -- sensible really. We're avoiding looking up superclass selectors
192 -- and constructors; zonking them is a no-op anyway, and the
193 -- superclass selectors aren't in the environment anyway.
196 = tcLookupValueMaybe (idName id) `thenNF_Tc` \ maybe_id' ->
198 new_id = case maybe_id' of
200 Nothing -> pprTrace "zonkIdOcc: " (ppr id) id
207 zonkTopBinds :: TcMonoBinds -> NF_TcM s (TypecheckedMonoBinds, ValueEnv)
208 zonkTopBinds binds -- Top level is implicitly recursive
209 = fixNF_Tc (\ ~(_, new_ids) ->
210 tcExtendGlobalValEnv (bagToList new_ids) $
211 zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
212 tcGetValueEnv `thenNF_Tc` \ env ->
213 returnNF_Tc ((binds', env), new_ids)
214 ) `thenNF_Tc` \ (stuff, _) ->
217 zonkBinds :: TcHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv)
220 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
221 returnNF_Tc (binds', env))
224 -- -> (TypecheckedHsBinds
225 -- -> NF_TcM s (TypecheckedHsBinds, TcEnv)
227 -- -> NF_TcM s (TypecheckedHsBinds, TcEnv)
229 go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
231 thing_inside (b1' `ThenBinds` b2')
233 go EmptyBinds thing_inside = thing_inside EmptyBinds
235 go (MonoBind bind sigs is_rec) thing_inside
236 = ASSERT( null sigs )
237 fixNF_Tc (\ ~(_, new_ids) ->
238 tcExtendGlobalValEnv (bagToList new_ids) $
239 zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
240 thing_inside (MonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
241 returnNF_Tc (stuff, new_ids)
242 ) `thenNF_Tc` \ (stuff, _) ->
247 -------------------------------------------------------------------------
248 zonkMonoBinds :: TcMonoBinds
249 -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
251 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
253 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
254 = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
255 zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
256 returnNF_Tc (b1' `AndMonoBinds` b2',
257 ids1 `unionBags` ids2)
259 zonkMonoBinds (PatMonoBind pat grhss locn)
260 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
261 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
262 returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
264 zonkMonoBinds (VarMonoBind var expr)
265 = zonkIdBndr var `thenNF_Tc` \ new_var ->
266 zonkExpr expr `thenNF_Tc` \ new_expr ->
267 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
269 zonkMonoBinds (CoreMonoBind var core_expr)
270 = zonkIdBndr var `thenNF_Tc` \ new_var ->
271 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
273 zonkMonoBinds (FunMonoBind var inf ms locn)
274 = zonkIdBndr var `thenNF_Tc` \ new_var ->
275 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
276 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
279 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
280 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
281 -- No need to extend tyvar env: the effects are
282 -- propagated through binding the tyvars themselves
284 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
285 tcExtendGlobalValEnv new_dicts $
287 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
288 tcExtendGlobalValEnv (bagToList val_bind_ids) $
289 zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
290 mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports ->
291 returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
292 ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
294 new_globals = listToBag [global | (_, global, local) <- new_exports]
296 returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
299 zonkExport (tyvars, global, local)
300 = mapNF_Tc zonkTcTyVarBndr tyvars `thenNF_Tc` \ new_tyvars ->
301 zonkIdBndr global `thenNF_Tc` \ new_global ->
302 zonkIdOcc local `thenNF_Tc` \ new_local ->
303 returnNF_Tc (new_tyvars, new_global, new_local)
306 %************************************************************************
308 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
310 %************************************************************************
313 zonkMatch :: TcMatch -> NF_TcM s TypecheckedMatch
315 zonkMatch (Match _ pats _ grhss)
316 = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
317 tcExtendGlobalValEnv (bagToList new_ids) $
318 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
319 returnNF_Tc (Match [] new_pats Nothing new_grhss)
321 -------------------------------------------------------------------------
323 -> NF_TcM s TypecheckedGRHSs
325 zonkGRHSs (GRHSs grhss binds (Just ty))
326 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
329 zonk_grhs (GRHS guarded locn)
330 = zonkStmts guarded `thenNF_Tc` \ new_guarded ->
331 returnNF_Tc (GRHS new_guarded locn)
333 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
334 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
335 returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
338 %************************************************************************
340 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
342 %************************************************************************
345 zonkExpr :: TcExpr -> NF_TcM s TypecheckedHsExpr
348 = zonkIdOcc id `thenNF_Tc` \ id' ->
349 returnNF_Tc (HsVar id')
351 zonkExpr (HsLit _) = panic "zonkExpr:HsLit"
353 zonkExpr (HsLitOut lit ty)
354 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
355 returnNF_Tc (HsLitOut lit new_ty)
357 zonkExpr (HsLam match)
358 = zonkMatch match `thenNF_Tc` \ new_match ->
359 returnNF_Tc (HsLam new_match)
361 zonkExpr (HsApp e1 e2)
362 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
363 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
364 returnNF_Tc (HsApp new_e1 new_e2)
366 zonkExpr (OpApp e1 op fixity e2)
367 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
368 zonkExpr op `thenNF_Tc` \ new_op ->
369 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
370 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
372 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
373 zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
375 zonkExpr (SectionL expr op)
376 = zonkExpr expr `thenNF_Tc` \ new_expr ->
377 zonkExpr op `thenNF_Tc` \ new_op ->
378 returnNF_Tc (SectionL new_expr new_op)
380 zonkExpr (SectionR op expr)
381 = zonkExpr op `thenNF_Tc` \ new_op ->
382 zonkExpr expr `thenNF_Tc` \ new_expr ->
383 returnNF_Tc (SectionR new_op new_expr)
385 zonkExpr (HsCase expr ms src_loc)
386 = zonkExpr expr `thenNF_Tc` \ new_expr ->
387 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
388 returnNF_Tc (HsCase new_expr new_ms src_loc)
390 zonkExpr (HsIf e1 e2 e3 src_loc)
391 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
392 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
393 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
394 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
396 zonkExpr (HsLet binds expr)
397 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
399 zonkExpr expr `thenNF_Tc` \ new_expr ->
400 returnNF_Tc (HsLet new_binds new_expr)
402 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
404 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
405 = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
406 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
407 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
408 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
409 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
410 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
413 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
415 zonkExpr (ExplicitListOut ty exprs)
416 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
417 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
418 returnNF_Tc (ExplicitListOut new_ty new_exprs)
420 zonkExpr (ExplicitTuple exprs boxed)
421 = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
422 returnNF_Tc (ExplicitTuple new_exprs boxed)
424 zonkExpr (HsCon data_con tys exprs)
425 = mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
426 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
427 returnNF_Tc (HsCon data_con new_tys new_exprs)
429 zonkExpr (RecordConOut data_con con_expr rbinds)
430 = zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
431 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
432 returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
434 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
436 zonkExpr (RecordUpdOut expr ty dicts rbinds)
437 = zonkExpr expr `thenNF_Tc` \ new_expr ->
438 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
439 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
440 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
441 returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
443 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
444 zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
446 zonkExpr (ArithSeqOut expr info)
447 = zonkExpr expr `thenNF_Tc` \ new_expr ->
448 zonkArithSeq info `thenNF_Tc` \ new_info ->
449 returnNF_Tc (ArithSeqOut new_expr new_info)
451 zonkExpr (CCall fun args may_gc is_casm result_ty)
452 = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
453 zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
454 returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
456 zonkExpr (HsSCC label expr)
457 = zonkExpr expr `thenNF_Tc` \ new_expr ->
458 returnNF_Tc (HsSCC label new_expr)
460 zonkExpr (TyLam tyvars expr)
461 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
462 -- No need to extend tyvar env; see AbsBinds
464 zonkExpr expr `thenNF_Tc` \ new_expr ->
465 returnNF_Tc (TyLam new_tyvars new_expr)
467 zonkExpr (TyApp expr tys)
468 = zonkExpr expr `thenNF_Tc` \ new_expr ->
469 mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
470 returnNF_Tc (TyApp new_expr new_tys)
472 zonkExpr (DictLam dicts expr)
473 = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
474 tcExtendGlobalValEnv new_dicts $
475 zonkExpr expr `thenNF_Tc` \ new_expr ->
476 returnNF_Tc (DictLam new_dicts new_expr)
478 zonkExpr (DictApp expr dicts)
479 = zonkExpr expr `thenNF_Tc` \ new_expr ->
480 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
481 returnNF_Tc (DictApp new_expr new_dicts)
485 -------------------------------------------------------------------------
486 zonkArithSeq :: TcArithSeqInfo -> NF_TcM s TypecheckedArithSeqInfo
488 zonkArithSeq (From e)
489 = zonkExpr e `thenNF_Tc` \ new_e ->
490 returnNF_Tc (From new_e)
492 zonkArithSeq (FromThen e1 e2)
493 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
494 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
495 returnNF_Tc (FromThen new_e1 new_e2)
497 zonkArithSeq (FromTo e1 e2)
498 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
499 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
500 returnNF_Tc (FromTo new_e1 new_e2)
502 zonkArithSeq (FromThenTo e1 e2 e3)
503 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
504 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
505 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
506 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
508 -------------------------------------------------------------------------
509 zonkStmts :: [TcStmt]
510 -> NF_TcM s [TypecheckedStmt]
512 zonkStmts [] = returnNF_Tc []
514 zonkStmts [ReturnStmt expr]
515 = zonkExpr expr `thenNF_Tc` \ new_expr ->
516 returnNF_Tc [ReturnStmt new_expr]
518 zonkStmts (ExprStmt expr locn : stmts)
519 = zonkExpr expr `thenNF_Tc` \ new_expr ->
520 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
521 returnNF_Tc (ExprStmt new_expr locn : new_stmts)
523 zonkStmts (GuardStmt expr locn : stmts)
524 = zonkExpr expr `thenNF_Tc` \ new_expr ->
525 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
526 returnNF_Tc (GuardStmt new_expr locn : new_stmts)
528 zonkStmts (LetStmt binds : stmts)
529 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
531 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
532 returnNF_Tc (LetStmt new_binds : new_stmts)
534 zonkStmts (BindStmt pat expr locn : stmts)
535 = zonkExpr expr `thenNF_Tc` \ new_expr ->
536 zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) ->
537 tcExtendGlobalValEnv (bagToList new_ids) $
538 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
539 returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
543 -------------------------------------------------------------------------
544 zonkRbinds :: TcRecordBinds -> NF_TcM s TypecheckedRecordBinds
547 = mapNF_Tc zonk_rbind rbinds
549 zonk_rbind (field, expr, pun)
550 = zonkExpr expr `thenNF_Tc` \ new_expr ->
551 zonkIdOcc field `thenNF_Tc` \ new_field ->
552 returnNF_Tc (new_field, new_expr, pun)
555 %************************************************************************
557 \subsection[BackSubst-Pats]{Patterns}
559 %************************************************************************
562 zonkPat :: TcPat -> NF_TcM s (TypecheckedPat, Bag Id)
565 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
566 returnNF_Tc (WildPat new_ty, emptyBag)
569 = zonkIdBndr v `thenNF_Tc` \ new_v ->
570 returnNF_Tc (VarPat new_v, unitBag new_v)
572 zonkPat (LazyPat pat)
573 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
574 returnNF_Tc (LazyPat new_pat, ids)
576 zonkPat (AsPat n pat)
577 = zonkIdBndr n `thenNF_Tc` \ new_n ->
578 zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
579 returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
581 zonkPat (ListPat ty pats)
582 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
583 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
584 returnNF_Tc (ListPat new_ty new_pats, ids)
586 zonkPat (TuplePat pats boxed)
587 = zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
588 returnNF_Tc (TuplePat new_pats boxed, ids)
590 zonkPat (ConPat n ty tvs dicts pats)
591 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
592 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
593 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
594 tcExtendGlobalValEnv new_dicts $
595 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
596 returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
597 listToBag new_dicts `unionBags` ids)
599 zonkPat (RecPat n ty tvs dicts rpats)
600 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
601 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
602 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
603 tcExtendGlobalValEnv new_dicts $
604 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
605 returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
606 listToBag new_dicts `unionBags` unionManyBags ids_s)
608 zonk_rpat (f, pat, pun)
609 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
610 returnNF_Tc ((f, new_pat, pun), ids)
612 zonkPat (LitPat lit ty)
613 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
614 returnNF_Tc (LitPat lit new_ty, emptyBag)
616 zonkPat (NPat lit ty expr)
617 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
618 zonkExpr expr `thenNF_Tc` \ new_expr ->
619 returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
621 zonkPat (NPlusKPat n k ty e1 e2)
622 = zonkIdBndr n `thenNF_Tc` \ new_n ->
623 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
624 zonkExpr e1 `thenNF_Tc` \ new_e1 ->
625 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
626 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
628 zonkPat (DictPat ds ms)
629 = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
630 mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
631 returnNF_Tc (DictPat new_ds new_ms,
632 listToBag new_ds `unionBags` listToBag new_ms)
636 = returnNF_Tc ([], emptyBag)
639 = zonkPat pat `thenNF_Tc` \ (pat', ids1) ->
640 zonkPats pats `thenNF_Tc` \ (pats', ids2) ->
641 returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
644 %************************************************************************
646 \subsection[BackSubst-Foreign]{Foreign exports}
648 %************************************************************************
652 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM s [TypecheckedForeignDecl]
653 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
655 zonkForeignExport :: TcForeignExportDecl -> NF_TcM s (TypecheckedForeignDecl)
656 zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
657 zonkIdOcc i `thenNF_Tc` \ i' ->
658 returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
662 zonkRules :: [TcRuleDecl] -> NF_TcM s [TypecheckedRuleDecl]
663 zonkRules rs = mapNF_Tc zonkRule rs
665 zonkRule (RuleDecl name tyvars vars lhs rhs loc)
666 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
667 mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars] `thenNF_Tc` \ new_bndrs ->
668 tcExtendGlobalValEnv new_bndrs $
669 zonkExpr lhs `thenNF_Tc` \ new_lhs ->
670 zonkExpr rhs `thenNF_Tc` \ new_rhs ->
671 returnNF_Tc (RuleDecl name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
672 -- I hate this map RuleBndr stuff
674 zonkRule (IfaceRuleDecl fun rule loc)
675 = returnNF_Tc (IfaceRuleDecl fun rule loc)