TcHsSyn.hs 61.3 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1996-1998

5 6

TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker
7 8 9

This module is an extension of @HsSyn@ syntax, for use in the type
checker.
Austin Seipp's avatar
Austin Seipp committed
10
-}
11

12 13
{-# LANGUAGE CPP #-}

14
module TcHsSyn (
15 16 17 18 19
        mkHsConApp, mkHsDictLet, mkHsApp,
        hsLitType, hsLPatType, hsPatType,
        mkHsAppTy, mkSimpleHsAlt,
        nlHsIntLit,
        shortCutLit, hsOverLitName,
20
        conLikeResTy,
21 22 23 24 25 26

        -- re-exported from TcMonad
        TcId, TcIdSet,

        zonkTopDecls, zonkTopExpr, zonkTopLExpr,
        zonkTopBndrs, zonkTyBndrsX,
27
        emptyZonkEnv, mkEmptyZonkEnv,
28
        zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
29
        zonkCoToCo
30 31
  ) where

32
#include "HsVersions.h"
33

34
import HsSyn
35
import Id
36
import TcRnMonad
37
import PrelNames
38
import TcType
39
import TcMType
40
import TcEvidence
41 42
import TysPrim
import TysWiredIn
dreixel's avatar
dreixel committed
43
import Type
44
import Coercion
45
import ConLike
46
import DataCon
47 48
import Name
import Var
49
import VarSet
50
import VarEnv
51
import DynFlags
52
import Literal
53 54 55
import BasicTypes
import Maybes
import SrcLoc
sof's avatar
sof committed
56
import Bag
sof's avatar
sof committed
57
import Outputable
58
import Util
59 60
import qualified GHC.LanguageExtensions as LangExt

61 62
import Control.Monad
import Data.List  ( partition )
63

Austin Seipp's avatar
Austin Seipp committed
64 65 66
{-
************************************************************************
*                                                                      *
67
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
Austin Seipp's avatar
Austin Seipp committed
68 69
*                                                                      *
************************************************************************
70

71
Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
72
then something is wrong.
Austin Seipp's avatar
Austin Seipp committed
73 74
-}

75 76 77
hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat

Ian Lynagh's avatar
Ian Lynagh committed
78 79 80
hsPatType :: Pat Id -> Type
hsPatType (ParPat pat)                = hsLPatType pat
hsPatType (WildPat ty)                = ty
81
hsPatType (VarPat (L _ var))          = idType var
Ian Lynagh's avatar
Ian Lynagh committed
82 83 84 85 86
hsPatType (BangPat pat)               = hsLPatType pat
hsPatType (LazyPat pat)               = hsLPatType pat
hsPatType (LitPat lit)                = hsLitType lit
hsPatType (AsPat var _)               = idType (unLoc var)
hsPatType (ViewPat _ _ ty)            = ty
87 88
hsPatType (ListPat _ ty Nothing)      = mkListTy ty
hsPatType (ListPat _ _ (Just (ty,_))) = ty
Ian Lynagh's avatar
Ian Lynagh committed
89
hsPatType (PArrPat _ ty)              = mkPArrTy ty
90
hsPatType (TuplePat _ bx tys)         = mkTupleTy bx tys
91
hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys })
92
                                      = conLikeResTy con tys
Ian Lynagh's avatar
Ian Lynagh committed
93
hsPatType (SigPatOut _ ty)            = ty
Alan Zimmerman's avatar
Alan Zimmerman committed
94
hsPatType (NPat (L _ lit) _ _)        = overLitType lit
Ian Lynagh's avatar
Ian Lynagh committed
95 96 97
hsPatType (NPlusKPat id _ _ _)        = idType (unLoc id)
hsPatType (CoPat _ _ ty)              = ty
hsPatType p                           = pprPanic "hsPatType" (ppr p)
98

99

100
hsLitType :: HsLit -> TcType
101 102 103 104 105 106 107 108 109 110 111 112 113
hsLitType (HsChar _ _)       = charTy
hsLitType (HsCharPrim _ _)   = charPrimTy
hsLitType (HsString _ _)     = stringTy
hsLitType (HsStringPrim _ _) = addrPrimTy
hsLitType (HsInt _ _)        = intTy
hsLitType (HsIntPrim _ _)    = intPrimTy
hsLitType (HsWordPrim _ _)   = wordPrimTy
hsLitType (HsInt64Prim _ _)  = int64PrimTy
hsLitType (HsWord64Prim _ _) = word64PrimTy
hsLitType (HsInteger _ _ ty) = ty
hsLitType (HsRat _ ty)       = ty
hsLitType (HsFloatPrim _)    = floatPrimTy
hsLitType (HsDoublePrim _)   = doublePrimTy
114

Austin Seipp's avatar
Austin Seipp committed
115
-- Overloaded literals. Here mainly because it uses isIntTy etc
116

117
shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr TcId)
118 119 120 121 122
shortCutLit dflags (HsIntegral src i) ty
  | isIntTy ty  && inIntRange  dflags i = Just (HsLit (HsInt src i))
  | isWordTy ty && inWordRange dflags i
                                   = Just (mkLit wordDataCon (HsWordPrim src i))
  | isIntegerTy ty = Just (HsLit (HsInteger src i ty))
123
  | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit i)) ty
124 125 126 127 128
        -- The 'otherwise' case is important
        -- Consider (3 :: Float).  Syntactically it looks like an IntLit,
        -- so we'll call shortCutIntLit, but of course it's a float
        -- This can make a big difference for programs with a lot of
        -- literals, compiled without -O
129

130
shortCutLit _ (HsFractional f) ty
131 132
  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim f))
  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
133 134
  | otherwise     = Nothing

135 136
shortCutLit _ (HsIsString src s) ty
  | isStringTy ty = Just (HsLit (HsString src s))
137 138 139 140 141 142 143 144 145 146 147
  | otherwise     = Nothing

mkLit :: DataCon -> HsLit -> HsExpr Id
mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)

------------------------------
hsOverLitName :: OverLitVal -> Name
-- Get the canonical 'fromX' name for a particular OverLitVal
hsOverLitName (HsIntegral {})   = fromIntegerName
hsOverLitName (HsFractional {}) = fromRationalName
hsOverLitName (HsIsString {})   = fromStringName
148

Austin Seipp's avatar
Austin Seipp committed
149 150 151
{-
************************************************************************
*                                                                      *
152
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
Austin Seipp's avatar
Austin Seipp committed
153 154
*                                                                      *
************************************************************************
155

156 157
The rest of the zonking is done *after* typechecking.
The main zonking pass runs over the bindings
158 159 160

 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 b) convert unbound TcTyVar to Void
161
 c) convert each TcId to an Id by zonking its type
sof's avatar
sof committed
162

163 164
The type variables are converted by binding mutable tyvars to immutable ones
and then zonking as normal.
165

166 167 168
The Ids are converted by binding them in the normal Tc envt; that
way we maintain sharing; eg an Id is zonked at its binding site and they
all occurrences of that Id point to the common zonked copy
sof's avatar
sof committed
169

170
It's all pretty boring stuff, because HsSyn is such a large type, and
171
the environment manipulation is tiresome.
Austin Seipp's avatar
Austin Seipp committed
172
-}
173

174
type UnboundTyVarZonker = TcTyVar -> TcM Type
175
        -- How to zonk an unbound type variable
dreixel's avatar
dreixel committed
176 177
        -- Note [Zonking the LHS of a RULE]

178 179 180 181 182 183 184 185 186 187 188
-- | A ZonkEnv carries around several bits.
-- The UnboundTyVarZonker just zaps unbouned meta-tyvars to Any (as
-- defined in zonkTypeZapping), except on the LHS of rules. See
-- Note [Zonking the LHS of a RULE]. The (TyCoVarEnv TyVar) and is just
-- an optimisation: when binding a tyvar or covar, we zonk the kind right away
-- and add a mapping to the env. This prevents re-zonking the kind at
-- every occurrence. But this is *just* an optimisation.
-- The final (IdEnv Var) optimises zonking for
-- Ids. It is knot-tied. We must be careful never to put coercion variables
-- (which are Ids, after all) in the knot-tied env, because coercions can
-- appear in types, and we sometimes inspect a zonked type in this module.
189 190
data ZonkEnv
  = ZonkEnv
dreixel's avatar
dreixel committed
191
      UnboundTyVarZonker
192 193
      (TyCoVarEnv TyVar)
      (IdEnv      Var)         -- What variables are in scope
194 195 196 197 198 199 200
        -- Maps an Id or EvVar to its zonked version; both have the same Name
        -- Note that all evidence (coercion variables as well as dictionaries)
        --      are kept in the ZonkEnv
        -- Only *type* abstraction is done by side effect
        -- Is only consulted lazily; hence knot-tying

instance Outputable ZonkEnv where
201 202 203
  ppr (ZonkEnv _ _ty_env var_env) = vcat (map ppr (varEnvElts var_env))


204
-- The EvBinds have to already be zonked, but that's usually the case.
Ian Lynagh's avatar
Ian Lynagh committed
205
emptyZonkEnv :: ZonkEnv
206 207 208 209
emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping

mkEmptyZonkEnv :: UnboundTyVarZonker -> ZonkEnv
mkEmptyZonkEnv zonker = ZonkEnv zonker emptyVarEnv emptyVarEnv
210

211 212 213 214 215
-- | Extend the knot-tied environment.
extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv
extendIdZonkEnvRec (ZonkEnv zonk_ty ty_env id_env) ids
    -- NB: Don't look at the var to decide which env't to put it in. That
    -- would end up knot-tying all the env'ts.
dreixel's avatar
dreixel committed
216
  = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
217 218 219 220 221 222 223 224 225 226 227 228
  -- Given coercion variables will actually end up here. That's OK though:
  -- coercion variables are never looked up in the knot-tied env't, so zonking
  -- them simply doesn't get optimised. No one gets hurt. An improvement (?)
  -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the
  -- recursive groups. But perhaps the time it takes to do the analysis is
  -- more than the savings.

extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
extendZonkEnv (ZonkEnv zonk_ty tyco_env id_env) vars
  = ZonkEnv zonk_ty (extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars])
                    (extendVarEnvList id_env   [(id,id) | id <- ids])
  where (tycovars, ids) = partition isTyCoVar vars
229

dreixel's avatar
dreixel committed
230
extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
231
extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id
dreixel's avatar
dreixel committed
232
  = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
233

dreixel's avatar
dreixel committed
234 235 236 237 238
extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) ty
  = ZonkEnv zonk_ty (extendVarEnv ty_env ty ty) id_env

setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
239 240
setZonkType (ZonkEnv _ ty_env id_env) zonk_ty
  = ZonkEnv zonk_ty ty_env id_env
241

242
zonkEnvIds :: ZonkEnv -> [Id]
dreixel's avatar
dreixel committed
243
zonkEnvIds (ZonkEnv _ _ id_env) = varEnvElts id_env
244 245

zonkIdOcc :: ZonkEnv -> TcId -> Id
246
-- Ids defined in this module should be in the envt;
247 248
-- ignore others.  (Actually, data constructors are also
-- not LocalVars, even when locally defined, but that is fine.)
249 250
-- (Also foreign-imported things aren't currently in the ZonkEnv;
--  that's ok because they don't need zonking.)
251 252
--
-- Actually, Template Haskell works in 'chunks' of declarations, and
253
-- an earlier chunk won't be in the 'env' that the zonking phase
254
-- carries around.  Instead it'll be in the tcg_gbl_env, already fully
255
-- zonked.  There's no point in looking it up there (except for error
256 257 258 259
-- checking), and it's not conveniently to hand; hence the simple
-- 'orElse' case in the LocalVar branch.
--
-- Even without template splices, in module Main, the checking of
260
-- 'main' is done as a separate chunk.
261 262 263
zonkIdOcc (ZonkEnv _zonk_ty _ty_env id_env) id
  | isLocalVar id = lookupVarEnv id_env id `orElse`
                    id
264
  | otherwise     = id
265

Ian Lynagh's avatar
Ian Lynagh committed
266
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
267
zonkIdOccs env ids = map (zonkIdOcc env) ids
268

269
-- zonkIdBndr is used *after* typechecking to get the Id's type
270
-- to its final form.  The TyVarEnv give
271 272
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
zonkIdBndr env id
ian@well-typed.com's avatar
ian@well-typed.com committed
273
  = do ty' <- zonkTcTypeToType env (idType id)
274
       return (setIdType id ty')
275 276

zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
277
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
278 279 280

zonkTopBndrs :: [TcId] -> TcM [Id]
zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
281

282 283 284
zonkFieldOcc :: ZonkEnv -> FieldOcc TcId -> TcM (FieldOcc Id)
zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel

285
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
286
zonkEvBndrsX = mapAccumLM zonkEvBndrX
287 288 289 290 291

zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
-- Works for dictionaries and coercions
zonkEvBndrX env var
  = do { var' <- zonkEvBndr env var
292
       ; return (extendZonkEnv env [var'], var') }
293 294 295 296

zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
-- Works for dictionaries and coercions
-- Does not extend the ZonkEnv
297
zonkEvBndr env var
298
  = do { let var_ty = varType var
299
       ; ty <-
300 301
           {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
           zonkTcTypeToType env var_ty
dreixel's avatar
dreixel committed
302
       ; return (setVarType var ty) }
303

304 305 306 307 308 309
zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm
zonkEvVarOcc env v
  | isCoVar v
  = EvCoercion <$> zonkCoVarOcc env v
  | otherwise
  = return (EvId $ zonkIdOcc env v)
dreixel's avatar
dreixel committed
310 311

zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
312
zonkTyBndrsX = mapAccumLM zonkTyBndrX
dreixel's avatar
dreixel committed
313 314

zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar)
315 316
-- This guarantees to return a TyVar (not a TcTyVar)
-- then we add it to the envt, so all occurrences are replaced
dreixel's avatar
dreixel committed
317
zonkTyBndrX env tv
318 319
  = ASSERT( isImmutableTyVar tv )
    do { ki <- zonkTcTypeToType env (tyVarKind tv)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
320
               -- Internal names tidy up better, for iface files.
321 322
       ; let tv' = mkTyVar (tyVarName tv) ki
       ; return (extendTyZonkEnv1 env tv', tv') }
323

324
zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
325 326
zonkTopExpr e = zonkExpr emptyZonkEnv e

327 328 329
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

330
zonkTopDecls :: Bag EvBind
Matthew Pickering's avatar
Matthew Pickering committed
331
             -> LHsBinds TcId
332
             -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
333
             -> TcM ([Id],
334
                     Bag EvBind,
cactus's avatar
cactus committed
335
                     LHsBinds Id,
336 337 338 339
                     [LForeignDecl Id],
                     [LTcSpecPrag],
                     [LRuleDecl    Id],
                     [LVectDecl    Id])
340
zonkTopDecls ev_binds binds rules vects imp_specs fords
341
  = do  { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
342
        ; (env2, binds') <- zonkRecMonoBinds env1 binds
343 344 345
                        -- Top level is implicitly recursive
        ; rules' <- zonkRules env2 rules
        ; vects' <- zonkVects env2 vects
346
        ; specs' <- zonkLTcSpecPrags env2 imp_specs
347 348
        ; fords' <- zonkForeignExports env2 fords
        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') }
349 350

---------------------------------------------
351 352 353 354
zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
zonkLocalBinds env EmptyLocalBinds
  = return (env, EmptyLocalBinds)

355 356 357
zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
  = panic "zonkLocalBinds" -- Not in typechecker output

358 359
zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs))
  = do  { (env1, new_binds) <- go env binds
360 361
        ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }
  where
362
    go env []
363
      = return (env, [])
364 365 366
    go env ((r,b):bs)
      = do { (env1, b')  <- zonkRecMonoBinds env b
           ; (env2, bs') <- go env1 bs
367
           ; return (env2, (r,b'):bs') }
368

ian@well-typed.com's avatar
ian@well-typed.com committed
369 370
zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do
    new_binds <- mapM (wrapLocM zonk_ip_bind) binds
371
    let
372
        env1 = extendIdZonkEnvRec env [ n | L _ (IPBind (Right n) _) <- new_binds]
ian@well-typed.com's avatar
ian@well-typed.com committed
373
    (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
374
    return (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
375
  where
376
    zonk_ip_bind (IPBind n e)
ian@well-typed.com's avatar
ian@well-typed.com committed
377 378 379
        = do n' <- mapIPNameTc (zonkIdBndr env) n
             e' <- zonkLExpr env e
             return (IPBind n' e')
380

381
---------------------------------------------
382 383
zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
zonkRecMonoBinds env binds
384
 = fixM (\ ~(_, new_binds) -> do
385
        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)
386
        ; binds' <- zonkMonoBinds env1 binds
387 388
        ; return (env1, binds') })

389
---------------------------------------------
390 391
zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
cactus's avatar
cactus committed
392

393 394
zonk_lbind :: ZonkEnv -> LHsBind TcId -> TcM (LHsBind Id)
zonk_lbind env = wrapLocM (zonk_bind env)
395

396 397
zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
398 399 400 401
  = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
        ; new_grhss <- zonkGRHSs env zonkLExpr grhss
        ; new_ty    <- zonkTcTypeToType env ty
        ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
402

403
zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
404 405 406 407
  = do { new_var  <- zonkIdBndr env var
       ; new_expr <- zonkLExpr env expr
       ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }

408 409
zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
                            , fun_co_fn = co_fn })
410 411
  = do { new_var <- zonkIdBndr env var
       ; (env1, new_co_fn) <- zonkCoFn env co_fn
412
       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
413 414 415
       ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
                      , fun_co_fn = new_co_fn }) }

416 417 418 419
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                        , abs_ev_binds = ev_binds
                        , abs_exports = exports
                        , abs_binds = val_binds })
420
  = ASSERT( all isImmutableTyVar tyvars )
dreixel's avatar
dreixel committed
421 422
    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
423
       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
424
       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
425 426
         do { let env3 = extendIdZonkEnvRec env2
                           (collectHsBindsBinders new_val_binds)
427
            ; new_val_binds <- zonkMonoBinds env3 val_binds
428 429
            ; new_exports   <- mapM (zonkExport env3) exports
            ; return (new_val_binds, new_exports) }
dreixel's avatar
dreixel committed
430 431
       ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
                          , abs_ev_binds = new_ev_binds
432
                          , abs_exports = new_exports, abs_binds = new_val_bind }) }
sof's avatar
sof committed
433
  where
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
434 435
    zonkExport env (ABE{ abe_wrap = wrap, abe_inst_wrap = inst_wrap
                       , abe_poly = poly_id
436
                       , abe_mono = mono_id, abe_prags = prags })
ian@well-typed.com's avatar
ian@well-typed.com committed
437 438
        = do new_poly_id <- zonkIdBndr env poly_id
             (_, new_wrap) <- zonkCoFn env wrap
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
439
             (_, new_inst_wrap) <- zonkCoFn env inst_wrap
ian@well-typed.com's avatar
ian@well-typed.com committed
440
             new_prags <- zonkSpecPrags env prags
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
441 442
             return (ABE{ abe_wrap = new_wrap, abe_inst_wrap = new_inst_wrap
                        , abe_poly = new_poly_id
ian@well-typed.com's avatar
ian@well-typed.com committed
443 444
                        , abe_mono = zonkIdOcc env mono_id
                        , abe_prags = new_prags })
445

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465
zonk_bind env (AbsBindsSig { abs_tvs         = tyvars
                           , abs_ev_vars     = evs
                           , abs_sig_export  = poly
                           , abs_sig_prags   = prags
                           , abs_sig_ev_bind = ev_bind
                           , abs_sig_bind    = bind })
  = ASSERT( all isImmutableTyVar tyvars )
    do { (env0, new_tyvars)  <- zonkTyBndrsX env  tyvars
       ; (env1, new_evs)     <- zonkEvBndrsX env0 evs
       ; (env2, new_ev_bind) <- zonkTcEvBinds env1 ev_bind
       ; new_val_bind        <- zonk_lbind env2 bind
       ; new_poly_id         <- zonkIdBndr env2 poly
       ; new_prags           <- zonkSpecPrags env2 prags
       ; return (AbsBindsSig { abs_tvs         = new_tyvars
                             , abs_ev_vars     = new_evs
                             , abs_sig_export  = new_poly_id
                             , abs_sig_prags   = new_prags
                             , abs_sig_ev_bind = new_ev_bind
                             , abs_sig_bind    = new_val_bind  }) }

466 467 468 469
zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id
                                    , psb_args = details
                                    , psb_def = lpat
                                    , psb_dir = dir }))
cactus's avatar
cactus committed
470 471
  = do { id' <- zonkIdBndr env id
       ; details' <- zonkPatSynDetails env details
472
       ; (env1, lpat') <- zonkPat env lpat
cactus's avatar
cactus committed
473
       ; (_env2, dir') <- zonkPatSynDir env1 dir
474 475 476 477 478
       ; return $ PatSynBind $
                  bind { psb_id = L loc id'
                       , psb_args = details'
                       , psb_def = lpat'
                       , psb_dir = dir' } }
cactus's avatar
cactus committed
479 480 481 482 483 484 485 486 487

zonkPatSynDetails :: ZonkEnv
                  -> HsPatSynDetails (Located TcId)
                  -> TcM (HsPatSynDetails (Located Id))
zonkPatSynDetails env = traverse (wrapLocM $ zonkIdBndr env)

zonkPatSynDir :: ZonkEnv -> HsPatSynDir TcId -> TcM (ZonkEnv, HsPatSynDir Id)
zonkPatSynDir env Unidirectional = return (env, Unidirectional)
zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
488 489 490
zonkPatSynDir env (ExplicitBidirectional mg) = do
    mg' <- zonkMatchGroup env zonkLExpr mg
    return (env, ExplicitBidirectional mg')
cactus's avatar
cactus committed
491

492 493
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
494
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
495
                                       ; return (SpecPrags ps') }
496 497 498 499

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
500
  where
501
    zonk_prag (L loc (SpecPrag id co_fn inl))
502 503
        = do { (_, co_fn') <- zonkCoFn env co_fn
             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
504

Austin Seipp's avatar
Austin Seipp committed
505 506 507
{-
************************************************************************
*                                                                      *
508
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
509 510 511
*                                                                      *
************************************************************************
-}
512

513
zonkMatchGroup :: ZonkEnv
514 515
               -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
               -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id)))
516 517
zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys
                             , mg_res_ty = res_ty, mg_origin = origin })
518 519 520
  = do  { ms' <- mapM (zonkMatch env zBody) ms
        ; arg_tys' <- zonkTcTypeToTypes env arg_tys
        ; res_ty'  <- zonkTcTypeToType env res_ty
521 522
        ; return (MG { mg_alts = L l ms', mg_arg_tys = arg_tys'
                     , mg_res_ty = res_ty', mg_origin = origin }) }
523

524
zonkMatch :: ZonkEnv
525 526
          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
          -> LMatch TcId (Located (body TcId)) -> TcM (LMatch Id (Located (body Id)))
Alan Zimmerman's avatar
Alan Zimmerman committed
527
zonkMatch env zBody (L loc (Match mf pats _ grhss))
528 529
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
Alan Zimmerman's avatar
Alan Zimmerman committed
530
        ; return (L loc (Match mf new_pats Nothing new_grhss)) }
531

532
-------------------------------------------------------------------------
533
zonkGRHSs :: ZonkEnv
534 535
          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
          -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))
536

537
zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
538
    (new_env, new_binds) <- zonkLocalBinds env binds
539
    let
540
        zonk_grhs (GRHS guarded rhs)
ian@well-typed.com's avatar
ian@well-typed.com committed
541 542 543 544
          = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
               new_rhs <- zBody env2 rhs
               return (GRHS new_guarded new_rhs)
    new_grhss <- mapM (wrapLocM zonk_grhs) grhss
545
    return (GRHSs new_grhss (L l new_binds))
546

Austin Seipp's avatar
Austin Seipp committed
547 548 549
{-
************************************************************************
*                                                                      *
550
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
551 552 553
*                                                                      *
************************************************************************
-}
554

555 556 557
zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
558

559
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
560
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
561

562 563
zonkExpr env (HsVar (L l id))
  = return (HsVar (L l (zonkIdOcc env id)))
564

565
zonkExpr _ (HsIPVar id)
566
  = return (HsIPVar id)
567

Adam Gundry's avatar
Adam Gundry committed
568 569 570
zonkExpr _ (HsOverLabel l)
  = return (HsOverLabel l)

571
zonkExpr env (HsLit (HsRat f ty))
ian@well-typed.com's avatar
ian@well-typed.com committed
572 573
  = do new_ty <- zonkTcTypeToType env ty
       return (HsLit (HsRat f new_ty))
sof's avatar
sof committed
574

Ian Lynagh's avatar
Ian Lynagh committed
575
zonkExpr _ (HsLit lit)
576
  = return (HsLit lit)
577 578

zonkExpr env (HsOverLit lit)
579 580
  = do  { lit' <- zonkOverLit env lit
        ; return (HsOverLit lit') }
581

582
zonkExpr env (HsLam matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
583 584
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLam new_matches)
585

586
zonkExpr env (HsLamCase arg matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
587 588 589
  = do new_arg <- zonkTcTypeToType env arg
       new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLamCase new_arg new_matches)
590

591
zonkExpr env (HsApp e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
592 593 594
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (HsApp new_e1 new_e2)
595

gmainland's avatar
gmainland committed
596 597 598
zonkExpr _ e@(HsRnBracketOut _ _)
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

599
zonkExpr env (HsTcBracketOut body bs)
ian@well-typed.com's avatar
ian@well-typed.com committed
600
  = do bs' <- mapM zonk_b bs
601
       return (HsTcBracketOut body bs')
602
  where
603 604
    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
                                      return (PendingTcSplice n e')
gmainland's avatar
gmainland committed
605

606 607
zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE s)
608 609

zonkExpr env (OpApp e1 op fixity e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
610 611 612 613
  = do new_e1 <- zonkLExpr env e1
       new_op <- zonkLExpr env op
       new_e2 <- zonkLExpr env e2
       return (OpApp new_e1 new_op fixity new_e2)
614

615
zonkExpr env (NegApp expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
616 617 618
  = do new_expr <- zonkLExpr env expr
       new_op <- zonkExpr env op
       return (NegApp new_expr new_op)
619

620
zonkExpr env (HsPar e)
ian@well-typed.com's avatar
ian@well-typed.com committed
621 622
  = do new_e <- zonkLExpr env e
       return (HsPar new_e)
623 624

zonkExpr env (SectionL expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
625 626 627
  = do new_expr <- zonkLExpr env expr
       new_op   <- zonkLExpr env op
       return (SectionL new_expr new_op)
628 629

zonkExpr env (SectionR op expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
630 631 632
  = do new_op   <- zonkLExpr env op
       new_expr <- zonkLExpr env expr
       return (SectionR new_op new_expr)
633

634 635 636 637
zonkExpr env (ExplicitTuple tup_args boxed)
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
       ; return (ExplicitTuple new_tup_args boxed) }
  where
638 639 640 641
    zonk_tup_arg (L l (Present e)) = do { e' <- zonkLExpr env e
                                        ; return (L l (Present e')) }
    zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t
                                        ; return (L l (Missing t')) }
642

643
zonkExpr env (HsCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
644 645 646
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLExpr ms
       return (HsCase new_expr new_ms)
647

648 649 650 651 652
zonkExpr env (HsIf e0 e1 e2 e3)
  = do { new_e0 <- fmapMaybeM (zonkExpr env) e0
       ; new_e1 <- zonkLExpr env e1
       ; new_e2 <- zonkLExpr env e2
       ; new_e3 <- zonkLExpr env e3
653
       ; return (HsIf new_e0 new_e1 new_e2 new_e3) }
654

655 656 657
zonkExpr env (HsMultiIf ty alts)
  = do { alts' <- mapM (wrapLocM zonk_alt) alts
       ; ty'   <- zonkTcTypeToType env ty
658
       ; return $ HsMultiIf ty' alts' }
659
  where zonk_alt (GRHS guard expr)
660
          = do { (env', guard') <- zonkStmts env zonkLExpr guard
661
               ; expr'          <- zonkLExpr env' expr
662
               ; return $ GRHS guard' expr' }
663

664
zonkExpr env (HsLet (L l binds) expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
665 666
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_expr <- zonkLExpr new_env expr
667
       return (HsLet (L l new_binds) new_expr)
668

669
zonkExpr env (HsDo do_or_lc (L l stmts) ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
670 671
  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
       new_ty <- zonkTcTypeToType env ty
672
       return (HsDo do_or_lc (L l new_stmts) new_ty)
673

674
zonkExpr env (ExplicitList ty wit exprs)
ian@well-typed.com's avatar
ian@well-typed.com committed
675 676 677 678
  = do new_ty <- zonkTcTypeToType env ty
       new_wit <- zonkWit env wit
       new_exprs <- zonkLExprs env exprs
       return (ExplicitList new_ty new_wit new_exprs)
679
   where zonkWit _ Nothing = return Nothing
ian@well-typed.com's avatar
ian@well-typed.com committed
680 681
         zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
                                     return (Just new_fln)
682 683

zonkExpr env (ExplicitPArr ty exprs)
ian@well-typed.com's avatar
ian@well-typed.com committed
684 685 686
  = do new_ty <- zonkTcTypeToType env ty
       new_exprs <- zonkLExprs env exprs
       return (ExplicitPArr new_ty new_exprs)
687

688
zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds })
689 690
  = do  { new_con_expr <- zonkExpr env con_expr
        ; new_rbinds   <- zonkRecFields env rbinds
691 692
        ; return (expr { rcon_con_expr = new_con_expr
                       , rcon_flds = new_rbinds }) }
693

694 695 696
zonkExpr env (RecordUpd { rupd_expr = expr, rupd_flds = rbinds
                        , rupd_cons = cons, rupd_in_tys = in_tys
                        , rupd_out_tys = out_tys, rupd_wrap = req_wrap })
697 698 699
  = do  { new_expr    <- zonkLExpr env expr
        ; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
        ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
700
        ; new_rbinds  <- zonkRecUpdFields env rbinds
Matthew Pickering's avatar
Matthew Pickering committed
701
        ; (_, new_recwrap) <- zonkCoFn env req_wrap
702 703 704
        ; return (RecordUpd { rupd_expr = new_expr, rupd_flds =  new_rbinds
                            , rupd_cons = cons, rupd_in_tys = new_in_tys
                            , rupd_out_tys = new_out_tys, rupd_wrap = new_recwrap }) }
705

706
zonkExpr env (ExprWithTySigOut e ty)
707 708 709
  = do { e' <- zonkLExpr env e
       ; return (ExprWithTySigOut e' ty) }

710
zonkExpr env (ArithSeq expr wit info)
ian@well-typed.com's avatar
ian@well-typed.com committed
711 712 713 714
  = do new_expr <- zonkExpr env expr
       new_wit <- zonkWit env wit
       new_info <- zonkArithSeq env info
       return (ArithSeq new_expr new_wit new_info)
715
   where zonkWit _ Nothing = return Nothing
ian@well-typed.com's avatar
ian@well-typed.com committed
716 717
         zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
                                     return (Just new_fln)
718

719
zonkExpr env (PArrSeq expr info)
ian@well-typed.com's avatar
ian@well-typed.com committed
720 721 722
  = do new_expr <- zonkExpr env expr
       new_info <- zonkArithSeq env info
       return (PArrSeq new_expr new_info)
723

Alan Zimmerman's avatar
Alan Zimmerman committed
724
zonkExpr env (HsSCC src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
725
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
726
       return (HsSCC src lbl new_expr)
727

728
zonkExpr env (HsTickPragma src info srcInfo expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
729
  = do new_expr <- zonkLExpr env expr
730
       return (HsTickPragma src info srcInfo new_expr)
andy@galois.com's avatar
andy@galois.com committed
731

732
-- hdaume: core annotations
Alan Zimmerman's avatar
Alan Zimmerman committed
733
zonkExpr env (HsCoreAnn src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
734
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
735
       return (HsCoreAnn src lbl new_expr)
736

737
-- arrow notation extensions
738
zonkExpr env (HsProc pat body)
739 740 741
  = do  { (env1, new_pat) <- zonkPat env pat
        ; new_body <- zonkCmdTop env1 body
        ; return (HsProc new_pat new_body) }
742

743 744 745 746
-- StaticPointers extension
zonkExpr env (HsStatic expr)
  = HsStatic <$> zonkLExpr env expr

747
zonkExpr env (HsWrap co_fn expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
748 749 750
  = do (env1, new_co_fn) <- zonkCoFn env co_fn
       new_expr <- zonkExpr env1 expr
       return (HsWrap new_co_fn new_expr)
751

752 753
zonkExpr _ (HsUnboundVar v)
  = return (HsUnboundVar v)
754

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
755 756 757
  -- nothing to do here. The payload is an LHsType, not a Type.
zonkExpr _ e@(HsTypeOut {}) = return e

Ian Lynagh's avatar
Ian Lynagh committed
758
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
759

760 761 762 763 764 765 766
-------------------------------------------------------------------------

zonkLCmd  :: ZonkEnv -> LHsCmd TcId   -> TcM (LHsCmd Id)
zonkCmd   :: ZonkEnv -> HsCmd TcId    -> TcM (HsCmd Id)

zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
767 768 769 770
zonkCmd env (HsCmdWrap w cmd)
  = do { (env1, w') <- zonkCoFn env w
       ; cmd' <- zonkCmd env1 cmd
       ; return (HsCmdWrap w' cmd') }
771
zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
ian@well-typed.com's avatar
ian@well-typed.com committed
772 773 774 775
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       new_ty <- zonkTcTypeToType env ty
       return (HsCmdArrApp new_e1 new_e2 new_ty ho rl)
776 777

zonkCmd env (HsCmdArrForm op fixity args)
ian@well-typed.com's avatar
ian@well-typed.com committed
778 779 780
  = do new_op <- zonkLExpr env op
       new_args <- mapM (zonkCmdTop env) args
       return (HsCmdArrForm new_op fixity new_args)
781 782

zonkCmd env (HsCmdApp c e)
ian@well-typed.com's avatar
ian@well-typed.com committed
783 784 785
  = do new_c <- zonkLCmd env c
       new_e <- zonkLExpr env e
       return (HsCmdApp new_c new_e)
786 787

zonkCmd env (HsCmdLam matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
788 789
  = do new_matches <- zonkMatchGroup env zonkLCmd matches
       return (HsCmdLam new_matches)
790

791
zonkCmd env (HsCmdPar c)
ian@well-typed.com's avatar
ian@well-typed.com committed
792 793
  = do new_c <- zonkLCmd env c
       return (HsCmdPar new_c)
794 795

zonkCmd env (HsCmdCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
796 797 798
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLCmd ms
       return (HsCmdCase new_expr new_ms)
799 800 801 802 803 804

zonkCmd env (HsCmdIf eCond ePred cThen cElse)
  = do { new_eCond <- fmapMaybeM (zonkExpr env) eCond
       ; new_ePred <- zonkLExpr env ePred
       ; new_cThen <- zonkLCmd env cThen
       ; new_cElse <- zonkLCmd env cElse
805
       ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
806

807
zonkCmd env (HsCmdLet (L l binds) cmd)
ian@well-typed.com's avatar
ian@well-typed.com committed
808 809
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_cmd <- zonkLCmd new_env cmd
810
       return (HsCmdLet (L l new_binds) new_cmd)
811

812
zonkCmd env (HsCmdDo (L l stmts) ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
813 814
  = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
       new_ty <- zonkTcTypeToType env ty
815
       return (HsCmdDo (L l new_stmts) new_ty)
816 817 818 819 820





821 822 823
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd

Ian Lynagh's avatar
Ian Lynagh committed
824
zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
825
zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
ian@well-typed.com's avatar
ian@well-typed.com committed
826 827 828 829 830
  = do new_cmd <- zonkLCmd env cmd
       new_stack_tys <- zonkTcTypeToType env stack_tys
       new_ty <- zonkTcTypeToType env ty
       new_ids <- mapSndM (zonkExpr env) ids
       return (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
831

832
-------------------------------------------------------------------------
833
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
834
zonkCoFn env WpHole   = return (env, WpHole)
835
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
836 837
                                    ; (env2, c2') <- zonkCoFn env1 c2
                                    ; return (env2, WpCompose c1' c2') }
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
838 839 840 841
zonkCoFn env (WpFun c1 c2 t1) = do { (env1, c1') <- zonkCoFn env c1
                                   ; (env2, c2') <- zonkCoFn env1 c2
                                   ; t1'         <- zonkTcTypeToType env2 t1
                                   ; return (env2, WpFun c1' c2' t1') }
842
zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co
843
                              ; return (env, WpCast co') }
844
zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
845 846
                                 ; return (env', WpEvLam ev') }
zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg
847
                                 ; return (env, WpEvApp arg') }
848
zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
dreixel's avatar
dreixel committed
849
                              do { (env', tv') <- zonkTyBndrX env tv
850
                                 ; return (env', WpTyLam tv') }
851
zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToType env ty
852
                                 ; return (env, WpTyApp ty') }
853
zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs
854
                                 ; return (env1, WpLet bs') }
855

856 857
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
858
zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
859 860 861
  = do  { ty' <- zonkTcTypeToType env ty
        ; e' <- zonkExpr env e
        ; return (lit { ol_witness = e', ol_type = ty' }) }
862

863
-------------------------------------------------------------------------
864
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
865

866
zonkArithSeq env (From e)
ian@well-typed.com's avatar
ian@well-typed.com committed
867 868
  = do new_e <- zonkLExpr env e
       return (From new_e)
869

870
zonkArithSeq env (FromThen e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
871 872 873
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (FromThen new_e1 new_e2)
874

875
zonkArithSeq env (FromTo e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
876 877 878
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (FromTo new_e1 new_e2)
879

880
zonkArithSeq env (FromThenTo e1 e2 e3)
ian@well-typed.com's avatar
ian@well-typed.com committed