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