TcHsSyn.lhs 27.1 KB
Newer Older
1
%
2
% (c) The AQUA Project, Glasgow University, 1996-1998
3
4
5
6
7
8
9
10
%
\section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker}

This module is an extension of @HsSyn@ syntax, for use in the type
checker.

\begin{code}
module TcHsSyn (
11
	TcMonoBinds, TcHsBinds, TcPat,
12
	TcExpr, TcGRHSs, TcGRHS, TcMatch,
13
14
	TcStmt, TcArithSeqInfo, TcRecordBinds,
	TcHsModule, TcCoreExpr, TcDictBinds,
sof's avatar
sof committed
15
	TcForeignExportDecl,
16
	
17
	TypecheckedHsBinds, TypecheckedRuleDecl,
18
19
	TypecheckedMonoBinds, TypecheckedPat,
	TypecheckedHsExpr, TypecheckedArithSeqInfo,
sof's avatar
sof committed
20
	TypecheckedStmt, TypecheckedForeignDecl,
21
	TypecheckedMatch, TypecheckedHsModule,
22
	TypecheckedGRHSs, TypecheckedGRHS,
23
	TypecheckedRecordBinds, TypecheckedDictBinds,
24
	TypecheckedMatchContext,
25

26
	mkHsTyApp, mkHsDictApp, mkHsConApp,
27
	mkHsTyLam, mkHsDictLam, mkHsLet,
28
	simpleHsLitTy,
29

30
	collectTypedPatBinders, outPatType, 
31

32
	-- re-exported from TcEnv
33
	TcId, 
34

35
	zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
36
	zonkForeignExports, zonkRules
37
38
  ) where

39
#include "HsVersions.h"
40
41
42
43
44

-- friends:
import HsSyn	-- oodles of it

-- others:
45
import Id	( idName, idType, setIdType, Id )
46
import DataCon	( dataConWrapId )	
47
import TcEnv	( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId )
48

49
import TcMonad
50
import Type	  ( Type )
51
import TcType	  ( TcType )
52
import TcMType	  ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars )
53
54
55
56
import TysPrim	  ( charPrimTy, intPrimTy, floatPrimTy,
		    doublePrimTy, addrPrimTy
		  )
import TysWiredIn ( charTy, stringTy, intTy, integerTy,
chak's avatar
chak committed
57
		    mkListTy, mkPArrTy, mkTupleTy, unitTy )
58
import CoreSyn    ( Expr )
59
import Var	  ( isId )
60
import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName )
sof's avatar
sof committed
61
import Bag
sof's avatar
sof committed
62
import Outputable
63
import HscTypes	( TyThing(..) )
64
65
66
67
68
69
70
71
72
73
74
75
76
77
\end{code}


Type definitions
~~~~~~~~~~~~~~~~

The @Tc...@ datatypes are the ones that apply {\em during} type checking.
All the types in @Tc...@ things have mutable type-variables in them for
unification.

At the end of type checking we zonk everything to @Typechecked...@ datatypes,
which have immutable type variables in them.

\begin{code}
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
type TcHsBinds     	= HsBinds TcId TcPat
type TcMonoBinds	= MonoBinds TcId TcPat
type TcDictBinds	= TcMonoBinds
type TcPat	     	= OutPat TcId
type TcExpr	     	= HsExpr TcId TcPat
type TcGRHSs		= GRHSs TcId TcPat
type TcGRHS		= GRHS TcId TcPat
type TcMatch		= Match TcId TcPat
type TcStmt		= Stmt TcId TcPat
type TcArithSeqInfo	= ArithSeqInfo TcId TcPat
type TcRecordBinds	= HsRecordBinds TcId TcPat
type TcHsModule	= HsModule TcId TcPat

type TcCoreExpr	= Expr TcId
type TcForeignExportDecl = ForeignDecl TcId
93
type TcRuleDecl 	 = RuleDecl    TcId TcPat
94
95
96

type TypecheckedPat		= OutPat	Id
type TypecheckedMonoBinds 	= MonoBinds	Id TypecheckedPat
sof's avatar
sof committed
97
type TypecheckedDictBinds 	= TypecheckedMonoBinds
98
99
100
101
102
type TypecheckedHsBinds		= HsBinds	Id TypecheckedPat
type TypecheckedHsExpr		= HsExpr	Id TypecheckedPat
type TypecheckedArithSeqInfo	= ArithSeqInfo	Id TypecheckedPat
type TypecheckedStmt		= Stmt		Id TypecheckedPat
type TypecheckedMatch		= Match		Id TypecheckedPat
103
type TypecheckedMatchContext	= HsMatchContext Id
104
105
106
107
type TypecheckedGRHSs		= GRHSs		Id TypecheckedPat
type TypecheckedGRHS		= GRHS		Id TypecheckedPat
type TypecheckedRecordBinds	= HsRecordBinds Id TypecheckedPat
type TypecheckedHsModule	= HsModule	Id TypecheckedPat
sof's avatar
sof committed
108
type TypecheckedForeignDecl     = ForeignDecl Id
109
type TypecheckedRuleDecl	= RuleDecl      Id TypecheckedPat
110
111
112
113
114
115
116
117
118
119
120
121
122
123
\end{code}

\begin{code}
mkHsTyApp expr []  = expr
mkHsTyApp expr tys = TyApp expr tys

mkHsDictApp expr []	 = expr
mkHsDictApp expr dict_vars = DictApp expr dict_vars

mkHsTyLam []     expr = expr
mkHsTyLam tyvars expr = TyLam tyvars expr

mkHsDictLam []    expr = expr
mkHsDictLam dicts expr = DictLam dicts expr
124
125
126

mkHsLet EmptyMonoBinds expr = expr
mkHsLet mbinds	       expr = HsLet (MonoBind mbinds [] Recursive) expr
127
128

mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
129
\end{code}
130

131

132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
------------------------------------------------------
\begin{code}
simpleHsLitTy :: HsLit -> TcType
simpleHsLitTy (HsCharPrim c)   = charPrimTy
simpleHsLitTy (HsStringPrim s) = addrPrimTy
simpleHsLitTy (HsInt i)	       = intTy
simpleHsLitTy (HsInteger i)    = integerTy
simpleHsLitTy (HsIntPrim i)    = intPrimTy
simpleHsLitTy (HsFloatPrim f)  = floatPrimTy
simpleHsLitTy (HsDoublePrim d) = doublePrimTy
simpleHsLitTy (HsChar c)       = charTy
simpleHsLitTy (HsString str)   = stringTy
\end{code}


147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
%************************************************************************
%*									*
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
%*									*
%************************************************************************

Note: If @outPatType@ doesn't bear a strong resemblance to @exprType@,
then something is wrong.
\begin{code}
outPatType :: TypecheckedPat -> Type

outPatType (WildPat ty)		= ty
outPatType (VarPat var)		= idType var
outPatType (LazyPat pat)	= outPatType pat
outPatType (AsPat var pat)	= idType var
outPatType (ConPat _ ty _ _ _)	= ty
outPatType (ListPat ty _)	= mkListTy ty
chak's avatar
chak committed
164
outPatType (PArrPat ty _)	= mkPArrTy ty
165
166
outPatType (TuplePat pats box)	= mkTupleTy box (length pats) (map outPatType pats)
outPatType (RecPat _ ty _ _ _)  = ty
167
outPatType (SigPat _ ty _)	= ty
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
outPatType (LitPat lit ty)	= ty
outPatType (NPat lit ty _)	= ty
outPatType (NPlusKPat _ _ ty _ _) = ty
outPatType (DictPat ds ms)      = case (length ds_ms) of
				    0 -> unitTy
				    1 -> idType (head ds_ms)
				    n -> mkTupleTy Boxed n (map idType ds_ms)
				   where
				    ds_ms = ds ++ ms
\end{code}


Nota bene: @DsBinds@ relies on the fact that at least for simple
tuple patterns @collectTypedPatBinders@ returns the binders in
the same order as they appear in the tuple.

@collectTypedBinders@ and @collectedTypedPatBinders@ are the exportees.

\begin{code}
collectTypedPatBinders :: TypecheckedPat -> [Id]
collectTypedPatBinders (VarPat var)	       = [var]
collectTypedPatBinders (LazyPat pat)	       = collectTypedPatBinders pat
collectTypedPatBinders (AsPat a pat)	       = a : collectTypedPatBinders pat
191
collectTypedPatBinders (SigPat pat _ _)	       = collectTypedPatBinders pat
192
193
collectTypedPatBinders (ConPat _ _ _ _ pats)   = concat (map collectTypedPatBinders pats)
collectTypedPatBinders (ListPat t pats)        = concat (map collectTypedPatBinders pats)
chak's avatar
chak committed
194
collectTypedPatBinders (PArrPat t pats)        = concat (map collectTypedPatBinders pats)
195
196
197
198
199
200
201
202
203
collectTypedPatBinders (TuplePat pats _)       = concat (map collectTypedPatBinders pats)
collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat)
							  fields)
collectTypedPatBinders (DictPat ds ms)	       = ds ++ ms
collectTypedPatBinders (NPlusKPat var _ _ _ _) = [var]
collectTypedPatBinders any_other_pat	       = [ {-no binders-} ]
\end{code}


204
205
206
207
208
209
%************************************************************************
%*									*
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
%*									*
%************************************************************************

210
211
212
213
This zonking pass runs over the bindings

 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 b) convert unbound TcTyVar to Void
214
 c) convert each TcId to an Id by zonking its type
sof's avatar
sof committed
215

216
217
The type variables are converted by binding mutable tyvars to immutable ones
and then zonking as normal.
218

219
220
221
The Ids are converted by binding them in the normal Tc envt; that
way we maintain sharing; eg an Id is zonked at its binding site and they
all occurrences of that Id point to the common zonked copy
sof's avatar
sof committed
222

223
224
It's all pretty boring stuff, because HsSyn is such a large type, and 
the environment manipulation is tiresome.
225

226
\begin{code}
227
-- zonkId is used *during* typechecking just to zonk the Id's type
228
zonkId :: TcId -> NF_TcM TcId
229
230
zonkId id
  = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
231
    returnNF_Tc (setIdType id ty')
232

233
234
-- zonkIdBndr is used *after* typechecking to get the Id's type
-- to its final form.  The TyVarEnv give 
235
zonkIdBndr :: TcId -> NF_TcM Id
236
237
238
zonkIdBndr id
  = zonkTcTypeToType (idType id)	`thenNF_Tc` \ ty' ->
    returnNF_Tc (setIdType id ty')
239

240
zonkIdOcc :: TcId -> NF_TcM Id
241
zonkIdOcc id 
242
  = tcLookupGlobal_maybe (idName id)	`thenNF_Tc` \ maybe_id' ->
243
244
245
246
247
248
249
	-- We're even look up up superclass selectors and constructors; 
	-- even though zonking them is a no-op anyway, and the
	-- superclass selectors aren't in the environment anyway.
	-- But we don't want to call isLocalId to find out whether
	-- it's a superclass selector (for example) because that looks
	-- at the IdInfo field, which in turn be in a knot because of
	-- the big knot in typecheckModule
sof's avatar
sof committed
250
251
    let
	new_id = case maybe_id' of
252
		    Just (AnId id') -> id'
253
254
255
		    other  	    -> id -- WARN( isLocalId id, ppr id ) id
					-- Oops: the warning can give a black hole
					-- because it looks at the idinfo
sof's avatar
sof committed
256
257
    in
    returnNF_Tc new_id
258
259
260
261
\end{code}


\begin{code}
262
zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
sof's avatar
sof committed
263
264
265
zonkTopBinds binds	-- Top level is implicitly recursive
  = fixNF_Tc (\ ~(_, new_ids) ->
	tcExtendGlobalValEnv (bagToList new_ids)	$
266
	zonkMonoBinds binds			`thenNF_Tc` \ (binds', new_ids) ->
267
	tcGetEnv				`thenNF_Tc` \ env ->
sof's avatar
sof committed
268
269
270
271
	returnNF_Tc ((binds', env), new_ids)
    )					`thenNF_Tc` \ (stuff, _) ->
    returnNF_Tc stuff

272
zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
sof's avatar
sof committed
273

274
275
276
zonkBinds binds 
  = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env -> 
			  returnNF_Tc (binds', env))
sof's avatar
sof committed
277
  where
278
    -- go :: TcHsBinds
279
    --    -> (TypecheckedHsBinds
280
    --	      -> NF_TcM (TypecheckedHsBinds, TcEnv)
281
    --       ) 
282
    --	  -> NF_TcM (TypecheckedHsBinds, TcEnv)
283

284
285
286
    go (ThenBinds b1 b2) thing_inside = go b1 	$ \ b1' -> 
					go b2 	$ \ b2' ->
					thing_inside (b1' `ThenBinds` b2')
287

288
289
290
    go EmptyBinds thing_inside = thing_inside EmptyBinds

    go (MonoBind bind sigs is_rec) thing_inside
sof's avatar
sof committed
291
	  = ASSERT( null sigs )
292
293
294
	    fixNF_Tc (\ ~(_, new_ids) ->
		tcExtendGlobalValEnv (bagToList new_ids)	$
		zonkMonoBinds bind				`thenNF_Tc` \ (new_bind, new_ids) ->
295
		thing_inside (mkMonoBind new_bind [] is_rec)	`thenNF_Tc` \ stuff ->
296
297
		returnNF_Tc (stuff, new_ids)
	    )							`thenNF_Tc` \ (stuff, _) ->
sof's avatar
sof committed
298
	   returnNF_Tc stuff
299
300
301
302
\end{code}

\begin{code}
-------------------------------------------------------------------------
303
zonkMonoBinds :: TcMonoBinds
304
	      -> NF_TcM (TypecheckedMonoBinds, Bag Id)
305

306
zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
307

308
309
310
zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
  = zonkMonoBinds mbinds1		`thenNF_Tc` \ (b1', ids1) ->
    zonkMonoBinds mbinds2		`thenNF_Tc` \ (b2', ids2) ->
311
312
    returnNF_Tc (b1' `AndMonoBinds` b2', 
		 ids1 `unionBags` ids2)
313

314
315
316
317
zonkMonoBinds (PatMonoBind pat grhss locn)
  = zonkPat pat		`thenNF_Tc` \ (new_pat, ids) ->
    zonkGRHSs grhss	`thenNF_Tc` \ new_grhss ->
    returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
318

319
320
321
322
zonkMonoBinds (VarMonoBind var expr)
  = zonkIdBndr var    	`thenNF_Tc` \ new_var ->
    zonkExpr expr	`thenNF_Tc` \ new_expr ->
    returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
323

324
325
326
zonkMonoBinds (CoreMonoBind var core_expr)
  = zonkIdBndr var    	`thenNF_Tc` \ new_var ->
    returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
327

328
329
330
331
zonkMonoBinds (FunMonoBind var inf ms locn)
  = zonkIdBndr var			`thenNF_Tc` \ new_var ->
    mapNF_Tc zonkMatch ms		`thenNF_Tc` \ new_ms ->
    returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
sof's avatar
sof committed
332
333


334
zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
sof's avatar
sof committed
335
  = mapNF_Tc zonkTcTyVarToTyVar tyvars	`thenNF_Tc` \ new_tyvars ->
336
337
	-- No need to extend tyvar env: the effects are
	-- propagated through binding the tyvars themselves
sof's avatar
sof committed
338

339
    mapNF_Tc zonkIdBndr  dicts		`thenNF_Tc` \ new_dicts ->
sof's avatar
sof committed
340
    tcExtendGlobalValEnv new_dicts			$
341
342
343
344
345
346
347

    fixNF_Tc (\ ~(_, _, val_bind_ids) ->
	tcExtendGlobalValEnv (bagToList val_bind_ids)	$
	zonkMonoBinds val_bind 				`thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
        mapNF_Tc zonkExport exports			`thenNF_Tc` \ new_exports ->
	returnNF_Tc (new_val_bind, new_exports,  val_bind_ids)
    )						`thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
sof's avatar
sof committed
348
    let
sof's avatar
sof committed
349
	    new_globals = listToBag [global | (_, global, local) <- new_exports]
sof's avatar
sof committed
350
    in
351
    returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
sof's avatar
sof committed
352
353
		 new_globals)
  where
354
    zonkExport (tyvars, global, local)
355
356
357
358
359
	= zonkTcSigTyVars tyvars	`thenNF_Tc` \ new_tyvars ->
		-- This isn't the binding occurrence of these tyvars
		-- but they should *be* tyvars.  Hence zonkTcSigTyVars.
	  zonkIdBndr global		`thenNF_Tc` \ new_global ->
	  zonkIdOcc local		`thenNF_Tc` \ new_local -> 
sof's avatar
sof committed
360
	  returnNF_Tc (new_tyvars, new_global, new_local)
361
362
363
364
\end{code}

%************************************************************************
%*									*
365
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
366
367
368
369
%*									*
%************************************************************************

\begin{code}
370
zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
371

372
zonkMatch (Match pats _ grhss)
373
  = zonkPats pats				`thenNF_Tc` \ (new_pats, new_ids) ->
374
    tcExtendGlobalValEnv (bagToList new_ids)	$
375
    zonkGRHSs grhss 				`thenNF_Tc` \ new_grhss ->
376
    returnNF_Tc (Match new_pats Nothing new_grhss)
377

378
-------------------------------------------------------------------------
379
zonkGRHSs :: TcGRHSs
380
	  -> NF_TcM TypecheckedGRHSs
381

382
zonkGRHSs (GRHSs grhss binds ty)
383
  = zonkBinds binds   		`thenNF_Tc` \ (new_binds, new_env) ->
sof's avatar
sof committed
384
    tcSetEnv new_env $
385
    let
386
	zonk_grhs (GRHS guarded locn)
387
	  = zonkStmts guarded  `thenNF_Tc` \ new_guarded ->
388
	    returnNF_Tc (GRHS new_guarded locn)
389
390
    in
    mapNF_Tc zonk_grhs grhss 	`thenNF_Tc` \ new_grhss ->
391
    zonkTcTypeToType ty 	`thenNF_Tc` \ new_ty ->
392
    returnNF_Tc (GRHSs new_grhss new_binds new_ty)
393
394
395
396
397
398
399
400
401
\end{code}

%************************************************************************
%*									*
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
%*									*
%************************************************************************

\begin{code}
402
zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
403

404
zonkExpr (HsVar id)
sof's avatar
sof committed
405
406
  = zonkIdOcc id	`thenNF_Tc` \ id' ->
    returnNF_Tc (HsVar id')
407

408
zonkExpr (HsIPVar id)
409
  = mapIPNameTc zonkIdOcc id	`thenNF_Tc` \ id' ->
410
411
    returnNF_Tc (HsIPVar id')

412
413
414
zonkExpr (HsLit (HsRat f ty))
  = zonkTcTypeToType ty	    `thenNF_Tc` \ new_ty  ->
    returnNF_Tc (HsLit (HsRat f new_ty))
sof's avatar
sof committed
415

416
zonkExpr (HsLit (HsLitLit lit ty))
417
  = zonkTcTypeToType ty	    `thenNF_Tc` \ new_ty  ->
418
419
420
421
422
423
    returnNF_Tc (HsLit (HsLitLit lit new_ty))

zonkExpr (HsLit lit)
  = returnNF_Tc (HsLit lit)

-- HsOverLit doesn't appear in typechecker output
424

425
426
zonkExpr (HsLam match)
  = zonkMatch match	`thenNF_Tc` \ new_match ->
427
428
    returnNF_Tc (HsLam new_match)

429
430
431
zonkExpr (HsApp e1 e2)
  = zonkExpr e1	`thenNF_Tc` \ new_e1 ->
    zonkExpr e2	`thenNF_Tc` \ new_e2 ->
432
433
    returnNF_Tc (HsApp new_e1 new_e2)

434
435
436
437
zonkExpr (OpApp e1 op fixity e2)
  = zonkExpr e1	`thenNF_Tc` \ new_e1 ->
    zonkExpr op	`thenNF_Tc` \ new_op ->
    zonkExpr e2	`thenNF_Tc` \ new_e2 ->
438
    returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
439

440
441
zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
zonkExpr (HsPar _)    = panic "zonkExpr: HsPar"
442

443
444
445
zonkExpr (SectionL expr op)
  = zonkExpr expr	`thenNF_Tc` \ new_expr ->
    zonkExpr op		`thenNF_Tc` \ new_op ->
446
447
    returnNF_Tc (SectionL new_expr new_op)

448
449
450
zonkExpr (SectionR op expr)
  = zonkExpr op		`thenNF_Tc` \ new_op ->
    zonkExpr expr		`thenNF_Tc` \ new_expr ->
451
452
    returnNF_Tc (SectionR new_op new_expr)

453
454
455
zonkExpr (HsCase expr ms src_loc)
  = zonkExpr expr    	    `thenNF_Tc` \ new_expr ->
    mapNF_Tc zonkMatch ms   `thenNF_Tc` \ new_ms ->
456
457
    returnNF_Tc (HsCase new_expr new_ms src_loc)

458
459
460
461
zonkExpr (HsIf e1 e2 e3 src_loc)
  = zonkExpr e1	`thenNF_Tc` \ new_e1 ->
    zonkExpr e2	`thenNF_Tc` \ new_e2 ->
    zonkExpr e3	`thenNF_Tc` \ new_e3 ->
462
463
    returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)

464
465
zonkExpr (HsLet binds expr)
  = zonkBinds binds		`thenNF_Tc` \ (new_binds, new_env) ->
sof's avatar
sof committed
466
    tcSetEnv new_env		$
467
    zonkExpr expr	`thenNF_Tc` \ new_expr ->
468
469
    returnNF_Tc (HsLet new_binds new_expr)

470
zonkExpr (HsWith expr binds)
471
  = zonkIPBinds binds				`thenNF_Tc` \ new_binds ->
472
    tcExtendGlobalValEnv (map (ipNameName . fst) new_binds)	$
473
    zonkExpr expr				`thenNF_Tc` \ new_expr ->
474
475
476
    returnNF_Tc (HsWith new_expr new_binds)
    where
	zonkIPBinds = mapNF_Tc zonkIPBind
477
478
479
480
	zonkIPBind (n, e)
	    = mapIPNameTc zonkIdBndr n	`thenNF_Tc` \ n' ->
	      zonkExpr e		`thenNF_Tc` \ e' ->
	      returnNF_Tc (n', e')
481

482
zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
483

484
485
486
zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
  = zonkStmts stmts 		`thenNF_Tc` \ new_stmts ->
    zonkTcTypeToType ty	`thenNF_Tc` \ new_ty   ->
sof's avatar
sof committed
487
488
489
490
    zonkIdOcc return_id		`thenNF_Tc` \ new_return_id ->
    zonkIdOcc then_id		`thenNF_Tc` \ new_then_id ->
    zonkIdOcc zero_id		`thenNF_Tc` \ new_zero_id ->
    returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
491
			 new_ty src_loc)
492

493
zonkExpr (ExplicitList ty exprs)
494
495
  = zonkTcTypeToType ty		`thenNF_Tc` \ new_ty ->
    mapNF_Tc zonkExpr exprs	`thenNF_Tc` \ new_exprs ->
496
    returnNF_Tc (ExplicitList new_ty new_exprs)
497

chak's avatar
chak committed
498
499
500
501
502
zonkExpr (ExplicitPArr ty exprs)
  = zonkTcTypeToType ty		`thenNF_Tc` \ new_ty ->
    mapNF_Tc zonkExpr exprs	`thenNF_Tc` \ new_exprs ->
    returnNF_Tc (ExplicitPArr new_ty new_exprs)

503
504
zonkExpr (ExplicitTuple exprs boxed)
  = mapNF_Tc zonkExpr exprs  	`thenNF_Tc` \ new_exprs ->
505
    returnNF_Tc (ExplicitTuple new_exprs boxed)
506

507
508
509
zonkExpr (RecordConOut data_con con_expr rbinds)
  = zonkExpr con_expr	`thenNF_Tc` \ new_con_expr ->
    zonkRbinds rbinds	`thenNF_Tc` \ new_rbinds ->
510
    returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
511

512
zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
513

514
zonkExpr (RecordUpdOut expr in_ty out_ty dicts rbinds)
515
  = zonkExpr expr		`thenNF_Tc` \ new_expr ->
516
517
    zonkTcTypeToType in_ty	`thenNF_Tc` \ new_in_ty ->
    zonkTcTypeToType out_ty	`thenNF_Tc` \ new_out_ty ->
sof's avatar
sof committed
518
    mapNF_Tc zonkIdOcc dicts	`thenNF_Tc` \ new_dicts ->
519
    zonkRbinds rbinds	`thenNF_Tc` \ new_rbinds ->
520
    returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_dicts new_rbinds)
521

522
523
zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
zonkExpr (ArithSeqIn _)      = panic "zonkExpr:ArithSeqIn"
chak's avatar
chak committed
524
zonkExpr (PArrSeqIn _)       = panic "zonkExpr:PArrSeqIn"
525

526
527
528
zonkExpr (ArithSeqOut expr info)
  = zonkExpr expr	`thenNF_Tc` \ new_expr ->
    zonkArithSeq info	`thenNF_Tc` \ new_info ->
529
530
    returnNF_Tc (ArithSeqOut new_expr new_info)

chak's avatar
chak committed
531
532
533
534
535
zonkExpr (PArrSeqOut expr info)
  = zonkExpr expr	`thenNF_Tc` \ new_expr ->
    zonkArithSeq info	`thenNF_Tc` \ new_info ->
    returnNF_Tc (PArrSeqOut new_expr new_info)

536
zonkExpr (HsCCall fun args may_gc is_casm result_ty)
537
538
  = mapNF_Tc zonkExpr args 	`thenNF_Tc` \ new_args ->
    zonkTcTypeToType result_ty	`thenNF_Tc` \ new_result_ty ->
539
    returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
540

541
zonkExpr (HsSCC lbl expr)
542
  = zonkExpr expr	`thenNF_Tc` \ new_expr ->
543
    returnNF_Tc (HsSCC lbl new_expr)
544

545
zonkExpr (TyLam tyvars expr)
546
  = mapNF_Tc zonkTcTyVarToTyVar tyvars	`thenNF_Tc` \ new_tyvars ->
547
548
549
	-- No need to extend tyvar env; see AbsBinds

    zonkExpr expr			`thenNF_Tc` \ new_expr ->
550
551
    returnNF_Tc (TyLam new_tyvars new_expr)

552
553
554
zonkExpr (TyApp expr tys)
  = zonkExpr expr    	    		`thenNF_Tc` \ new_expr ->
    mapNF_Tc zonkTcTypeToType tys	`thenNF_Tc` \ new_tys ->
555
556
    returnNF_Tc (TyApp new_expr new_tys)

557
558
zonkExpr (DictLam dicts expr)
  = mapNF_Tc zonkIdBndr dicts		`thenNF_Tc` \ new_dicts ->
sof's avatar
sof committed
559
    tcExtendGlobalValEnv new_dicts	$
560
    zonkExpr expr    	    		`thenNF_Tc` \ new_expr ->
561
562
    returnNF_Tc (DictLam new_dicts new_expr)

563
564
zonkExpr (DictApp expr dicts)
  = zonkExpr expr    	    	`thenNF_Tc` \ new_expr ->
sof's avatar
sof committed
565
    mapNF_Tc zonkIdOcc dicts	`thenNF_Tc` \ new_dicts ->
566
567
568
    returnNF_Tc (DictApp new_expr new_dicts)


569

570
-------------------------------------------------------------------------
571
zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
572

573
574
zonkArithSeq (From e)
  = zonkExpr e		`thenNF_Tc` \ new_e ->
575
576
    returnNF_Tc (From new_e)

577
578
579
zonkArithSeq (FromThen e1 e2)
  = zonkExpr e1	`thenNF_Tc` \ new_e1 ->
    zonkExpr e2	`thenNF_Tc` \ new_e2 ->
580
581
    returnNF_Tc (FromThen new_e1 new_e2)

582
583
584
zonkArithSeq (FromTo e1 e2)
  = zonkExpr e1	`thenNF_Tc` \ new_e1 ->
    zonkExpr e2	`thenNF_Tc` \ new_e2 ->
585
586
    returnNF_Tc (FromTo new_e1 new_e2)

587
588
589
590
zonkArithSeq (FromThenTo e1 e2 e3)
  = zonkExpr e1	`thenNF_Tc` \ new_e1 ->
    zonkExpr e2	`thenNF_Tc` \ new_e2 ->
    zonkExpr e3	`thenNF_Tc` \ new_e3 ->
591
592
593
    returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)

-------------------------------------------------------------------------
594
zonkStmts :: [TcStmt]
595
	  -> NF_TcM [TypecheckedStmt]
596

597
zonkStmts [] = returnNF_Tc []
598

599
600
601
602
603
604
605
606
607
zonkStmts (ParStmtOut bndrstmtss : stmts)
  = mapNF_Tc (mapNF_Tc zonkId) bndrss	`thenNF_Tc` \ new_bndrss ->
    let new_binders = concat new_bndrss in
    mapNF_Tc zonkStmts stmtss		`thenNF_Tc` \ new_stmtss ->
    tcExtendGlobalValEnv new_binders	$ 
    zonkStmts stmts			`thenNF_Tc` \ new_stmts ->
    returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
  where (bndrss, stmtss) = unzip bndrstmtss

608
609
610
611
612
zonkStmts (ResultStmt expr locn : stmts)
  = zonkExpr expr	`thenNF_Tc` \ new_expr ->
    zonkStmts stmts	`thenNF_Tc` \ new_stmts ->
    returnNF_Tc (ResultStmt new_expr locn : new_stmts)

613
zonkStmts (ExprStmt expr ty locn : stmts)
614
  = zonkExpr expr	`thenNF_Tc` \ new_expr ->
615
    zonkTcTypeToType ty	`thenNF_Tc` \ new_ty ->
616
    zonkStmts stmts	`thenNF_Tc` \ new_stmts ->
617
    returnNF_Tc (ExprStmt new_expr new_ty locn : new_stmts)
618

619
620
zonkStmts (LetStmt binds : stmts)
  = zonkBinds binds		`thenNF_Tc` \ (new_binds, new_env) ->
sof's avatar
sof committed
621
    tcSetEnv new_env		$
622
    zonkStmts stmts		`thenNF_Tc` \ new_stmts ->
623
    returnNF_Tc (LetStmt new_binds : new_stmts)
624

625
626
627
zonkStmts (BindStmt pat expr locn : stmts)
  = zonkExpr expr				`thenNF_Tc` \ new_expr ->
    zonkPat pat					`thenNF_Tc` \ (new_pat, new_ids) ->
628
    tcExtendGlobalValEnv (bagToList new_ids)	$ 
629
    zonkStmts stmts				`thenNF_Tc` \ new_stmts ->
630
    returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
631
632


633
634

-------------------------------------------------------------------------
635
zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
636

637
zonkRbinds rbinds
638
639
640
  = mapNF_Tc zonk_rbind rbinds
  where
    zonk_rbind (field, expr, pun)
641
      = zonkExpr expr		`thenNF_Tc` \ new_expr ->
sof's avatar
sof committed
642
643
	zonkIdOcc field		`thenNF_Tc` \ new_field ->
	returnNF_Tc (new_field, new_expr, pun)
644
645
646

-------------------------------------------------------------------------
mapIPNameTc :: (a -> NF_TcM b) -> IPName a -> NF_TcM (IPName b)
647
648
mapIPNameTc f (Dupable n) = f n  `thenNF_Tc` \ r -> returnNF_Tc (Dupable r)
mapIPNameTc f (Linear  n) = f n  `thenNF_Tc` \ r -> returnNF_Tc (Linear r)
649
650
\end{code}

651

652
653
654
655
656
657
658
%************************************************************************
%*									*
\subsection[BackSubst-Pats]{Patterns}
%*									*
%************************************************************************

\begin{code}
659
zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
sof's avatar
sof committed
660

661
662
663
zonkPat (WildPat ty)
  = zonkTcTypeToType ty	    `thenNF_Tc` \ new_ty ->
    returnNF_Tc (WildPat new_ty, emptyBag)
664

665
666
667
zonkPat (VarPat v)
  = zonkIdBndr v	    `thenNF_Tc` \ new_v ->
    returnNF_Tc (VarPat new_v, unitBag new_v)
668

669
670
671
zonkPat (LazyPat pat)
  = zonkPat pat	    `thenNF_Tc` \ (new_pat, ids) ->
    returnNF_Tc (LazyPat new_pat, ids)
672

673
674
675
676
zonkPat (AsPat n pat)
  = zonkIdBndr n	    `thenNF_Tc` \ new_n ->
    zonkPat pat	    `thenNF_Tc` \ (new_pat, ids) ->
    returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
677

678
679
680
681
zonkPat (ListPat ty pats)
  = zonkTcTypeToType ty	`thenNF_Tc` \ new_ty ->
    zonkPats pats		`thenNF_Tc` \ (new_pats, ids) ->
    returnNF_Tc (ListPat new_ty new_pats, ids)
682

chak's avatar
chak committed
683
684
685
686
687
zonkPat (PArrPat ty pats)
  = zonkTcTypeToType ty	`thenNF_Tc` \ new_ty ->
    zonkPats pats		`thenNF_Tc` \ (new_pats, ids) ->
    returnNF_Tc (PArrPat new_ty new_pats, ids)

688
689
690
zonkPat (TuplePat pats boxed)
  = zonkPats pats   		`thenNF_Tc` \ (new_pats, ids) ->
    returnNF_Tc (TuplePat new_pats boxed, ids)
691

692
zonkPat (ConPat n ty tvs dicts pats)
693
  = zonkTcTypeToType ty			`thenNF_Tc` \ new_ty ->
694
    mapNF_Tc zonkTcTyVarToTyVar tvs	`thenNF_Tc` \ new_tvs ->
695
    mapNF_Tc zonkIdBndr dicts		`thenNF_Tc` \ new_dicts ->
696
    tcExtendGlobalValEnv new_dicts	$
697
    zonkPats pats			`thenNF_Tc` \ (new_pats, ids) ->
698
699
    returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats, 
		 listToBag new_dicts `unionBags` ids)
700

701
702
zonkPat (RecPat n ty tvs dicts rpats)
  = zonkTcTypeToType ty			`thenNF_Tc` \ new_ty ->
703
    mapNF_Tc zonkTcTyVarToTyVar tvs	`thenNF_Tc` \ new_tvs ->
704
705
706
    mapNF_Tc zonkIdBndr dicts		`thenNF_Tc` \ new_dicts ->
    tcExtendGlobalValEnv new_dicts	$
    mapAndUnzipNF_Tc zonk_rpat rpats	`thenNF_Tc` \ (new_rpats, ids_s) ->
707
708
    returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats, 
		 listToBag new_dicts `unionBags` unionManyBags ids_s)
709
  where
710
711
712
713
714
715
716
717
    zonk_rpat (f, pat, pun)
      = zonkPat pat		`thenNF_Tc` \ (new_pat, ids) ->
	returnNF_Tc ((f, new_pat, pun), ids)

zonkPat (LitPat lit ty)
  = zonkTcTypeToType ty	    `thenNF_Tc` \ new_ty  ->
    returnNF_Tc (LitPat lit new_ty, emptyBag)

718
719
720
721
722
723
zonkPat (SigPat pat ty expr)
  = zonkPat pat			`thenNF_Tc` \ (new_pat, ids) ->
    zonkTcTypeToType ty		`thenNF_Tc` \ new_ty  ->
    zonkExpr expr		`thenNF_Tc` \ new_expr ->
    returnNF_Tc (SigPat new_pat new_ty new_expr, ids)

724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
zonkPat (NPat lit ty expr)
  = zonkTcTypeToType ty		`thenNF_Tc` \ new_ty   ->
    zonkExpr expr		`thenNF_Tc` \ new_expr ->
    returnNF_Tc (NPat lit new_ty new_expr, emptyBag)

zonkPat (NPlusKPat n k ty e1 e2)
  = zonkIdBndr n		`thenNF_Tc` \ new_n ->
    zonkTcTypeToType ty	`thenNF_Tc` \ new_ty ->
    zonkExpr e1		`thenNF_Tc` \ new_e1 ->
    zonkExpr e2		`thenNF_Tc` \ new_e2 ->
    returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)

zonkPat (DictPat ds ms)
  = mapNF_Tc zonkIdBndr ds    `thenNF_Tc` \ new_ds ->
    mapNF_Tc zonkIdBndr ms    `thenNF_Tc` \ new_ms ->
    returnNF_Tc (DictPat new_ds new_ms,
sof's avatar
sof committed
740
		 listToBag new_ds `unionBags` listToBag new_ms)
741
742


743
744
zonkPats []
  = returnNF_Tc ([], emptyBag)
745

746
747
748
749
zonkPats (pat:pats) 
  = zonkPat pat		`thenNF_Tc` \ (pat',  ids1) ->
    zonkPats pats	`thenNF_Tc` \ (pats', ids2) ->
    returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
750
751
\end{code}

sof's avatar
sof committed
752
753
754
755
756
757
%************************************************************************
%*									*
\subsection[BackSubst-Foreign]{Foreign exports}
%*									*
%************************************************************************

758

sof's avatar
sof committed
759
\begin{code}
760
zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
sof's avatar
sof committed
761
762
zonkForeignExports ls = mapNF_Tc zonkForeignExport ls

763
zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
chak's avatar
chak committed
764
zonkForeignExport (ForeignExport i hs_ty spec isDeprec src_loc) =
sof's avatar
sof committed
765
   zonkIdOcc i	`thenNF_Tc` \ i' ->
chak's avatar
chak committed
766
   returnNF_Tc (ForeignExport i' undefined spec isDeprec src_loc)
sof's avatar
sof committed
767
\end{code}
768
769

\begin{code}
770
zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
771
772
zonkRules rs = mapNF_Tc zonkRule rs

773
zonkRule (HsRule name act vars lhs rhs loc)
774
775
776
777
  = mapNF_Tc zonk_bndr vars				`thenNF_Tc` \ new_bndrs ->
    tcExtendGlobalValEnv (filter isId new_bndrs)	$
	-- Type variables don't need an envt
	-- They are bound through the mutable mechanism
778
779
    zonkExpr lhs					`thenNF_Tc` \ new_lhs ->
    zonkExpr rhs					`thenNF_Tc` \ new_rhs ->
780
    returnNF_Tc (HsRule name act (map RuleBndr new_bndrs) new_lhs new_rhs loc)
781
	-- I hate this map RuleBndr stuff
782
783
784
785
  where
   zonk_bndr (RuleBndr v) 
	| isId v    = zonkIdBndr v
	| otherwise = zonkTcTyVarToTyVar v
786

787
788
789
zonkRule (IfaceRuleOut fun rule)
  = zonkIdOcc fun	`thenNF_Tc` \ fun' ->
    returnNF_Tc (IfaceRuleOut fun' rule)
790
\end{code}