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