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