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,
18 TypecheckedMonoBinds, TypecheckedPat,
19 TypecheckedHsExpr, TypecheckedArithSeqInfo,
20 TypecheckedStmt, TypecheckedForeignDecl,
21 TypecheckedMatch, TypecheckedHsModule,
22 TypecheckedGRHSs, TypecheckedGRHS,
23 TypecheckedRecordBinds, TypecheckedDictBinds,
25 mkHsTyApp, mkHsDictApp,
26 mkHsTyLam, mkHsDictLam,
28 -- re-exported from TcEnv
33 zonkTopBinds, zonkId, zonkIdOcc,
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 )
69 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
70 All the types in @Tc...@ things have mutable type-variables in them for
73 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
74 which have immutable type variables in them.
77 type TcHsBinds = HsBinds TcId TcPat
78 type TcMonoBinds = MonoBinds TcId TcPat
79 type TcDictBinds = TcMonoBinds
80 type TcPat = OutPat TcId
81 type TcExpr = HsExpr TcId TcPat
82 type TcGRHSs = GRHSs TcId TcPat
83 type TcGRHS = GRHS TcId TcPat
84 type TcMatch = Match TcId TcPat
85 type TcStmt = Stmt TcId TcPat
86 type TcArithSeqInfo = ArithSeqInfo TcId TcPat
87 type TcRecordBinds = HsRecordBinds TcId TcPat
88 type TcHsModule = HsModule TcId TcPat
90 type TcCoreExpr = Expr TcId
91 type TcForeignExportDecl = ForeignDecl TcId
93 type TypecheckedPat = OutPat Id
94 type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
95 type TypecheckedDictBinds = TypecheckedMonoBinds
96 type TypecheckedHsBinds = HsBinds Id TypecheckedPat
97 type TypecheckedHsExpr = HsExpr Id TypecheckedPat
98 type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat
99 type TypecheckedStmt = Stmt Id TypecheckedPat
100 type TypecheckedMatch = Match Id TypecheckedPat
101 type TypecheckedGRHSs = GRHSs Id TypecheckedPat
102 type TypecheckedGRHS = GRHS Id TypecheckedPat
103 type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
104 type TypecheckedHsModule = HsModule Id TypecheckedPat
105 type TypecheckedForeignDecl = ForeignDecl Id
109 mkHsTyApp expr [] = expr
110 mkHsTyApp expr tys = TyApp expr tys
112 mkHsDictApp expr [] = expr
113 mkHsDictApp expr dict_vars = DictApp expr dict_vars
115 mkHsTyLam [] expr = expr
116 mkHsTyLam tyvars expr = TyLam tyvars expr
118 mkHsDictLam [] expr = expr
119 mkHsDictLam dicts expr = DictLam dicts expr
122 %************************************************************************
124 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
126 %************************************************************************
128 Some gruesome hackery for desugaring ccalls. It's here because if we put it
129 in Type.lhs we get irritating loops, and it's only used by TcInstDcls.lhs and
133 maybeBoxedPrimType :: Type -> Maybe (DataCon, Type)
134 maybeBoxedPrimType ty
135 = case splitAlgTyConApp_maybe ty of -- Data type,
136 Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon -- with exactly one constructor
137 -> case (dataConArgTys data_con tys_applied) of
138 [data_con_arg_ty] -- Applied to exactly one type,
139 | isUnLiftedType data_con_arg_ty -- which is primitive
140 -> Just (data_con, data_con_arg_ty)
141 other_cases -> Nothing
142 other_cases -> Nothing
145 %************************************************************************
147 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
149 %************************************************************************
151 This zonking pass runs over the bindings
153 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
154 b) convert unbound TcTyVar to Void
155 c) convert each TcId to an Id by zonking its type
157 The type variables are converted by binding mutable tyvars to immutable ones
158 and then zonking as normal.
160 The Ids are converted by binding them in the normal Tc envt; that
161 way we maintain sharing; eg an Id is zonked at its binding site and they
162 all occurrences of that Id point to the common zonked copy
164 It's all pretty boring stuff, because HsSyn is such a large type, and
165 the environment manipulation is tiresome.
168 -- zonkId is used *during* typechecking just to zonk the Id's type
169 zonkId :: TcId -> NF_TcM s TcId
171 = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
172 returnNF_Tc (setIdType id ty')
174 -- zonkIdBndr is used *after* typechecking to get the Id's type
175 -- to its final form. The TyVarEnv give
176 zonkIdBndr :: TcId -> NF_TcM s Id
178 = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' ->
179 returnNF_Tc (setIdType id ty')
181 zonkIdOcc :: TcId -> NF_TcM s Id
183 | not (isLocallyDefined id) || omitIfaceSigForId id
184 -- The omitIfaceSigForId thing may look wierd but it's quite
185 -- sensible really. We're avoiding looking up superclass selectors
186 -- and constructors; zonking them is a no-op anyway, and the
187 -- superclass selectors aren't in the environment anyway.
190 = tcLookupValueMaybe (idName id) `thenNF_Tc` \ maybe_id' ->
192 new_id = case maybe_id' of
194 Nothing -> pprTrace "zonkIdOcc: " (ppr id) id
201 zonkTopBinds :: TcMonoBinds -> NF_TcM s (TypecheckedMonoBinds, ValueEnv)
202 zonkTopBinds binds -- Top level is implicitly recursive
203 = fixNF_Tc (\ ~(_, new_ids) ->
204 tcExtendGlobalValEnv (bagToList new_ids) $
205 zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
206 tcGetValueEnv `thenNF_Tc` \ env ->
207 returnNF_Tc ((binds', env), new_ids)
208 ) `thenNF_Tc` \ (stuff, _) ->
211 zonkBinds :: TcHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv)
214 = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
215 returnNF_Tc (binds', env))
218 -- -> (TypecheckedHsBinds
219 -- -> NF_TcM s (TypecheckedHsBinds, TcEnv)
221 -- -> NF_TcM s (TypecheckedHsBinds, TcEnv)
223 go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
225 thing_inside (b1' `ThenBinds` b2')
227 go EmptyBinds thing_inside = thing_inside EmptyBinds
229 go (MonoBind bind sigs is_rec) thing_inside
230 = ASSERT( null sigs )
231 fixNF_Tc (\ ~(_, new_ids) ->
232 tcExtendGlobalValEnv (bagToList new_ids) $
233 zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
234 thing_inside (MonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
235 returnNF_Tc (stuff, new_ids)
236 ) `thenNF_Tc` \ (stuff, _) ->
241 -------------------------------------------------------------------------
242 zonkMonoBinds :: TcMonoBinds
243 -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
245 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
247 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
248 = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
249 zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
250 returnNF_Tc (b1' `AndMonoBinds` b2',
251 ids1 `unionBags` ids2)
253 zonkMonoBinds (PatMonoBind pat grhss locn)
254 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
255 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
256 returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
258 zonkMonoBinds (VarMonoBind var expr)
259 = zonkIdBndr var `thenNF_Tc` \ new_var ->
260 zonkExpr expr `thenNF_Tc` \ new_expr ->
261 returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
263 zonkMonoBinds (CoreMonoBind var core_expr)
264 = zonkIdBndr var `thenNF_Tc` \ new_var ->
265 returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
267 zonkMonoBinds (FunMonoBind var inf ms locn)
268 = zonkIdBndr var `thenNF_Tc` \ new_var ->
269 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
270 returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
273 zonkMonoBinds (AbsBinds tyvars dicts exports val_bind)
274 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
275 -- No need to extend tyvar env: the effects are
276 -- propagated through binding the tyvars themselves
278 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
279 tcExtendGlobalValEnv new_dicts $
281 fixNF_Tc (\ ~(_, _, val_bind_ids) ->
282 tcExtendGlobalValEnv (bagToList val_bind_ids) $
283 zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
284 mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports ->
285 returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
286 ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
288 new_globals = listToBag [global | (_, global, local) <- new_exports]
290 returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports new_val_bind,
293 zonkExport (tyvars, global, local)
294 = mapNF_Tc zonkTcTyVarBndr tyvars `thenNF_Tc` \ new_tyvars ->
295 zonkIdBndr global `thenNF_Tc` \ new_global ->
296 zonkIdOcc local `thenNF_Tc` \ new_local ->
297 returnNF_Tc (new_tyvars, new_global, new_local)
300 %************************************************************************
302 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
304 %************************************************************************
307 zonkMatch :: TcMatch -> NF_TcM s TypecheckedMatch
309 zonkMatch (Match _ pats _ grhss)
310 = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
311 tcExtendGlobalValEnv (bagToList new_ids) $
312 zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
313 returnNF_Tc (Match [] new_pats Nothing new_grhss)
315 -------------------------------------------------------------------------
317 -> NF_TcM s TypecheckedGRHSs
319 zonkGRHSs (GRHSs grhss binds (Just ty))
320 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
323 zonk_grhs (GRHS guarded locn)
324 = zonkStmts guarded `thenNF_Tc` \ new_guarded ->
325 returnNF_Tc (GRHS new_guarded locn)
327 mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
328 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
329 returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
332 %************************************************************************
334 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
336 %************************************************************************
339 zonkExpr :: TcExpr -> NF_TcM s TypecheckedHsExpr
342 = zonkIdOcc id `thenNF_Tc` \ id' ->
343 returnNF_Tc (HsVar id')
345 zonkExpr (HsLit _) = panic "zonkExpr:HsLit"
347 zonkExpr (HsLitOut lit ty)
348 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
349 returnNF_Tc (HsLitOut lit new_ty)
351 zonkExpr (HsLam match)
352 = zonkMatch match `thenNF_Tc` \ new_match ->
353 returnNF_Tc (HsLam new_match)
355 zonkExpr (HsApp e1 e2)
356 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
357 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
358 returnNF_Tc (HsApp new_e1 new_e2)
360 zonkExpr (OpApp e1 op fixity e2)
361 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
362 zonkExpr op `thenNF_Tc` \ new_op ->
363 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
364 returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
366 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
367 zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
369 zonkExpr (SectionL expr op)
370 = zonkExpr expr `thenNF_Tc` \ new_expr ->
371 zonkExpr op `thenNF_Tc` \ new_op ->
372 returnNF_Tc (SectionL new_expr new_op)
374 zonkExpr (SectionR op expr)
375 = zonkExpr op `thenNF_Tc` \ new_op ->
376 zonkExpr expr `thenNF_Tc` \ new_expr ->
377 returnNF_Tc (SectionR new_op new_expr)
379 zonkExpr (HsCase expr ms src_loc)
380 = zonkExpr expr `thenNF_Tc` \ new_expr ->
381 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
382 returnNF_Tc (HsCase new_expr new_ms src_loc)
384 zonkExpr (HsIf e1 e2 e3 src_loc)
385 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
386 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
387 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
388 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
390 zonkExpr (HsLet binds expr)
391 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
393 zonkExpr expr `thenNF_Tc` \ new_expr ->
394 returnNF_Tc (HsLet new_binds new_expr)
396 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
398 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
399 = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
400 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
401 zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
402 zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
403 zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
404 returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
407 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
409 zonkExpr (ExplicitListOut ty exprs)
410 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
411 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
412 returnNF_Tc (ExplicitListOut new_ty new_exprs)
414 zonkExpr (ExplicitTuple exprs boxed)
415 = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
416 returnNF_Tc (ExplicitTuple new_exprs boxed)
418 zonkExpr (HsCon data_con tys exprs)
419 = mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
420 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
421 returnNF_Tc (HsCon data_con new_tys new_exprs)
423 zonkExpr (RecordConOut data_con con_expr rbinds)
424 = zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
425 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
426 returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
428 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
430 zonkExpr (RecordUpdOut expr ty dicts rbinds)
431 = zonkExpr expr `thenNF_Tc` \ new_expr ->
432 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
433 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
434 zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
435 returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
437 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
438 zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
440 zonkExpr (ArithSeqOut expr info)
441 = zonkExpr expr `thenNF_Tc` \ new_expr ->
442 zonkArithSeq info `thenNF_Tc` \ new_info ->
443 returnNF_Tc (ArithSeqOut new_expr new_info)
445 zonkExpr (CCall fun args may_gc is_casm result_ty)
446 = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
447 zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
448 returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
450 zonkExpr (HsSCC label expr)
451 = zonkExpr expr `thenNF_Tc` \ new_expr ->
452 returnNF_Tc (HsSCC label new_expr)
454 zonkExpr (TyLam tyvars expr)
455 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
456 -- No need to extend tyvar env; see AbsBinds
458 zonkExpr expr `thenNF_Tc` \ new_expr ->
459 returnNF_Tc (TyLam new_tyvars new_expr)
461 zonkExpr (TyApp expr tys)
462 = zonkExpr expr `thenNF_Tc` \ new_expr ->
463 mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
464 returnNF_Tc (TyApp new_expr new_tys)
466 zonkExpr (DictLam dicts expr)
467 = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
468 tcExtendGlobalValEnv new_dicts $
469 zonkExpr expr `thenNF_Tc` \ new_expr ->
470 returnNF_Tc (DictLam new_dicts new_expr)
472 zonkExpr (DictApp expr dicts)
473 = zonkExpr expr `thenNF_Tc` \ new_expr ->
474 mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
475 returnNF_Tc (DictApp new_expr new_dicts)
479 -------------------------------------------------------------------------
480 zonkArithSeq :: TcArithSeqInfo -> NF_TcM s TypecheckedArithSeqInfo
482 zonkArithSeq (From e)
483 = zonkExpr e `thenNF_Tc` \ new_e ->
484 returnNF_Tc (From new_e)
486 zonkArithSeq (FromThen e1 e2)
487 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
488 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
489 returnNF_Tc (FromThen new_e1 new_e2)
491 zonkArithSeq (FromTo e1 e2)
492 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
493 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
494 returnNF_Tc (FromTo new_e1 new_e2)
496 zonkArithSeq (FromThenTo e1 e2 e3)
497 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
498 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
499 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
500 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
502 -------------------------------------------------------------------------
503 zonkStmts :: [TcStmt]
504 -> NF_TcM s [TypecheckedStmt]
506 zonkStmts [] = returnNF_Tc []
508 zonkStmts [ReturnStmt expr]
509 = zonkExpr expr `thenNF_Tc` \ new_expr ->
510 returnNF_Tc [ReturnStmt new_expr]
512 zonkStmts (ExprStmt expr locn : stmts)
513 = zonkExpr expr `thenNF_Tc` \ new_expr ->
514 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
515 returnNF_Tc (ExprStmt new_expr locn : new_stmts)
517 zonkStmts (GuardStmt expr locn : stmts)
518 = zonkExpr expr `thenNF_Tc` \ new_expr ->
519 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
520 returnNF_Tc (GuardStmt new_expr locn : new_stmts)
522 zonkStmts (LetStmt binds : stmts)
523 = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
525 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
526 returnNF_Tc (LetStmt new_binds : new_stmts)
528 zonkStmts (BindStmt pat expr locn : stmts)
529 = zonkExpr expr `thenNF_Tc` \ new_expr ->
530 zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) ->
531 tcExtendGlobalValEnv (bagToList new_ids) $
532 zonkStmts stmts `thenNF_Tc` \ new_stmts ->
533 returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
537 -------------------------------------------------------------------------
538 zonkRbinds :: TcRecordBinds -> NF_TcM s TypecheckedRecordBinds
541 = mapNF_Tc zonk_rbind rbinds
543 zonk_rbind (field, expr, pun)
544 = zonkExpr expr `thenNF_Tc` \ new_expr ->
545 zonkIdOcc field `thenNF_Tc` \ new_field ->
546 returnNF_Tc (new_field, new_expr, pun)
549 %************************************************************************
551 \subsection[BackSubst-Pats]{Patterns}
553 %************************************************************************
556 zonkPat :: TcPat -> NF_TcM s (TypecheckedPat, Bag Id)
559 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
560 returnNF_Tc (WildPat new_ty, emptyBag)
563 = zonkIdBndr v `thenNF_Tc` \ new_v ->
564 returnNF_Tc (VarPat new_v, unitBag new_v)
566 zonkPat (LazyPat pat)
567 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
568 returnNF_Tc (LazyPat new_pat, ids)
570 zonkPat (AsPat n pat)
571 = zonkIdBndr n `thenNF_Tc` \ new_n ->
572 zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
573 returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
575 zonkPat (ListPat ty pats)
576 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
577 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
578 returnNF_Tc (ListPat new_ty new_pats, ids)
580 zonkPat (TuplePat pats boxed)
581 = zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
582 returnNF_Tc (TuplePat new_pats boxed, ids)
584 zonkPat (ConPat n ty tvs dicts pats)
585 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
586 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
587 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
588 tcExtendGlobalValEnv new_dicts $
589 zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
590 returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
591 listToBag new_dicts `unionBags` ids)
593 zonkPat (RecPat n ty tvs dicts rpats)
594 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
595 mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
596 mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
597 tcExtendGlobalValEnv new_dicts $
598 mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
599 returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
600 listToBag new_dicts `unionBags` unionManyBags ids_s)
602 zonk_rpat (f, pat, pun)
603 = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
604 returnNF_Tc ((f, new_pat, pun), ids)
606 zonkPat (LitPat lit ty)
607 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
608 returnNF_Tc (LitPat lit new_ty, emptyBag)
610 zonkPat (NPat lit ty expr)
611 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
612 zonkExpr expr `thenNF_Tc` \ new_expr ->
613 returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
615 zonkPat (NPlusKPat n k ty e1 e2)
616 = zonkIdBndr n `thenNF_Tc` \ new_n ->
617 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
618 zonkExpr e1 `thenNF_Tc` \ new_e1 ->
619 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
620 returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
622 zonkPat (DictPat ds ms)
623 = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
624 mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
625 returnNF_Tc (DictPat new_ds new_ms,
626 listToBag new_ds `unionBags` listToBag new_ms)
630 = returnNF_Tc ([], emptyBag)
633 = zonkPat pat `thenNF_Tc` \ (pat', ids1) ->
634 zonkPats pats `thenNF_Tc` \ (pats', ids2) ->
635 returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
638 %************************************************************************
640 \subsection[BackSubst-Foreign]{Foreign exports}
642 %************************************************************************
646 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM s [TypecheckedForeignDecl]
647 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
649 zonkForeignExport :: TcForeignExportDecl -> NF_TcM s (TypecheckedForeignDecl)
650 zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
651 zonkIdOcc i `thenNF_Tc` \ i' ->
652 returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)