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