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