Super-monster patch implementing the new typechecker -- at last
[ghc.git] / compiler / typecheck / TcHsSyn.lhs
1 1%
2 % (c) The University of Glasgow 2006
3 % (c) The AQUA Project, Glasgow University, 1996-1998
4 %
5
6 TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker
7
8 This module is an extension of @HsSyn@ syntax, for use in the type
9 checker.
10
11 \begin{code}
12 module TcHsSyn (
13         mkHsConApp, mkHsDictLet, mkHsApp,
14         hsLitType, hsLPatType, hsPatType, 
15         mkHsAppTy, mkSimpleHsAlt,
16         nlHsIntLit, 
17         shortCutLit, hsOverLitName,
18         
19         -- re-exported from TcMonad
20         TcId, TcIdSet, 
21
22         zonkTopDecls, zonkTopExpr, zonkTopLExpr,
23         zonkId, zonkTopBndrs
24   ) where
25
26 #include "HsVersions.h"
27
28 -- friends:
29 import HsSyn    -- oodles of it
30
31 -- others:
32 import Id
33
34 import TcRnMonad
35 import PrelNames
36 import TcType
37 import TcMType
38 import TysPrim
39 import TysWiredIn
40 import DataCon
41 import Name
42 import Var
43 import VarSet
44 import VarEnv
45 import Literal
46 import BasicTypes
47 import Maybes
48 import SrcLoc
49 import Bag
50 import Outputable
51 \end{code}
52
53 \begin{code}
54 -- XXX
55 thenM :: Monad a => a b -> (b -> a c) -> a c
56 thenM = (>>=)
57
58 returnM :: Monad m => a -> m a
59 returnM = return
60
61 mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
62 mappM = mapM
63 \end{code}
64
65
66 %************************************************************************
67 %*                                                                      *
68 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
69 %*                                                                      *
70 %************************************************************************
71
72 Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
73 then something is wrong.
74 \begin{code}
75 hsLPatType :: OutPat Id -> Type
76 hsLPatType (L _ pat) = hsPatType pat
77
78 hsPatType :: Pat Id -> Type
79 hsPatType (ParPat pat)                = hsLPatType pat
80 hsPatType (WildPat ty)                = ty
81 hsPatType (VarPat var)                = idType var
82 hsPatType (VarPatOut var _)           = idType var
83 hsPatType (BangPat pat)               = hsLPatType pat
84 hsPatType (LazyPat pat)               = hsLPatType pat
85 hsPatType (LitPat lit)                = hsLitType lit
86 hsPatType (AsPat var _)               = idType (unLoc var)
87 hsPatType (ViewPat _ _ ty)            = ty
88 hsPatType (ListPat _ ty)              = mkListTy ty
89 hsPatType (PArrPat _ ty)              = mkPArrTy ty
90 hsPatType (TuplePat _ _ ty)           = ty
91 hsPatType (ConPatOut { pat_ty = ty }) = ty
92 hsPatType (SigPatOut _ ty)            = ty
93 hsPatType (NPat lit _ _)              = overLitType lit
94 hsPatType (NPlusKPat id _ _ _)        = idType (unLoc id)
95 hsPatType (CoPat _ _ ty)              = ty
96 hsPatType p                           = pprPanic "hsPatType" (ppr p)
97
98 hsLitType :: HsLit -> TcType
99 hsLitType (HsChar _)       = charTy
100 hsLitType (HsCharPrim _)   = charPrimTy
101 hsLitType (HsString _)     = stringTy
102 hsLitType (HsStringPrim _) = addrPrimTy
103 hsLitType (HsInt _)        = intTy
104 hsLitType (HsIntPrim _)    = intPrimTy
105 hsLitType (HsWordPrim _)   = wordPrimTy
106 hsLitType (HsInteger _ ty) = ty
107 hsLitType (HsRat _ ty)     = ty
108 hsLitType (HsFloatPrim _)  = floatPrimTy
109 hsLitType (HsDoublePrim _) = doublePrimTy
110 \end{code}
111
112 Overloaded literals. Here mainly becuase it uses isIntTy etc
113
114 \begin{code}
115 shortCutLit :: OverLitVal -> TcType -> Maybe (HsExpr TcId)
116 shortCutLit (HsIntegral i) ty
117   | isIntTy ty && inIntRange i   = Just (HsLit (HsInt i))
118   | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
119   | isIntegerTy ty               = Just (HsLit (HsInteger i ty))
120   | otherwise                    = shortCutLit (HsFractional (fromInteger i)) ty
121         -- The 'otherwise' case is important
122         -- Consider (3 :: Float).  Syntactically it looks like an IntLit,
123         -- so we'll call shortCutIntLit, but of course it's a float
124         -- This can make a big difference for programs with a lot of
125         -- literals, compiled without -O
126
127 shortCutLit (HsFractional f) ty
128   | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim f))
129   | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
130   | otherwise     = Nothing
131
132 shortCutLit (HsIsString s) ty
133   | isStringTy ty = Just (HsLit (HsString s))
134   | otherwise     = Nothing
135
136 mkLit :: DataCon -> HsLit -> HsExpr Id
137 mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
138
139 ------------------------------
140 hsOverLitName :: OverLitVal -> Name
141 -- Get the canonical 'fromX' name for a particular OverLitVal
142 hsOverLitName (HsIntegral {})   = fromIntegerName
143 hsOverLitName (HsFractional {}) = fromRationalName
144 hsOverLitName (HsIsString {})   = fromStringName
145 \end{code}
146
147 %************************************************************************
148 %*                                                                      *
149 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
150 %*                                                                      *
151 %************************************************************************
152
153 \begin{code}
154 -- zonkId is used *during* typechecking just to zonk the Id's type
155 zonkId :: TcId -> TcM TcId
156 zonkId id
157   = zonkTcType (idType id) `thenM` \ ty' ->
158     returnM (Id.setIdType id ty')
159 \end{code}
160
161 The rest of the zonking is done *after* typechecking.
162 The main zonking pass runs over the bindings
163
164  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
165  b) convert unbound TcTyVar to Void
166  c) convert each TcId to an Id by zonking its type
167
168 The type variables are converted by binding mutable tyvars to immutable ones
169 and then zonking as normal.
170
171 The Ids are converted by binding them in the normal Tc envt; that
172 way we maintain sharing; eg an Id is zonked at its binding site and they
173 all occurrences of that Id point to the common zonked copy
174
175 It's all pretty boring stuff, because HsSyn is such a large type, and 
176 the environment manipulation is tiresome.
177
178 \begin{code}
179 data ZonkEnv = ZonkEnv  (TcType -> TcM Type)    -- How to zonk a type
180                         (VarEnv Var)            -- What variables are in scope
181         -- Maps an Id or EvVar to its zonked version; both have the same Name
182         -- Note that all evidence (coercion variables as well as dictionaries)
183         --      are kept in the ZonkEnv
184         -- Only *type* abstraction is done by side effect
185         -- Is only consulted lazily; hence knot-tying
186
187 emptyZonkEnv :: ZonkEnv
188 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
189
190 extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
191 extendZonkEnv (ZonkEnv zonk_ty env) ids 
192   = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
193
194 extendZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
195 extendZonkEnv1 (ZonkEnv zonk_ty env) id 
196   = ZonkEnv zonk_ty (extendVarEnv env id id)
197
198 setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
199 setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
200
201 zonkEnvIds :: ZonkEnv -> [Id]
202 zonkEnvIds (ZonkEnv _ env) = varEnvElts env
203
204 zonkIdOcc :: ZonkEnv -> TcId -> Id
205 -- Ids defined in this module should be in the envt; 
206 -- ignore others.  (Actually, data constructors are also
207 -- not LocalVars, even when locally defined, but that is fine.)
208 -- (Also foreign-imported things aren't currently in the ZonkEnv;
209 --  that's ok because they don't need zonking.)
210 --
211 -- Actually, Template Haskell works in 'chunks' of declarations, and
212 -- an earlier chunk won't be in the 'env' that the zonking phase 
213 -- carries around.  Instead it'll be in the tcg_gbl_env, already fully
214 -- zonked.  There's no point in looking it up there (except for error 
215 -- checking), and it's not conveniently to hand; hence the simple
216 -- 'orElse' case in the LocalVar branch.
217 --
218 -- Even without template splices, in module Main, the checking of
219 -- 'main' is done as a separate chunk.
220 zonkIdOcc (ZonkEnv _zonk_ty env) id 
221   | isLocalVar id = lookupVarEnv env id `orElse` id
222   | otherwise     = id
223
224 zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
225 zonkIdOccs env ids = map (zonkIdOcc env) ids
226
227 -- zonkIdBndr is used *after* typechecking to get the Id's type
228 -- to its final form.  The TyVarEnv give 
229 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
230 zonkIdBndr env id
231   = zonkTcTypeToType env (idType id)    `thenM` \ ty' ->
232     returnM (Id.setIdType id ty')
233
234 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
235 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
236
237 zonkTopBndrs :: [TcId] -> TcM [Id]
238 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
239
240 zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
241 zonkEvBndrsX = mapAccumLM zonkEvBndrX 
242
243 zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
244 -- Works for dictionaries and coercions
245 zonkEvBndrX env var
246   = do { var' <- zonkEvBndr env var
247        ; return (extendZonkEnv1 env var', var') }
248
249 zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
250 -- Works for dictionaries and coercions
251 -- Does not extend the ZonkEnv
252 zonkEvBndr env var 
253   = do { ty' <- zonkTcTypeToType env (varType var)
254        ; return (setVarType var ty') }
255
256 zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar
257 zonkEvVarOcc env v = zonkIdOcc env v
258 \end{code}
259
260
261 \begin{code}
262 zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
263 zonkTopExpr e = zonkExpr emptyZonkEnv e
264
265 zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
266 zonkTopLExpr e = zonkLExpr emptyZonkEnv e
267
268 zonkTopDecls :: Bag EvBind -> LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
269              -> TcM ([Id], 
270                      Bag EvBind,
271                      Bag (LHsBind  Id),
272                      [LForeignDecl Id],
273                      [LRuleDecl    Id])
274 zonkTopDecls ev_binds binds rules fords
275   = do  { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
276
277         ; (env2, binds') <- zonkRecMonoBinds env1 binds
278                         -- Top level is implicitly recursive
279         ; rules' <- zonkRules env2 rules
280         ; fords' <- zonkForeignExports env2 fords
281         ; return (zonkEnvIds env2, ev_binds', binds', fords', rules') }
282
283 ---------------------------------------------
284 zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
285 zonkLocalBinds env EmptyLocalBinds
286   = return (env, EmptyLocalBinds)
287
288 zonkLocalBinds env (HsValBinds binds)
289   = do  { (env1, new_binds) <- zonkValBinds env binds
290         ; return (env1, HsValBinds new_binds) }
291
292 zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
293   = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
294     let
295         env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
296     in
297     zonkTcEvBinds env1 dict_binds       `thenM` \ (env2, new_dict_binds) -> 
298     returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
299   where
300     zonk_ip_bind (IPBind n e)
301         = mapIPNameTc (zonkIdBndr env) n        `thenM` \ n' ->
302           zonkLExpr env e                       `thenM` \ e' ->
303           returnM (IPBind n' e')
304
305
306 ---------------------------------------------
307 zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id)
308 zonkValBinds _ (ValBindsIn _ _) 
309   = panic "zonkValBinds" -- Not in typechecker output
310 zonkValBinds env (ValBindsOut binds sigs) 
311   = do  { (env1, new_binds) <- go env binds
312         ; return (env1, ValBindsOut new_binds sigs) }
313   where
314     go env []         = return (env, [])
315     go env ((r,b):bs) = do { (env1, b')  <- zonkRecMonoBinds env b
316                            ; (env2, bs') <- go env1 bs
317                            ; return (env2, (r,b'):bs') }
318
319 ---------------------------------------------
320 zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
321 zonkRecMonoBinds env binds 
322  = fixM (\ ~(_, new_binds) -> do 
323         { let env1 = extendZonkEnv env (collectHsBindsBinders new_binds)
324         ; binds' <- zonkMonoBinds env1 binds
325         ; return (env1, binds') })
326
327 ---------------------------------------------
328 zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
329 zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
330
331 zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
332 zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
333   = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
334         ; new_grhss <- zonkGRHSs env grhss
335         ; new_ty    <- zonkTcTypeToType env ty
336         ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
337
338 zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
339   = zonkIdBndr env var                  `thenM` \ new_var ->
340     zonkLExpr env expr                  `thenM` \ new_expr ->
341     returnM (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl })
342
343 zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms
344                             , fun_co_fn = co_fn })
345   = wrapLocM (zonkIdBndr env) var       `thenM` \ new_var ->
346     zonkCoFn env co_fn                  `thenM` \ (env1, new_co_fn) ->
347     zonkMatchGroup env1 ms              `thenM` \ new_ms ->
348     returnM (bind { fun_id = new_var, fun_matches = new_ms
349                   , fun_co_fn = new_co_fn })
350
351 zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs, abs_ev_binds = ev_binds,
352                           abs_exports = exports, abs_binds = val_binds })
353   = ASSERT( all isImmutableTyVar tyvars )
354     do { (env1, new_evs) <- zonkEvBndrsX env evs
355        ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
356        ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
357          do { let env3 = extendZonkEnv env2 (collectHsBindsBinders new_val_binds)
358             ; new_val_binds <- zonkMonoBinds env3 val_binds
359             ; new_exports   <- mapM (zonkExport env3) exports
360             ; return (new_val_binds, new_exports) } 
361        ; return (AbsBinds { abs_tvs = tyvars, abs_ev_vars = new_evs, abs_ev_binds = new_ev_binds
362                           , abs_exports = new_exports, abs_binds = new_val_bind }) }
363   where
364     zonkExport env (tyvars, global, local, prags)
365         -- The tyvars are already zonked
366         = zonkIdBndr env global                 `thenM` \ new_global ->
367           zonkSpecPrags env prags               `thenM` \ new_prags -> 
368           returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
369
370 zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
371 zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
372 zonkSpecPrags env (SpecPrags ps)  = do { ps' <- mapM zonk_prag ps
373                                        ; return (SpecPrags ps') }
374   where
375     zonk_prag (L loc (SpecPrag co_fn inl))
376         = do { (_, co_fn') <- zonkCoFn env co_fn
377              ; return (L loc (SpecPrag co_fn' inl)) }
378 \end{code}
379
380 %************************************************************************
381 %*                                                                      *
382 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
383 %*                                                                      *
384 %************************************************************************
385
386 \begin{code}
387 zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id)
388 zonkMatchGroup env (MatchGroup ms ty) 
389   = do  { ms' <- mapM (zonkMatch env) ms
390         ; ty' <- zonkTcTypeToType env ty
391         ; return (MatchGroup ms' ty') }
392
393 zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
394 zonkMatch env (L loc (Match pats _ grhss))
395   = do  { (env1, new_pats) <- zonkPats env pats
396         ; new_grhss <- zonkGRHSs env1 grhss
397         ; return (L loc (Match new_pats Nothing new_grhss)) }
398
399 -------------------------------------------------------------------------
400 zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
401
402 zonkGRHSs env (GRHSs grhss binds)
403   = zonkLocalBinds env binds    `thenM` \ (new_env, new_binds) ->
404     let
405         zonk_grhs (GRHS guarded rhs)
406           = zonkStmts new_env guarded   `thenM` \ (env2, new_guarded) ->
407             zonkLExpr env2 rhs          `thenM` \ new_rhs ->
408             returnM (GRHS new_guarded new_rhs)
409     in
410     mappM (wrapLocM zonk_grhs) grhss    `thenM` \ new_grhss ->
411     returnM (GRHSs new_grhss new_binds)
412 \end{code}
413
414 %************************************************************************
415 %*                                                                      *
416 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
417 %*                                                                      *
418 %************************************************************************
419
420 \begin{code}
421 zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
422 zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
423 zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
424
425 zonkLExprs env exprs = mappM (zonkLExpr env) exprs
426 zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
427
428 zonkExpr env (HsVar id)
429   = returnM (HsVar (zonkIdOcc env id))
430
431 zonkExpr env (HsIPVar id)
432   = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
433
434 zonkExpr env (HsLit (HsRat f ty))
435   = zonkTcTypeToType env ty        `thenM` \ new_ty  ->
436     returnM (HsLit (HsRat f new_ty))
437
438 zonkExpr _ (HsLit lit)
439   = returnM (HsLit lit)
440
441 zonkExpr env (HsOverLit lit)
442   = do  { lit' <- zonkOverLit env lit
443         ; return (HsOverLit lit') }
444
445 zonkExpr env (HsLam matches)
446   = zonkMatchGroup env matches  `thenM` \ new_matches ->
447     returnM (HsLam new_matches)
448
449 zonkExpr env (HsApp e1 e2)
450   = zonkLExpr env e1    `thenM` \ new_e1 ->
451     zonkLExpr env e2    `thenM` \ new_e2 ->
452     returnM (HsApp new_e1 new_e2)
453
454 zonkExpr env (HsBracketOut body bs) 
455   = mappM zonk_b bs     `thenM` \ bs' ->
456     returnM (HsBracketOut body bs')
457   where
458     zonk_b (n,e) = zonkLExpr env e      `thenM` \ e' ->
459                    returnM (n,e')
460
461 zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
462                              returnM (HsSpliceE s)
463
464 zonkExpr env (OpApp e1 op fixity e2)
465   = zonkLExpr env e1    `thenM` \ new_e1 ->
466     zonkLExpr env op    `thenM` \ new_op ->
467     zonkLExpr env e2    `thenM` \ new_e2 ->
468     returnM (OpApp new_e1 new_op fixity new_e2)
469
470 zonkExpr env (NegApp expr op)
471   = zonkLExpr env expr  `thenM` \ new_expr ->
472     zonkExpr env op     `thenM` \ new_op ->
473     returnM (NegApp new_expr new_op)
474
475 zonkExpr env (HsPar e)    
476   = zonkLExpr env e     `thenM` \new_e ->
477     returnM (HsPar new_e)
478
479 zonkExpr env (SectionL expr op)
480   = zonkLExpr env expr  `thenM` \ new_expr ->
481     zonkLExpr env op            `thenM` \ new_op ->
482     returnM (SectionL new_expr new_op)
483
484 zonkExpr env (SectionR op expr)
485   = zonkLExpr env op            `thenM` \ new_op ->
486     zonkLExpr env expr          `thenM` \ new_expr ->
487     returnM (SectionR new_op new_expr)
488
489 zonkExpr env (ExplicitTuple tup_args boxed)
490   = do { new_tup_args <- mapM zonk_tup_arg tup_args
491        ; return (ExplicitTuple new_tup_args boxed) }
492   where
493     zonk_tup_arg (Present e) = do { e' <- zonkLExpr env e; return (Present e') }
494     zonk_tup_arg (Missing t) = do { t' <- zonkTcTypeToType env t; return (Missing t') }
495
496 zonkExpr env (HsCase expr ms)
497   = zonkLExpr env expr          `thenM` \ new_expr ->
498     zonkMatchGroup env ms       `thenM` \ new_ms ->
499     returnM (HsCase new_expr new_ms)
500
501 zonkExpr env (HsIf e1 e2 e3)
502   = zonkLExpr env e1    `thenM` \ new_e1 ->
503     zonkLExpr env e2    `thenM` \ new_e2 ->
504     zonkLExpr env e3    `thenM` \ new_e3 ->
505     returnM (HsIf new_e1 new_e2 new_e3)
506
507 zonkExpr env (HsLet binds expr)
508   = zonkLocalBinds env binds    `thenM` \ (new_env, new_binds) ->
509     zonkLExpr new_env expr      `thenM` \ new_expr ->
510     returnM (HsLet new_binds new_expr)
511
512 zonkExpr env (HsDo do_or_lc stmts body ty)
513   = zonkStmts env stmts         `thenM` \ (new_env, new_stmts) ->
514     zonkLExpr new_env body      `thenM` \ new_body ->
515     zonkTcTypeToType env ty     `thenM` \ new_ty   ->
516     zonkDo env do_or_lc         `thenM` \ new_do_or_lc ->
517     returnM (HsDo new_do_or_lc new_stmts new_body new_ty)
518
519 zonkExpr env (ExplicitList ty exprs)
520   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
521     zonkLExprs env exprs        `thenM` \ new_exprs ->
522     returnM (ExplicitList new_ty new_exprs)
523
524 zonkExpr env (ExplicitPArr ty exprs)
525   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
526     zonkLExprs env exprs        `thenM` \ new_exprs ->
527     returnM (ExplicitPArr new_ty new_exprs)
528
529 zonkExpr env (RecordCon data_con con_expr rbinds)
530   = do  { new_con_expr <- zonkExpr env con_expr
531         ; new_rbinds   <- zonkRecFields env rbinds
532         ; return (RecordCon data_con new_con_expr new_rbinds) }
533
534 zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
535   = do  { new_expr    <- zonkLExpr env expr
536         ; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
537         ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
538         ; new_rbinds  <- zonkRecFields env rbinds
539         ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) }
540
541 zonkExpr env (ExprWithTySigOut e ty) 
542   = do { e' <- zonkLExpr env e
543        ; return (ExprWithTySigOut e' ty) }
544
545 zonkExpr _ (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
546
547 zonkExpr env (ArithSeq expr info)
548   = zonkExpr env expr           `thenM` \ new_expr ->
549     zonkArithSeq env info       `thenM` \ new_info ->
550     returnM (ArithSeq new_expr new_info)
551
552 zonkExpr env (PArrSeq expr info)
553   = zonkExpr env expr           `thenM` \ new_expr ->
554     zonkArithSeq env info       `thenM` \ new_info ->
555     returnM (PArrSeq new_expr new_info)
556
557 zonkExpr env (HsSCC lbl expr)
558   = zonkLExpr env expr  `thenM` \ new_expr ->
559     returnM (HsSCC lbl new_expr)
560
561 zonkExpr env (HsTickPragma info expr)
562   = zonkLExpr env expr  `thenM` \ new_expr ->
563     returnM (HsTickPragma info new_expr)
564
565 -- hdaume: core annotations
566 zonkExpr env (HsCoreAnn lbl expr)
567   = zonkLExpr env expr   `thenM` \ new_expr ->
568     returnM (HsCoreAnn lbl new_expr)
569
570 -- arrow notation extensions
571 zonkExpr env (HsProc pat body)
572   = do  { (env1, new_pat) <- zonkPat env pat
573         ; new_body <- zonkCmdTop env1 body
574         ; return (HsProc new_pat new_body) }
575
576 zonkExpr env (HsArrApp e1 e2 ty ho rl)
577   = zonkLExpr env e1                    `thenM` \ new_e1 ->
578     zonkLExpr env e2                    `thenM` \ new_e2 ->
579     zonkTcTypeToType env ty             `thenM` \ new_ty ->
580     returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
581
582 zonkExpr env (HsArrForm op fixity args)
583   = zonkLExpr env op                    `thenM` \ new_op ->
584     mappM (zonkCmdTop env) args         `thenM` \ new_args ->
585     returnM (HsArrForm new_op fixity new_args)
586
587 zonkExpr env (HsWrap co_fn expr)
588   = zonkCoFn env co_fn  `thenM` \ (env1, new_co_fn) ->
589     zonkExpr env1 expr  `thenM` \ new_expr ->
590     return (HsWrap new_co_fn new_expr)
591
592 zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
593
594 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
595 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
596
597 zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
598 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
599   = zonkLExpr env cmd                   `thenM` \ new_cmd ->
600     zonkTcTypeToTypes env stack_tys     `thenM` \ new_stack_tys ->
601     zonkTcTypeToType env ty             `thenM` \ new_ty ->
602     mapSndM (zonkExpr env) ids          `thenM` \ new_ids ->
603     returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
604
605 -------------------------------------------------------------------------
606 zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
607 zonkCoFn env WpHole   = return (env, WpHole)
608 zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
609                                     ; (env2, c2') <- zonkCoFn env1 c2
610                                     ; return (env2, WpCompose c1' c2') }
611 zonkCoFn env (WpCast co)    = do { co' <- zonkTcTypeToType env co
612                                  ; return (env, WpCast co') }
613 zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
614                                  ; return (env', WpEvLam ev') }
615 zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg 
616                                  ; return (env, WpEvApp arg') }
617 zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
618                               return (env, WpTyLam tv) 
619 zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToType env ty
620                                  ; return (env, WpTyApp ty') }
621 zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs
622                                  ; return (env1, WpLet bs') }
623
624 -------------------------------------------------------------------------
625 zonkDo :: ZonkEnv -> HsStmtContext Name -> TcM (HsStmtContext Name)
626 -- Only used for 'do', so the only Ids are in a MDoExpr table
627 zonkDo env (MDoExpr tbl) = do { tbl' <- mapSndM (zonkExpr env) tbl
628                               ; return (MDoExpr tbl') }
629 zonkDo _   do_or_lc      = return do_or_lc
630
631 -------------------------------------------------------------------------
632 zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
633 zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
634   = do  { ty' <- zonkTcTypeToType env ty
635         ; e' <- zonkExpr env e
636         ; return (lit { ol_witness = e', ol_type = ty' }) }
637
638 -------------------------------------------------------------------------
639 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
640
641 zonkArithSeq env (From e)
642   = zonkLExpr env e             `thenM` \ new_e ->
643     returnM (From new_e)
644
645 zonkArithSeq env (FromThen e1 e2)
646   = zonkLExpr env e1    `thenM` \ new_e1 ->
647     zonkLExpr env e2    `thenM` \ new_e2 ->
648     returnM (FromThen new_e1 new_e2)
649
650 zonkArithSeq env (FromTo e1 e2)
651   = zonkLExpr env e1    `thenM` \ new_e1 ->
652     zonkLExpr env e2    `thenM` \ new_e2 ->
653     returnM (FromTo new_e1 new_e2)
654
655 zonkArithSeq env (FromThenTo e1 e2 e3)
656   = zonkLExpr env e1    `thenM` \ new_e1 ->
657     zonkLExpr env e2    `thenM` \ new_e2 ->
658     zonkLExpr env e3    `thenM` \ new_e3 ->
659     returnM (FromThenTo new_e1 new_e2 new_e3)
660
661
662 -------------------------------------------------------------------------
663 zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
664 zonkStmts env []     = return (env, [])
665 zonkStmts env (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env) s
666                           ; (env2, ss') <- zonkStmts env1 ss
667                           ; return (env2, s' : ss') }
668
669 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
670 zonkStmt env (ParStmt stmts_w_bndrs)
671   = mappM zonk_branch stmts_w_bndrs     `thenM` \ new_stmts_w_bndrs ->
672     let 
673         new_binders = concat (map snd new_stmts_w_bndrs)
674         env1 = extendZonkEnv env new_binders
675     in
676     return (env1, ParStmt new_stmts_w_bndrs)
677   where
678     zonk_branch (stmts, bndrs) = zonkStmts env stmts    `thenM` \ (env1, new_stmts) ->
679                                  returnM (new_stmts, zonkIdOccs env1 bndrs)
680
681 zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
682                       , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id
683                       , recS_rec_rets = rets, recS_dicts = binds })
684   = do { new_rvs <- zonkIdBndrs env rvs
685        ; new_lvs <- zonkIdBndrs env lvs
686        ; new_ret_id  <- zonkExpr env ret_id
687        ; new_mfix_id <- zonkExpr env mfix_id
688        ; new_bind_id <- zonkExpr env bind_id
689        ; let env1 = extendZonkEnv env new_rvs
690        ; (env2, new_segStmts) <- zonkStmts env1 segStmts
691         -- Zonk the ret-expressions in an envt that 
692         -- has the polymorphic bindings in the envt
693        ; new_rets <- mapM (zonkExpr env2) rets
694        ; let env3 = extendZonkEnv env new_lvs   -- Only the lvs are needed
695        ; (env4, new_binds) <- zonkTcEvBinds env3 binds
696        ; return (env4,
697                  RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
698                          , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
699                          , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
700                          , recS_rec_rets = new_rets, recS_dicts = new_binds }) }
701
702 zonkStmt env (ExprStmt expr then_op ty)
703   = zonkLExpr env expr          `thenM` \ new_expr ->
704     zonkExpr env then_op        `thenM` \ new_then ->
705     zonkTcTypeToType env ty     `thenM` \ new_ty ->
706     returnM (env, ExprStmt new_expr new_then new_ty)
707
708 zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr)
709   = do { (env', stmts') <- zonkStmts env stmts 
710     ; let binders' = zonkIdOccs env' binders
711     ; usingExpr' <- zonkLExpr env' usingExpr
712     ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
713     ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr') }
714     
715 zonkStmt env (GroupStmt stmts binderMap by using)
716   = do { (env', stmts') <- zonkStmts env stmts 
717     ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
718     ; by' <- fmapMaybeM (zonkLExpr env') by
719     ; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using
720     ; let env'' = extendZonkEnv env' (map snd binderMap')
721     ; return (env'', GroupStmt stmts' binderMap' by' using') }
722   where
723     zonkBinderMapEntry env (oldBinder, newBinder) = do 
724         let oldBinder' = zonkIdOcc env oldBinder
725         newBinder' <- zonkIdBndr env newBinder
726         return (oldBinder', newBinder') 
727
728 zonkStmt env (LetStmt binds)
729   = zonkLocalBinds env binds    `thenM` \ (env1, new_binds) ->
730     returnM (env1, LetStmt new_binds)
731
732 zonkStmt env (BindStmt pat expr bind_op fail_op)
733   = do  { new_expr <- zonkLExpr env expr
734         ; (env1, new_pat) <- zonkPat env pat
735         ; new_bind <- zonkExpr env bind_op
736         ; new_fail <- zonkExpr env fail_op
737         ; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
738
739 zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id))
740 zonkMaybeLExpr _   Nothing  = return Nothing
741 zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just)
742
743
744 -------------------------------------------------------------------------
745 zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
746 zonkRecFields env (HsRecFields flds dd)
747   = do  { flds' <- mappM zonk_rbind flds
748         ; return (HsRecFields flds' dd) }
749   where
750     zonk_rbind fld
751       = do { new_id   <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld)
752            ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
753            ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) }
754
755 -------------------------------------------------------------------------
756 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
757 mapIPNameTc f (IPName n) = f n  `thenM` \ r -> returnM (IPName r)
758 \end{code}
759
760
761 %************************************************************************
762 %*                                                                      *
763 \subsection[BackSubst-Pats]{Patterns}
764 %*                                                                      *
765 %************************************************************************
766
767 \begin{code}
768 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
769 -- Extend the environment as we go, because it's possible for one
770 -- pattern to bind something that is used in another (inside or
771 -- to the right)
772 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
773
774 zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id)
775 zonk_pat env (ParPat p)
776   = do  { (env', p') <- zonkPat env p
777         ; return (env', ParPat p') }
778
779 zonk_pat env (WildPat ty)
780   = do  { ty' <- zonkTcTypeToType env ty
781         ; return (env, WildPat ty') }
782
783 zonk_pat env (VarPat v)
784   = do  { v' <- zonkIdBndr env v
785         ; return (extendZonkEnv1 env v', VarPat v') }
786
787 zonk_pat env (VarPatOut v binds)
788   = do  { v' <- zonkIdBndr env v
789         ; (env', binds') <- zonkTcEvBinds (extendZonkEnv1 env v') binds
790         ; returnM (env', VarPatOut v' binds') }
791
792 zonk_pat env (LazyPat pat)
793   = do  { (env', pat') <- zonkPat env pat
794         ; return (env',  LazyPat pat') }
795
796 zonk_pat env (BangPat pat)
797   = do  { (env', pat') <- zonkPat env pat
798         ; return (env',  BangPat pat') }
799
800 zonk_pat env (AsPat (L loc v) pat)
801   = do  { v' <- zonkIdBndr env v
802         ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
803         ; return (env', AsPat (L loc v') pat') }
804
805 zonk_pat env (ViewPat expr pat ty)
806   = do  { expr' <- zonkLExpr env expr
807         ; (env', pat') <- zonkPat env pat
808         ; ty' <- zonkTcTypeToType env ty
809         ; return (env', ViewPat expr' pat' ty') }
810
811 zonk_pat env (ListPat pats ty)
812   = do  { ty' <- zonkTcTypeToType env ty
813         ; (env', pats') <- zonkPats env pats
814         ; return (env', ListPat pats' ty') }
815
816 zonk_pat env (PArrPat pats ty)
817   = do  { ty' <- zonkTcTypeToType env ty
818         ; (env', pats') <- zonkPats env pats
819         ; return (env', PArrPat pats' ty') }
820
821 zonk_pat env (TuplePat pats boxed ty)
822   = do  { ty' <- zonkTcTypeToType env ty
823         ; (env', pats') <- zonkPats env pats
824         ; return (env', TuplePat pats' boxed ty') }
825
826 zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = evs, pat_binds = binds, pat_args = args })
827   = ASSERT( all isImmutableTyVar (pat_tvs p) ) 
828     do  { new_ty <- zonkTcTypeToType env ty
829         ; (env1, new_evs) <- zonkEvBndrsX env evs
830         ; (env2, new_binds) <- zonkTcEvBinds env1 binds
831         ; (env', new_args) <- zonkConStuff env2 args
832         ; returnM (env', p { pat_ty = new_ty, pat_dicts = new_evs, 
833                              pat_binds = new_binds, pat_args = new_args }) }
834
835 zonk_pat env (LitPat lit) = return (env, LitPat lit)
836
837 zonk_pat env (SigPatOut pat ty)
838   = do  { ty' <- zonkTcTypeToType env ty
839         ; (env', pat') <- zonkPat env pat
840         ; return (env', SigPatOut pat' ty') }
841
842 zonk_pat env (NPat lit mb_neg eq_expr)
843   = do  { lit' <- zonkOverLit env lit
844         ; mb_neg' <- case mb_neg of
845                         Nothing  -> return Nothing
846                         Just neg -> do { neg' <- zonkExpr env neg
847                                        ; return (Just neg') }
848         ; eq_expr' <- zonkExpr env eq_expr
849         ; return (env, NPat lit' mb_neg' eq_expr') }
850
851 zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
852   = do  { n' <- zonkIdBndr env n
853         ; lit' <- zonkOverLit env lit
854         ; e1' <- zonkExpr env e1
855         ; e2' <- zonkExpr env e2
856         ; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
857
858 zonk_pat env (CoPat co_fn pat ty) 
859   = do { (env', co_fn') <- zonkCoFn env co_fn
860        ; (env'', pat') <- zonkPat env' (noLoc pat)
861        ; ty' <- zonkTcTypeToType env'' ty
862        ; return (env'', CoPat co_fn' (unLoc pat') ty') }
863
864 zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
865
866 ---------------------------
867 zonkConStuff :: ZonkEnv
868              -> HsConDetails (OutPat TcId) (HsRecFields id (OutPat TcId))
869              -> TcM (ZonkEnv,
870                      HsConDetails (OutPat Id) (HsRecFields id (OutPat Id)))
871 zonkConStuff env (PrefixCon pats)
872   = do  { (env', pats') <- zonkPats env pats
873         ; return (env', PrefixCon pats') }
874
875 zonkConStuff env (InfixCon p1 p2)
876   = do  { (env1, p1') <- zonkPat env  p1
877         ; (env', p2') <- zonkPat env1 p2
878         ; return (env', InfixCon p1' p2') }
879
880 zonkConStuff env (RecCon (HsRecFields rpats dd))
881   = do  { (env', pats') <- zonkPats env (map hsRecFieldArg rpats)
882         ; let rpats' = zipWith (\rp p' -> rp { hsRecFieldArg = p' }) rpats pats'
883         ; returnM (env', RecCon (HsRecFields rpats' dd)) }
884         -- Field selectors have declared types; hence no zonking
885
886 ---------------------------
887 zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id])
888 zonkPats env []         = return (env, [])
889 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
890                      ; (env', pats') <- zonkPats env1 pats
891                      ; return (env', pat':pats') }
892 \end{code}
893
894 %************************************************************************
895 %*                                                                      *
896 \subsection[BackSubst-Foreign]{Foreign exports}
897 %*                                                                      *
898 %************************************************************************
899
900
901 \begin{code}
902 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
903 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
904
905 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
906 zonkForeignExport env (ForeignExport i _hs_ty spec) =
907    returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec)
908 zonkForeignExport _ for_imp 
909   = returnM for_imp     -- Foreign imports don't need zonking
910 \end{code}
911
912 \begin{code}
913 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
914 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
915
916 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
917 zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
918   = do { (env_rhs, new_bndrs) <- mapAccumLM zonk_bndr env vars
919
920        ; unbound_tv_set <- newMutVar emptyVarSet
921        ; let env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
922         -- We need to gather the type variables mentioned on the LHS so we can 
923         -- quantify over them.  Example:
924         --   data T a = C
925         -- 
926         --   foo :: T a -> Int
927         --   foo C = 1
928         --
929         --   {-# RULES "myrule"  foo C = 1 #-}
930         -- 
931         -- After type checking the LHS becomes (foo a (C a))
932         -- and we do not want to zap the unbound tyvar 'a' to (), because
933         -- that limits the applicability of the rule.  Instead, we
934         -- want to quantify over it!  
935         --
936         -- It's easiest to find the free tyvars here. Attempts to do so earlier
937         -- are tiresome, because (a) the data type is big and (b) finding the 
938         -- free type vars of an expression is necessarily monadic operation.
939         --      (consider /\a -> f @ b, where b is side-effected to a)
940
941        ; new_lhs <- zonkLExpr env_lhs lhs
942        ; new_rhs <- zonkLExpr env_rhs rhs
943
944        ; unbound_tvs <- readMutVar unbound_tv_set
945        ; let final_bndrs :: [RuleBndr Var]
946              final_bndrs = map (RuleBndr . noLoc) (varSetElems unbound_tvs) ++ new_bndrs
947
948        ; return (HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs) }
949   where
950    zonk_bndr env (RuleBndr (L loc v)) 
951       = do { (env', v') <- zonk_it env v; return (env', RuleBndr (L loc v')) }
952    zonk_bndr _ (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig"
953
954    zonk_it env v
955      | isId v     = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') }
956      | isCoVar v  = do { v' <- zonkEvBndr env v; return (extendZonkEnv1 env v', v') }
957      | otherwise  = ASSERT( isImmutableTyVar v) return (env, v)
958 \end{code}
959
960
961 %************************************************************************
962 %*                                                                      *
963               Constraints and evidence
964 %*                                                                      *
965 %************************************************************************
966
967 \begin{code}
968 zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
969 zonkEvTerm env (EvId v)           = ASSERT2( isId v, ppr v ) 
970                                     return (EvId (zonkIdOcc env v))
971 zonkEvTerm env (EvCoercion co)    = do { co' <- zonkTcTypeToType env co
972                                        ; return (EvCoercion co') }
973 zonkEvTerm env (EvCast v co)      = ASSERT( isId v) 
974                                     do { co' <- zonkTcTypeToType env co
975                                        ; return (EvCast (zonkIdOcc env v) co') }
976 zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n)
977 zonkEvTerm env (EvDFunApp df tys tms) 
978   = do { tys' <- zonkTcTypeToTypes env tys
979        ; let tms' = map (zonkEvVarOcc env) tms
980        ; return (EvDFunApp (zonkIdOcc env df) tys' tms') }
981
982 zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
983 zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var
984                                        ; return (env', EvBinds bs') }
985 zonkTcEvBinds env (EvBinds bs)    = do { (env', bs') <- zonkEvBinds env bs
986                                        ; return (env', EvBinds bs') }
987
988 zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
989 zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref
990                                            ; zonkEvBinds env (evBindMapBinds bs) }
991
992 zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
993 zonkEvBinds env binds
994   = fixM (\ ~( _, new_binds) -> do
995          { let env1 = extendZonkEnv env (collect_ev_bndrs new_binds)
996          ; binds' <- mapBagM (zonkEvBind env1) binds
997          ; return (env1, binds') })
998   where
999     collect_ev_bndrs :: Bag EvBind -> [EvVar]
1000     collect_ev_bndrs = foldrBag add [] 
1001     add (EvBind var _) vars = var : vars
1002
1003 zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
1004 zonkEvBind env (EvBind var term)
1005   = do { var' <- zonkEvBndr env var
1006        ; term' <- zonkEvTerm env term
1007        ; return (EvBind var' term') }
1008 \end{code}
1009
1010 %************************************************************************
1011 %*                                                                      *
1012 \subsection[BackSubst-Foreign]{Foreign exports}
1013 %*                                                                      *
1014 %************************************************************************
1015
1016 \begin{code}
1017 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
1018 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
1019
1020 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
1021 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
1022
1023 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
1024 -- This variant collects unbound type variables in a mutable variable
1025 zonkTypeCollecting unbound_tv_set
1026   = zonkType (mkZonkTcTyVar zonk_unbound_tyvar)
1027   where
1028     zonk_unbound_tyvar tv 
1029         = do { tv' <- zonkQuantifiedTyVar tv
1030              ; tv_set <- readMutVar unbound_tv_set
1031              ; writeMutVar unbound_tv_set (extendVarSet tv_set tv')
1032              ; return (mkTyVarTy tv') }
1033
1034 zonkTypeZapping :: TcType -> TcM Type
1035 -- This variant is used for everything except the LHS of rules
1036 -- It zaps unbound type variables to (), or some other arbitrary type
1037 zonkTypeZapping ty 
1038   = zonkType (mkZonkTcTyVar zonk_unbound_tyvar) ty 
1039   where
1040         -- Zonk a mutable but unbound type variable to an arbitrary type
1041         -- We know it's unbound even though we don't carry an environment,
1042         -- because at the binding site for a type variable we bind the
1043         -- mutable tyvar to a fresh immutable one.  So the mutable store
1044         -- plays the role of an environment.  If we come across a mutable
1045         -- type variable that isn't so bound, it must be completely free.
1046     zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv)
1047                                ; writeMetaTyVar tv ty
1048                                ; return ty }
1049 \end{code}