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