Hurrah! This major commit adds support for scoped kind variables,
[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         emptyZonkEnv, mkTyVarZonkEnv, zonkTcTypeToType, zonkTcTypeToTypes
32   ) where
33
34 #include "HsVersions.h"
35
36 import HsSyn
37 import Id
38 import TcRnMonad
39 import PrelNames
40 import TcType
41 import TcMType
42 import TcEvidence
43 import TysPrim
44 import TysWiredIn
45 import Type
46 import DataCon
47 import Name
48 import NameSet
49 import Var
50 import VarSet
51 import VarEnv
52 import DynFlags
53 import Literal
54 import BasicTypes
55 import Maybes
56 import SrcLoc
57 import Bag
58 import FastString
59 import Outputable
60 -- import Data.Traversable( traverse )
61 \end{code}
62
63 \begin{code}
64 -- XXX
65 thenM :: Monad a => a b -> (b -> a c) -> a c
66 thenM = (>>=)
67
68 returnM :: Monad m => a -> m a
69 returnM = return
70
71 mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
72 mappM = mapM
73 \end{code}
74
75
76 %************************************************************************
77 %*                                                                      *
78 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
79 %*                                                                      *
80 %************************************************************************
81
82 Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
83 then something is wrong.
84 \begin{code}
85 hsLPatType :: OutPat Id -> Type
86 hsLPatType (L _ pat) = hsPatType pat
87
88 hsPatType :: Pat Id -> Type
89 hsPatType (ParPat pat)                = hsLPatType pat
90 hsPatType (WildPat ty)                = ty
91 hsPatType (VarPat var)                = idType var
92 hsPatType (BangPat pat)               = hsLPatType pat
93 hsPatType (LazyPat pat)               = hsLPatType pat
94 hsPatType (LitPat lit)                = hsLitType lit
95 hsPatType (AsPat var _)               = idType (unLoc var)
96 hsPatType (ViewPat _ _ ty)            = ty
97 hsPatType (ListPat _ ty)              = mkListTy ty
98 hsPatType (PArrPat _ ty)              = mkPArrTy ty
99 hsPatType (TuplePat _ _ ty)           = ty
100 hsPatType (ConPatOut { pat_ty = ty }) = ty
101 hsPatType (SigPatOut _ ty)            = ty
102 hsPatType (NPat lit _ _)              = overLitType lit
103 hsPatType (NPlusKPat id _ _ _)        = idType (unLoc id)
104 hsPatType (CoPat _ _ ty)              = ty
105 hsPatType p                           = pprPanic "hsPatType" (ppr p)
106
107 hsLitType :: HsLit -> TcType
108 hsLitType (HsChar _)       = charTy
109 hsLitType (HsCharPrim _)   = charPrimTy
110 hsLitType (HsString _)     = stringTy
111 hsLitType (HsStringPrim _) = addrPrimTy
112 hsLitType (HsInt _)        = intTy
113 hsLitType (HsIntPrim _)    = intPrimTy
114 hsLitType (HsWordPrim _)   = wordPrimTy
115 hsLitType (HsInt64Prim _)  = int64PrimTy
116 hsLitType (HsWord64Prim _) = word64PrimTy
117 hsLitType (HsInteger _ ty) = ty
118 hsLitType (HsRat _ ty)     = ty
119 hsLitType (HsFloatPrim _)  = floatPrimTy
120 hsLitType (HsDoublePrim _) = doublePrimTy
121 \end{code}
122
123 Overloaded literals. Here mainly becuase it uses isIntTy etc
124
125 \begin{code}
126 shortCutLit :: OverLitVal -> TcType -> Maybe (HsExpr TcId)
127 shortCutLit (HsIntegral i) ty
128   | isIntTy ty && inIntRange i   = Just (HsLit (HsInt i))
129   | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
130   | isIntegerTy ty               = Just (HsLit (HsInteger i ty))
131   | otherwise                    = shortCutLit (HsFractional (integralFractionalLit i)) ty
132         -- The 'otherwise' case is important
133         -- Consider (3 :: Float).  Syntactically it looks like an IntLit,
134         -- so we'll call shortCutIntLit, but of course it's a float
135         -- This can make a big difference for programs with a lot of
136         -- literals, compiled without -O
137
138 shortCutLit (HsFractional f) ty
139   | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim f))
140   | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
141   | otherwise     = Nothing
142
143 shortCutLit (HsIsString s) ty
144   | isStringTy ty = Just (HsLit (HsString s))
145   | otherwise     = Nothing
146
147 mkLit :: DataCon -> HsLit -> HsExpr Id
148 mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
149
150 ------------------------------
151 hsOverLitName :: OverLitVal -> Name
152 -- Get the canonical 'fromX' name for a particular OverLitVal
153 hsOverLitName (HsIntegral {})   = fromIntegerName
154 hsOverLitName (HsFractional {}) = fromRationalName
155 hsOverLitName (HsIsString {})   = fromStringName
156 \end{code}
157
158 %************************************************************************
159 %*                                                                      *
160 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
161 %*                                                                      *
162 %************************************************************************
163
164 \begin{code}
165 -- zonkId is used *during* typechecking just to zonk the Id's type
166 zonkId :: TcId -> TcM TcId
167 zonkId id
168   = zonkTcType (idType id) `thenM` \ ty' ->
169     returnM (Id.setIdType id ty')
170 \end{code}
171
172 The rest of the zonking is done *after* typechecking.
173 The main zonking pass runs over the bindings
174
175  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
176  b) convert unbound TcTyVar to Void
177  c) convert each TcId to an Id by zonking its type
178
179 The type variables are converted by binding mutable tyvars to immutable ones
180 and then zonking as normal.
181
182 The Ids are converted by binding them in the normal Tc envt; that
183 way we maintain sharing; eg an Id is zonked at its binding site and they
184 all occurrences of that Id point to the common zonked copy
185
186 It's all pretty boring stuff, because HsSyn is such a large type, and 
187 the environment manipulation is tiresome.
188
189 \begin{code}
190 type UnboundTyVarZonker = TcTyVar-> TcM Type 
191         -- How to zonk an unbound type variable
192         -- Note [Zonking the LHS of a RULE]
193
194 data ZonkEnv 
195   = ZonkEnv 
196       UnboundTyVarZonker
197       (TyVarEnv TyVar)          -- 
198       (IdEnv Var)               -- What variables are in scope
199         -- Maps an Id or EvVar to its zonked version; both have the same Name
200         -- Note that all evidence (coercion variables as well as dictionaries)
201         --      are kept in the ZonkEnv
202         -- Only *type* abstraction is done by side effect
203         -- Is only consulted lazily; hence knot-tying
204
205 instance Outputable ZonkEnv where 
206   ppr (ZonkEnv _ _ty_env var_env) = vcat (map ppr (varEnvElts var_env))
207
208
209 emptyZonkEnv :: ZonkEnv
210 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv emptyVarEnv
211
212 extendIdZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
213 extendIdZonkEnv (ZonkEnv zonk_ty ty_env id_env) ids 
214   = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
215
216 extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
217 extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id 
218   = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
219
220 extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
221 extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) ty
222   = ZonkEnv zonk_ty (extendVarEnv ty_env ty ty) id_env
223
224 mkTyVarZonkEnv :: [TyVar] -> ZonkEnv
225 mkTyVarZonkEnv tvs = ZonkEnv zonkTypeZapping (mkVarEnv [(tv,tv) | tv <- tvs]) emptyVarEnv
226
227 setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
228 setZonkType (ZonkEnv _ ty_env id_env) zonk_ty = ZonkEnv zonk_ty ty_env id_env
229
230 zonkEnvIds :: ZonkEnv -> [Id]
231 zonkEnvIds (ZonkEnv _ _ id_env) = varEnvElts id_env
232
233 zonkIdOcc :: ZonkEnv -> TcId -> Id
234 -- Ids defined in this module should be in the envt; 
235 -- ignore others.  (Actually, data constructors are also
236 -- not LocalVars, even when locally defined, but that is fine.)
237 -- (Also foreign-imported things aren't currently in the ZonkEnv;
238 --  that's ok because they don't need zonking.)
239 --
240 -- Actually, Template Haskell works in 'chunks' of declarations, and
241 -- an earlier chunk won't be in the 'env' that the zonking phase 
242 -- carries around.  Instead it'll be in the tcg_gbl_env, already fully
243 -- zonked.  There's no point in looking it up there (except for error 
244 -- checking), and it's not conveniently to hand; hence the simple
245 -- 'orElse' case in the LocalVar branch.
246 --
247 -- Even without template splices, in module Main, the checking of
248 -- 'main' is done as a separate chunk.
249 zonkIdOcc (ZonkEnv _zonk_ty _ty_env env) id 
250   | isLocalVar id = lookupVarEnv env id `orElse` id
251   | otherwise     = id
252
253 zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
254 zonkIdOccs env ids = map (zonkIdOcc env) ids
255
256 -- zonkIdBndr is used *after* typechecking to get the Id's type
257 -- to its final form.  The TyVarEnv give 
258 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
259 zonkIdBndr env id
260   = zonkTcTypeToType env (idType id)    `thenM` \ ty' ->
261     returnM (Id.setIdType id ty')
262
263 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
264 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
265
266 zonkTopBndrs :: [TcId] -> TcM [Id]
267 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
268
269 zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
270 zonkEvBndrsX = mapAccumLM zonkEvBndrX 
271
272 zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
273 -- Works for dictionaries and coercions
274 zonkEvBndrX env var
275   = do { var' <- zonkEvBndr env var
276        ; return (extendIdZonkEnv1 env var', var') }
277
278 zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
279 -- Works for dictionaries and coercions
280 -- Does not extend the ZonkEnv
281 zonkEvBndr env var 
282   = do { let var_ty = varType var
283        ; ty <- 
284            {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
285            zonkTcTypeToType env var_ty
286        ; return (setVarType var ty) }
287
288 zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar
289 zonkEvVarOcc env v = zonkIdOcc env v
290
291 zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
292 zonkTyBndrsX = mapAccumLM zonkTyBndrX 
293
294 zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar)
295 -- This guarantees to return a TyVar (not a TcTyVar)
296 -- then we add it to the envt, so all occurrences are replaced
297 zonkTyBndrX env tv
298   = do { ki <- zonkTcTypeToType env (tyVarKind tv)
299        ; let tv' = mkTyVar (tyVarName tv) ki
300        ; return (extendTyZonkEnv1 env tv', tv') }
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 $ pprPrefixName (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_later_rets = later_rets, recS_rec_rets = rec_rets
793                       , recS_ret_ty = ret_ty })
794   = do { new_rvs <- zonkIdBndrs env rvs
795        ; new_lvs <- zonkIdBndrs env lvs
796        ; new_ret_ty  <- zonkTcTypeToType env ret_ty
797        ; new_ret_id  <- zonkExpr env ret_id
798        ; new_mfix_id <- zonkExpr env mfix_id
799        ; new_bind_id <- zonkExpr env bind_id
800        ; let env1 = extendIdZonkEnv env new_rvs
801        ; (env2, new_segStmts) <- zonkStmts env1 segStmts
802         -- Zonk the ret-expressions in an envt that 
803         -- has the polymorphic bindings in the envt
804        ; new_later_rets <- mapM (zonkExpr env2) later_rets
805        ; new_rec_rets <- mapM (zonkExpr env2) rec_rets
806        ; return (extendIdZonkEnv env new_lvs,     -- Only the lvs are needed
807                  RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
808                          , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
809                          , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
810                          , recS_later_rets = new_later_rets
811                          , recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) }
812
813 zonkStmt env (ExprStmt expr then_op guard_op ty)
814   = zonkLExpr env expr          `thenM` \ new_expr ->
815     zonkExpr env then_op        `thenM` \ new_then ->
816     zonkExpr env guard_op       `thenM` \ new_guard ->
817     zonkTcTypeToType env ty     `thenM` \ new_ty ->
818     returnM (env, ExprStmt new_expr new_then new_guard new_ty)
819
820 zonkStmt env (LastStmt expr ret_op)
821   = zonkLExpr env expr          `thenM` \ new_expr ->
822     zonkExpr env ret_op         `thenM` \ new_ret ->
823     returnM (env, LastStmt new_expr new_ret)
824
825 zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
826                         , trS_by = by, trS_form = form, trS_using = using
827                         , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op })
828   = do { (env', stmts') <- zonkStmts env stmts 
829     ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
830     ; by'        <- fmapMaybeM (zonkLExpr env') by
831     ; using'     <- zonkLExpr env using
832     ; return_op' <- zonkExpr env' return_op
833     ; bind_op'   <- zonkExpr env' bind_op
834     ; liftM_op'  <- zonkExpr env' liftM_op
835     ; let env'' = extendIdZonkEnv env' (map snd binderMap')
836     ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
837                                , trS_by = by', trS_form = form, trS_using = using'
838                                , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) }
839   where
840     zonkBinderMapEntry env (oldBinder, newBinder) = do 
841         let oldBinder' = zonkIdOcc env oldBinder
842         newBinder' <- zonkIdBndr env newBinder
843         return (oldBinder', newBinder') 
844
845 zonkStmt env (LetStmt binds)
846   = zonkLocalBinds env binds    `thenM` \ (env1, new_binds) ->
847     returnM (env1, LetStmt new_binds)
848
849 zonkStmt env (BindStmt pat expr bind_op fail_op)
850   = do  { new_expr <- zonkLExpr env expr
851         ; (env1, new_pat) <- zonkPat env pat
852         ; new_bind <- zonkExpr env bind_op
853         ; new_fail <- zonkExpr env fail_op
854         ; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
855
856 -------------------------------------------------------------------------
857 zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
858 zonkRecFields env (HsRecFields flds dd)
859   = do  { flds' <- mappM zonk_rbind flds
860         ; return (HsRecFields flds' dd) }
861   where
862     zonk_rbind fld
863       = do { new_id   <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld)
864            ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
865            ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) }
866
867 -------------------------------------------------------------------------
868 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
869 mapIPNameTc f (IPName n) = f n  `thenM` \ r -> returnM (IPName r)
870 \end{code}
871
872
873 %************************************************************************
874 %*                                                                      *
875 \subsection[BackSubst-Pats]{Patterns}
876 %*                                                                      *
877 %************************************************************************
878
879 \begin{code}
880 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
881 -- Extend the environment as we go, because it's possible for one
882 -- pattern to bind something that is used in another (inside or
883 -- to the right)
884 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
885
886 zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id)
887 zonk_pat env (ParPat p)
888   = do  { (env', p') <- zonkPat env p
889         ; return (env', ParPat p') }
890
891 zonk_pat env (WildPat ty)
892   = do  { ty' <- zonkTcTypeToType env ty
893         ; return (env, WildPat ty') }
894
895 zonk_pat env (VarPat v)
896   = do  { v' <- zonkIdBndr env v
897         ; return (extendIdZonkEnv1 env v', VarPat v') }
898
899 zonk_pat env (LazyPat pat)
900   = do  { (env', pat') <- zonkPat env pat
901         ; return (env',  LazyPat pat') }
902
903 zonk_pat env (BangPat pat)
904   = do  { (env', pat') <- zonkPat env pat
905         ; return (env',  BangPat pat') }
906
907 zonk_pat env (AsPat (L loc v) pat)
908   = do  { v' <- zonkIdBndr env v
909         ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat
910         ; return (env', AsPat (L loc v') pat') }
911
912 zonk_pat env (ViewPat expr pat ty)
913   = do  { expr' <- zonkLExpr env expr
914         ; (env', pat') <- zonkPat env pat
915         ; ty' <- zonkTcTypeToType env ty
916         ; return (env', ViewPat expr' pat' ty') }
917
918 zonk_pat env (ListPat pats ty)
919   = do  { ty' <- zonkTcTypeToType env ty
920         ; (env', pats') <- zonkPats env pats
921         ; return (env', ListPat pats' ty') }
922
923 zonk_pat env (PArrPat pats ty)
924   = do  { ty' <- zonkTcTypeToType env ty
925         ; (env', pats') <- zonkPats env pats
926         ; return (env', PArrPat pats' ty') }
927
928 zonk_pat env (TuplePat pats boxed ty)
929   = do  { ty' <- zonkTcTypeToType env ty
930         ; (env', pats') <- zonkPats env pats
931         ; return (env', TuplePat pats' boxed ty') }
932
933 zonk_pat env p@(ConPatOut { pat_ty = ty, pat_tvs = tyvars
934                           , pat_dicts = evs, pat_binds = binds
935                           , pat_args = args })
936   = ASSERT( all isImmutableTyVar tyvars ) 
937     do  { new_ty <- zonkTcTypeToType env ty
938         ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars
939           -- Must zonk the existential variables, because their
940           -- /kind/ need potential zonking.
941           -- cf typecheck/should_compile/tc221.hs
942         ; (env1, new_evs) <- zonkEvBndrsX env0 evs
943         ; (env2, new_binds) <- zonkTcEvBinds env1 binds
944         ; (env', new_args) <- zonkConStuff env2 args
945         ; returnM (env', p { pat_ty = new_ty, 
946                              pat_tvs = new_tyvars,
947                              pat_dicts = new_evs, 
948                              pat_binds = new_binds, 
949                              pat_args = new_args }) }
950
951 zonk_pat env (LitPat lit) = return (env, LitPat lit)
952
953 zonk_pat env (SigPatOut pat ty)
954   = do  { ty' <- zonkTcTypeToType env ty
955         ; (env', pat') <- zonkPat env pat
956         ; return (env', SigPatOut pat' ty') }
957
958 zonk_pat env (NPat lit mb_neg eq_expr)
959   = do  { lit' <- zonkOverLit env lit
960         ; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg
961         ; eq_expr' <- zonkExpr env eq_expr
962         ; return (env, NPat lit' mb_neg' eq_expr') }
963
964 zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
965   = do  { n' <- zonkIdBndr env n
966         ; lit' <- zonkOverLit env lit
967         ; e1' <- zonkExpr env e1
968         ; e2' <- zonkExpr env e2
969         ; return (extendIdZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
970
971 zonk_pat env (CoPat co_fn pat ty) 
972   = do { (env', co_fn') <- zonkCoFn env co_fn
973        ; (env'', pat') <- zonkPat env' (noLoc pat)
974        ; ty' <- zonkTcTypeToType env'' ty
975        ; return (env'', CoPat co_fn' (unLoc pat') ty') }
976
977 zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
978
979 ---------------------------
980 zonkConStuff :: ZonkEnv
981              -> HsConDetails (OutPat TcId) (HsRecFields id (OutPat TcId))
982              -> TcM (ZonkEnv,
983                      HsConDetails (OutPat Id) (HsRecFields id (OutPat Id)))
984 zonkConStuff env (PrefixCon pats)
985   = do  { (env', pats') <- zonkPats env pats
986         ; return (env', PrefixCon pats') }
987
988 zonkConStuff env (InfixCon p1 p2)
989   = do  { (env1, p1') <- zonkPat env  p1
990         ; (env', p2') <- zonkPat env1 p2
991         ; return (env', InfixCon p1' p2') }
992
993 zonkConStuff env (RecCon (HsRecFields rpats dd))
994   = do  { (env', pats') <- zonkPats env (map hsRecFieldArg rpats)
995         ; let rpats' = zipWith (\rp p' -> rp { hsRecFieldArg = p' }) rpats pats'
996         ; returnM (env', RecCon (HsRecFields rpats' dd)) }
997         -- Field selectors have declared types; hence no zonking
998
999 ---------------------------
1000 zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id])
1001 zonkPats env []         = return (env, [])
1002 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
1003                      ; (env', pats') <- zonkPats env1 pats
1004                      ; return (env', pat':pats') }
1005 \end{code}
1006
1007 %************************************************************************
1008 %*                                                                      *
1009 \subsection[BackSubst-Foreign]{Foreign exports}
1010 %*                                                                      *
1011 %************************************************************************
1012
1013
1014 \begin{code}
1015 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
1016 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
1017
1018 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
1019 zonkForeignExport env (ForeignExport i _hs_ty co spec) =
1020    returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined co spec)
1021 zonkForeignExport _ for_imp 
1022   = returnM for_imp     -- Foreign imports don't need zonking
1023 \end{code}
1024
1025 \begin{code}
1026 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
1027 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
1028
1029 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
1030 zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
1031   = do { unbound_tkv_set <- newMutVar emptyVarSet
1032        ; let env_rule = setZonkType env (zonkTvCollecting unbound_tkv_set)
1033               -- See Note [Zonking the LHS of a RULE]
1034
1035        ; (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env_rule vars
1036
1037        ; new_lhs <- zonkLExpr env_inside lhs
1038        ; new_rhs <- zonkLExpr env_inside rhs
1039
1040        ; unbound_tkvs <- readMutVar unbound_tkv_set
1041
1042        ; let final_bndrs :: [RuleBndr Var]
1043              final_bndrs = map (RuleBndr . noLoc)
1044                              (varSetElemsKvsFirst unbound_tkvs)
1045                            ++ new_bndrs
1046
1047        ; return $ 
1048          HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs }
1049   where
1050    zonk_bndr env (RuleBndr (L loc v)) 
1051       = do { (env', v') <- zonk_it env v
1052            ; return (env', RuleBndr (L loc v')) }
1053    zonk_bndr _ (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig"
1054
1055    zonk_it env v
1056      | isId v     = do { v' <- zonkIdBndr env v
1057                        ; return (extendIdZonkEnv1 env v', v') }
1058      | otherwise  = ASSERT( isImmutableTyVar v)
1059                     zonkTyBndrX env v
1060                     -- DV: used to be return (env,v) but that is plain 
1061                     -- wrong because we may need to go inside the kind 
1062                     -- of v and zonk there!
1063 \end{code}
1064
1065 \begin{code}
1066 zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id]
1067 zonkVects env = mappM (wrapLocM (zonkVect env))
1068
1069 zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id)
1070 zonkVect env (HsVect v e)
1071   = do { v' <- wrapLocM (zonkIdBndr env) v
1072        ; e' <- fmapMaybeM (zonkLExpr env) e
1073        ; return $ HsVect v' e'
1074        }
1075 zonkVect env (HsNoVect v)
1076   = do { v' <- wrapLocM (zonkIdBndr env) v
1077        ; return $ HsNoVect v'
1078        }
1079 zonkVect _env (HsVectTypeOut s t rt)
1080   = return $ HsVectTypeOut s t rt
1081 zonkVect _ (HsVectTypeIn _ _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn"
1082 zonkVect _env (HsVectClassOut c)
1083   = return $ HsVectClassOut c
1084 zonkVect _ (HsVectClassIn _) = panic "TcHsSyn.zonkVect: HsVectClassIn"
1085 zonkVect _env (HsVectInstOut i)
1086   = return $ HsVectInstOut i
1087 zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn"
1088 \end{code}
1089
1090 %************************************************************************
1091 %*                                                                      *
1092               Constraints and evidence
1093 %*                                                                      *
1094 %************************************************************************
1095
1096 \begin{code}
1097 zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
1098 zonkEvTerm env (EvId v)           = ASSERT2( isId v, ppr v ) 
1099                                     return (EvId (zonkIdOcc env v))
1100 zonkEvTerm env (EvCoercion co)    = do { co' <- zonkTcLCoToLCo env co
1101                                        ; return (EvCoercion co') }
1102 zonkEvTerm env (EvCast v co)      = ASSERT( isId v) 
1103                                     do { co' <- zonkTcLCoToLCo env co
1104                                        ; return (mkEvCast (zonkIdOcc env v) co') }
1105
1106 zonkEvTerm env (EvKindCast v co) = ASSERT( isId v) 
1107                                     do { co' <- zonkTcLCoToLCo env co
1108                                        ; return (mkEvKindCast (zonkIdOcc env v) co') }
1109
1110 zonkEvTerm env (EvTupleSel v n)   = return (EvTupleSel (zonkIdOcc env v) n)
1111 zonkEvTerm env (EvTupleMk vs)     = return (EvTupleMk (map (zonkIdOcc env) vs))
1112 zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n)
1113 zonkEvTerm env (EvDFunApp df tys tms)
1114   = do { tys' <- zonkTcTypeToTypes env tys
1115        ; let tms' = map (zonkEvVarOcc env) tms
1116        ; return (EvDFunApp (zonkIdOcc env df) tys' tms') }
1117 zonkEvTerm env (EvDelayedError ty msg)
1118   = do { ty' <- zonkTcTypeToType env ty
1119        ; return (EvDelayedError ty' msg) }
1120
1121 zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
1122 zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var
1123                                        ; return (env', EvBinds bs') }
1124 zonkTcEvBinds env (EvBinds bs)    = do { (env', bs') <- zonkEvBinds env bs
1125                                        ; return (env', EvBinds bs') }
1126
1127 zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
1128 zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref
1129                                            ; zonkEvBinds env (evBindMapBinds bs) }
1130
1131 zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
1132 zonkEvBinds env binds
1133   = {-# SCC "zonkEvBinds" #-}
1134     fixM (\ ~( _, new_binds) -> do
1135          { let env1 = extendIdZonkEnv env (collect_ev_bndrs new_binds)
1136          ; binds' <- mapBagM (zonkEvBind env1) binds
1137          ; return (env1, binds') })
1138   where
1139     collect_ev_bndrs :: Bag EvBind -> [EvVar]
1140     collect_ev_bndrs = foldrBag add [] 
1141     add (EvBind var _) vars = var : vars
1142
1143 zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
1144 zonkEvBind env (EvBind var term)
1145   -- This function has some special cases for avoiding re-zonking the
1146   -- same types many types. See Note [Optimized Evidence Binding Zonking]
1147   = case term of 
1148       -- Fast path for reflexivity coercions:
1149       EvCoercion co 
1150         | Just ty <- isTcReflCo_maybe co
1151         ->
1152           do { zty  <- zonkTcTypeToType env ty
1153              ; let var' = setVarType var (mkEqPred zty zty)
1154              ; return (EvBind var' (EvCoercion (mkTcReflCo zty))) }
1155
1156       -- Fast path for variable-variable bindings 
1157       -- NB: could be optimized further! (e.g. SymCo cv)
1158         | Just cv <- getTcCoVar_maybe co 
1159         -> do { let cv'   = zonkIdOcc env cv -- Just lazily look up
1160                     term' = EvCoercion (TcCoVarCo cv')
1161                     var'  = setVarType var (varType cv')
1162               ; return (EvBind var' term') }
1163
1164       -- Ugly safe and slow path
1165       _ -> do { var'  <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var
1166               ; term' <- zonkEvTerm env term 
1167               ; return (EvBind var' term')
1168               }
1169 \end{code}
1170
1171 %************************************************************************
1172 %*                                                                      *
1173                          Zonking types
1174 %*                                                                      *
1175 %************************************************************************
1176
1177 Note [Zonking the LHS of a RULE]
1178 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1179 We need to gather the type variables mentioned on the LHS so we can 
1180 quantify over them.  Example:
1181   data T a = C
1182
1183   foo :: T a -> Int
1184   foo C = 1
1185
1186   {-# RULES "myrule"  foo C = 1 #-}
1187
1188 After type checking the LHS becomes (foo a (C a))
1189 and we do not want to zap the unbound tyvar 'a' to (), because
1190 that limits the applicability of the rule.  Instead, we
1191 want to quantify over it!  
1192
1193 It's easiest to get zonkTvCollecting to gather the free tyvars
1194 here. Attempts to do so earlier are tiresome, because (a) the data
1195 type is big and (b) finding the free type vars of an expression is
1196 necessarily monadic operation. (consider /\a -> f @ b, where b is
1197 side-effected to a)
1198
1199 And that in turn is why ZonkEnv carries the function to use for
1200 type variables!
1201
1202 Note [Zonking mutable unbound type or kind variables]
1203 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1204 In zonkTypeZapping, we zonk mutable but unbound type or kind variables to an
1205 arbitrary type. We know if they are unbound even though we don't carry an
1206 environment, because at the binding site for a variable we bind the mutable
1207 var to a fresh immutable one.  So the mutable store plays the role of an
1208 environment.  If we come across a mutable variable that isn't so bound, it
1209 must be completely free. We zonk the expected kind to make sure we don't get
1210 some unbound meta variable as the kind.
1211
1212 Note that since we have kind polymorphism, zonk_unbound_tyvar will handle both
1213 type and kind variables. Consider the following datatype:
1214
1215   data Phantom a = Phantom Int
1216
1217 The type of Phantom is (forall (k : BOX). forall (a : k). Int). Both `a` and
1218 `k` are unbound variables. We want to zonk this to
1219 (forall (k : AnyK). forall (a : Any AnyK). Int). For that we have to check if
1220 we have a type or a kind variable; for kind variables we just return AnyK (and
1221 not the ill-kinded Any BOX).
1222
1223 Note [Optimized Evidence Binding Zonking]
1224 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1225
1226 When optimising evidence binds we may come accross situations where 
1227 a coercion is just reflexivity: 
1228       cv = ReflCo ty
1229 In such a case it is a waste of time to zonk both ty and the type 
1230 of the coercion, especially if the types involved are huge. For this
1231 reason this case is optimized to only zonk 'ty' and set the type of 
1232 the variable to be that zonked type.
1233
1234 Another case that hurts a lot are simple coercion bindings of the form:
1235       cv1 = cv2
1236       cv3 = cv1
1237       cv4 = cv2 
1238 etc. In all such cases it is very easy to just get the zonked type of 
1239 cv2 and use it to set the type of the LHS coercion variable without zonking
1240 twice. Though this case is funny, it can happen due the way that evidence 
1241 from spontaneously solved goals is now used.
1242 See Note [Optimizing Spontaneously Solved Goals] about this.
1243
1244 NB: That these optimizations are independently useful, regardless of the 
1245 constraint solver strategy.
1246
1247 DV, TODO: followup on this note mentioning new examples I will add to perf/
1248
1249
1250 \begin{code}
1251 mkZonkTcTyVar :: (TcTyVar -> TcM Type)  -- What to do for an *mutable Flexi* var
1252               -> (TcTyVar -> Type)      -- What to do for an immutable var
1253               -> TcTyVar -> TcM TcType
1254 mkZonkTcTyVar unbound_mvar_fn unbound_ivar_fn
1255   = zonk_tv
1256   where
1257     zonk_tv tv 
1258      = ASSERT( isTcTyVar tv )
1259        case tcTyVarDetails tv of
1260          SkolemTv {}    -> return (unbound_ivar_fn tv)
1261          RuntimeUnk {}  -> return (unbound_ivar_fn tv)
1262          FlatSkol ty    -> zonkType zonk_tv ty
1263          MetaTv _ ref   -> do { cts <- readMutVar ref
1264                               ; case cts of    
1265                                    Flexi -> do { kind <- {-# SCC "zonkKind1" #-}
1266                                                          zonkType zonk_tv (tyVarKind tv)
1267                                                ; unbound_mvar_fn (setTyVarKind tv kind) }
1268                                    Indirect ty -> do { zty <- zonkType zonk_tv ty 
1269                                                      -- Small optimisation: shortern-out indirect steps
1270                                                      -- so that the old type may be more easily collected.
1271                                                      ; writeMutVar ref (Indirect zty)
1272                                                      ; return zty } }
1273
1274 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
1275 zonkTcTypeToType (ZonkEnv zonk_unbound_tyvar tv_env _id_env)
1276   = zonkType (mkZonkTcTyVar zonk_unbound_tyvar zonk_bound_tyvar)
1277   where
1278     zonk_bound_tyvar tv    -- Look up in the env just as we do for Ids
1279       = case lookupVarEnv tv_env tv of
1280           Nothing  -> mkTyVarTy tv
1281           Just tv' -> mkTyVarTy tv'
1282
1283 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
1284 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
1285
1286 zonkTvCollecting :: TcRef TyVarSet -> UnboundTyVarZonker
1287 -- This variant collects unbound type variables in a mutable variable
1288 -- Works on both types and kinds
1289 zonkTvCollecting unbound_tv_set tv
1290   = do { poly_kinds <- xoptM Opt_PolyKinds
1291        ; if isKindVar tv && not poly_kinds then defaultKindVarToStar tv
1292          else do
1293        { tv' <- zonkQuantifiedTyVar tv
1294        ; tv_set <- readMutVar unbound_tv_set
1295        ; writeMutVar unbound_tv_set (extendVarSet tv_set tv')
1296        ; return (mkTyVarTy tv') } }
1297
1298 zonkTypeZapping :: UnboundTyVarZonker
1299 -- This variant is used for everything except the LHS of rules
1300 -- It zaps unbound type variables to (), or some other arbitrary type
1301 -- Works on both types and kinds
1302 zonkTypeZapping tv
1303   = do { let ty = if isKindVar tv
1304                   -- ty is actually a kind, zonk to AnyK
1305                   then anyKind
1306                   else anyTypeOfKind (defaultKind (tyVarKind tv))
1307        ; writeMetaTyVar tv ty
1308        ; return ty }
1309
1310
1311 zonkTcLCoToLCo :: ZonkEnv -> TcCoercion -> TcM TcCoercion
1312 -- NB: zonking often reveals that the coercion is an identity
1313 --     in which case the Refl-ness can propagate up to the top
1314 --     which in turn gives more efficient desugaring.  So it's
1315 --     worth using the 'mk' smart constructors on the RHS
1316 zonkTcLCoToLCo env co
1317   = go co
1318   where
1319     go (TcLetCo bs co)        = do { (env', bs') <- zonkTcEvBinds env bs
1320                                    ; co' <- zonkTcLCoToLCo env' co
1321                                    ; return (TcLetCo bs' co') }
1322     go (TcCoVarCo cv)         = return (mkTcCoVarCo (zonkEvVarOcc env cv))
1323     go (TcRefl ty)            = do { ty' <- zonkTcTypeToType env ty
1324                                    ; return (TcRefl ty') }
1325     go (TcTyConAppCo tc cos)  = do { cos' <- mapM go cos; return (mkTcTyConAppCo tc cos') }
1326     go (TcAxiomInstCo ax tys) = do { tys' <- zonkTcTypeToTypes env tys; return (TcAxiomInstCo ax tys') }
1327     go (TcAppCo co1 co2)      = do { co1' <- go co1; co2' <- go co2
1328                                    ; return (mkTcAppCo co1' co2') }
1329     go (TcSymCo co)           = do { co' <- go co; return (mkTcSymCo co')  }
1330     go (TcNthCo n co)         = do { co' <- go co; return (mkTcNthCo n co')  }
1331     go (TcTransCo co1 co2)    = do { co1' <- go co1; co2' <- go co2
1332                                    ; return (mkTcTransCo co1' co2')  }
1333     go (TcForAllCo tv co)     = ASSERT( isImmutableTyVar tv )
1334                                 do { co' <- go co; return (mkTcForAllCo tv co') }
1335     go (TcInstCo co ty)       = do { co' <- go co; ty' <- zonkTcTypeToType env ty; return (TcInstCo co' ty') }
1336 \end{code}