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