TcHsSyn.hs 65.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
        -- * re-exported from TcMonad
23 24
        TcId, TcIdSet,

25 26 27
        -- * Zonking
        -- | For a description of "zonking", see Note [What is zonking?]
        -- in TcMType
28 29
        zonkTopDecls, zonkTopExpr, zonkTopLExpr,
        zonkTopBndrs, zonkTyBndrsX,
30
        emptyZonkEnv, mkEmptyZonkEnv,
31
        zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
32
        zonkCoToCo
33 34
  ) where

35
#include "HsVersions.h"
36

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

64 65
import Control.Monad
import Data.List  ( partition )
66
import Control.Arrow ( second )
67

Austin Seipp's avatar
Austin Seipp committed
68 69 70
{-
************************************************************************
*                                                                      *
71
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
Austin Seipp's avatar
Austin Seipp committed
72 73
*                                                                      *
************************************************************************
74

75
Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
76
then something is wrong.
Austin Seipp's avatar
Austin Seipp committed
77 78
-}

79 80 81
hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat

Ian Lynagh's avatar
Ian Lynagh committed
82 83 84
hsPatType :: Pat Id -> Type
hsPatType (ParPat pat)                = hsLPatType pat
hsPatType (WildPat ty)                = ty
85
hsPatType (VarPat (L _ var))          = idType var
Ian Lynagh's avatar
Ian Lynagh committed
86 87 88 89 90
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
91 92
hsPatType (ListPat _ ty Nothing)      = mkListTy ty
hsPatType (ListPat _ _ (Just (ty,_))) = ty
Ian Lynagh's avatar
Ian Lynagh committed
93
hsPatType (PArrPat _ ty)              = mkPArrTy ty
94
hsPatType (TuplePat _ bx tys)         = mkTupleTy bx tys
95
hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys })
96
                                      = conLikeResTy con tys
Ian Lynagh's avatar
Ian Lynagh committed
97
hsPatType (SigPatOut _ ty)            = ty
98 99
hsPatType (NPat _ _ _ ty)             = ty
hsPatType (NPlusKPat _ _ _ _ _ ty)    = ty
Ian Lynagh's avatar
Ian Lynagh committed
100 101
hsPatType (CoPat _ _ ty)              = ty
hsPatType p                           = pprPanic "hsPatType" (ppr p)
102

103

104
hsLitType :: HsLit -> TcType
105 106 107 108 109 110 111 112 113 114 115 116 117
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
118

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

121
shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr TcId)
122 123 124 125 126
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))
127
  | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit i)) ty
128 129 130 131 132
        -- 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
133

134
shortCutLit _ (HsFractional f) ty
135 136
  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim f))
  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
137 138
  | otherwise     = Nothing

139 140
shortCutLit _ (HsIsString src s) ty
  | isStringTy ty = Just (HsLit (HsString src s))
141 142 143 144 145 146 147 148 149 150 151
  | 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
152

Austin Seipp's avatar
Austin Seipp committed
153 154 155
{-
************************************************************************
*                                                                      *
156
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
Austin Seipp's avatar
Austin Seipp committed
157 158
*                                                                      *
************************************************************************
159

160 161
The rest of the zonking is done *after* typechecking.
The main zonking pass runs over the bindings
162 163 164

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

167 168
The type variables are converted by binding mutable tyvars to immutable ones
and then zonking as normal.
169

170 171 172
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
173

174
It's all pretty boring stuff, because HsSyn is such a large type, and
175
the environment manipulation is tiresome.
Austin Seipp's avatar
Austin Seipp committed
176
-}
177

178
-- Confused by zonking? See Note [What is zonking?] in TcMType.
179
type UnboundTyVarZonker = TcTyVar -> TcM Type
180
        -- How to zonk an unbound type variable
dreixel's avatar
dreixel committed
181 182
        -- Note [Zonking the LHS of a RULE]

183 184 185 186 187 188 189 190 191 192 193
-- | 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.
194 195
--
-- Confused by zonking? See Note [What is zonking?] in TcMType.
196 197
data ZonkEnv
  = ZonkEnv
dreixel's avatar
dreixel committed
198
      UnboundTyVarZonker
199 200
      (TyCoVarEnv TyVar)
      (IdEnv      Var)         -- What variables are in scope
201 202 203 204 205 206 207
        -- 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
208 209 210
  ppr (ZonkEnv _ _ty_env var_env) = vcat (map ppr (varEnvElts var_env))


211
-- The EvBinds have to already be zonked, but that's usually the case.
Ian Lynagh's avatar
Ian Lynagh committed
212
emptyZonkEnv :: ZonkEnv
213 214 215 216
emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping

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

218 219 220 221 222
-- | 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
223
  = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
224 225 226 227 228 229 230 231 232 233 234 235
  -- 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
236

dreixel's avatar
dreixel committed
237
extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
238
extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id
dreixel's avatar
dreixel committed
239
  = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
240

dreixel's avatar
dreixel committed
241 242 243 244 245
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
246 247
setZonkType (ZonkEnv _ ty_env id_env) zonk_ty
  = ZonkEnv zonk_ty ty_env id_env
248

249
zonkEnvIds :: ZonkEnv -> [Id]
dreixel's avatar
dreixel committed
250
zonkEnvIds (ZonkEnv _ _ id_env) = varEnvElts id_env
251 252

zonkIdOcc :: ZonkEnv -> TcId -> Id
253
-- Ids defined in this module should be in the envt;
254 255
-- ignore others.  (Actually, data constructors are also
-- not LocalVars, even when locally defined, but that is fine.)
256 257
-- (Also foreign-imported things aren't currently in the ZonkEnv;
--  that's ok because they don't need zonking.)
258 259
--
-- Actually, Template Haskell works in 'chunks' of declarations, and
260
-- an earlier chunk won't be in the 'env' that the zonking phase
261
-- carries around.  Instead it'll be in the tcg_gbl_env, already fully
262
-- zonked.  There's no point in looking it up there (except for error
263 264 265 266
-- 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
267
-- 'main' is done as a separate chunk.
268 269 270
zonkIdOcc (ZonkEnv _zonk_ty _ty_env id_env) id
  | isLocalVar id = lookupVarEnv id_env id `orElse`
                    id
271
  | otherwise     = id
272

Ian Lynagh's avatar
Ian Lynagh committed
273
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
274
zonkIdOccs env ids = map (zonkIdOcc env) ids
275

276
-- zonkIdBndr is used *after* typechecking to get the Id's type
277
-- to its final form.  The TyVarEnv give
278 279
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
zonkIdBndr env id
ian@well-typed.com's avatar
ian@well-typed.com committed
280
  = do ty' <- zonkTcTypeToType env (idType id)
281
       return (setIdType id ty')
282 283

zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
284
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
285 286 287

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

289 290 291
zonkFieldOcc :: ZonkEnv -> FieldOcc TcId -> TcM (FieldOcc Id)
zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel

292
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
293
zonkEvBndrsX = mapAccumLM zonkEvBndrX
294 295 296 297 298

zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
-- Works for dictionaries and coercions
zonkEvBndrX env var
  = do { var' <- zonkEvBndr env var
299
       ; return (extendZonkEnv env [var'], var') }
300 301 302 303

zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
-- Works for dictionaries and coercions
-- Does not extend the ZonkEnv
304
zonkEvBndr env var
305
  = do { let var_ty = varType var
306
       ; ty <-
307 308
           {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
           zonkTcTypeToType env var_ty
dreixel's avatar
dreixel committed
309
       ; return (setVarType var ty) }
310

311 312 313 314 315 316
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
317 318

zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
319
zonkTyBndrsX = mapAccumLM zonkTyBndrX
dreixel's avatar
dreixel committed
320 321

zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar)
322 323
-- 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
324
zonkTyBndrX env tv
325 326
  = ASSERT( isImmutableTyVar tv )
    do { ki <- zonkTcTypeToType env (tyVarKind tv)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
327
               -- Internal names tidy up better, for iface files.
328 329
       ; let tv' = mkTyVar (tyVarName tv) ki
       ; return (extendTyZonkEnv1 env tv', tv') }
330

331
zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
332 333
zonkTopExpr e = zonkExpr emptyZonkEnv e

334 335 336
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

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

---------------------------------------------
358 359 360 361
zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
zonkLocalBinds env EmptyLocalBinds
  = return (env, EmptyLocalBinds)

362 363 364
zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
  = panic "zonkLocalBinds" -- Not in typechecker output

365 366
zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs))
  = do  { (env1, new_binds) <- go env binds
367 368
        ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }
  where
369
    go env []
370
      = return (env, [])
371 372 373
    go env ((r,b):bs)
      = do { (env1, b')  <- zonkRecMonoBinds env b
           ; (env2, bs') <- go env1 bs
374
           ; return (env2, (r,b'):bs') }
375

ian@well-typed.com's avatar
ian@well-typed.com committed
376 377
zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do
    new_binds <- mapM (wrapLocM zonk_ip_bind) binds
378
    let
379
        env1 = extendIdZonkEnvRec env [ n | L _ (IPBind (Right n) _) <- new_binds]
ian@well-typed.com's avatar
ian@well-typed.com committed
380
    (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
381
    return (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
382
  where
383
    zonk_ip_bind (IPBind n e)
ian@well-typed.com's avatar
ian@well-typed.com committed
384 385 386
        = do n' <- mapIPNameTc (zonkIdBndr env) n
             e' <- zonkLExpr env e
             return (IPBind n' e')
387

388
---------------------------------------------
389 390
zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
zonkRecMonoBinds env binds
391
 = fixM (\ ~(_, new_binds) -> do
392
        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)
393
        ; binds' <- zonkMonoBinds env1 binds
394 395
        ; return (env1, binds') })

396
---------------------------------------------
397 398
zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
cactus's avatar
cactus committed
399

400 401
zonk_lbind :: ZonkEnv -> LHsBind TcId -> TcM (LHsBind Id)
zonk_lbind env = wrapLocM (zonk_bind env)
402

403 404
zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
405 406 407 408
  = 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 }) }
409

410
zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
411 412 413 414
  = do { new_var  <- zonkIdBndr env var
       ; new_expr <- zonkLExpr env expr
       ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }

415 416
zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
                            , fun_co_fn = co_fn })
417 418
  = do { new_var <- zonkIdBndr env var
       ; (env1, new_co_fn) <- zonkCoFn env co_fn
419
       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
420 421 422
       ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
                      , fun_co_fn = new_co_fn }) }

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

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471
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  }) }

472 473 474 475
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
476 477
  = do { id' <- zonkIdBndr env id
       ; details' <- zonkPatSynDetails env details
478
       ; (env1, lpat') <- zonkPat env lpat
cactus's avatar
cactus committed
479
       ; (_env2, dir') <- zonkPatSynDir env1 dir
480 481 482 483 484
       ; return $ PatSynBind $
                  bind { psb_id = L loc id'
                       , psb_args = details'
                       , psb_def = lpat'
                       , psb_dir = dir' } }
cactus's avatar
cactus committed
485 486 487 488 489 490 491 492 493

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)
494 495 496
zonkPatSynDir env (ExplicitBidirectional mg) = do
    mg' <- zonkMatchGroup env zonkLExpr mg
    return (env, ExplicitBidirectional mg')
cactus's avatar
cactus committed
497

498 499
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
500
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
501
                                       ; return (SpecPrags ps') }
502 503 504 505

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
506
  where
507
    zonk_prag (L loc (SpecPrag id co_fn inl))
508 509
        = do { (_, co_fn') <- zonkCoFn env co_fn
             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
510

Austin Seipp's avatar
Austin Seipp committed
511 512 513
{-
************************************************************************
*                                                                      *
514
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
515 516 517
*                                                                      *
************************************************************************
-}
518

519
zonkMatchGroup :: ZonkEnv
520 521
               -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
               -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id)))
522 523
zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys
                             , mg_res_ty = res_ty, mg_origin = origin })
524 525 526
  = do  { ms' <- mapM (zonkMatch env zBody) ms
        ; arg_tys' <- zonkTcTypeToTypes env arg_tys
        ; res_ty'  <- zonkTcTypeToType env res_ty
527 528
        ; return (MG { mg_alts = L l ms', mg_arg_tys = arg_tys'
                     , mg_res_ty = res_ty', mg_origin = origin }) }
529

530
zonkMatch :: ZonkEnv
531 532
          -> (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
533
zonkMatch env zBody (L loc (Match mf pats _ grhss))
534 535
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
Alan Zimmerman's avatar
Alan Zimmerman committed
536
        ; return (L loc (Match mf new_pats Nothing new_grhss)) }
537

538
-------------------------------------------------------------------------
539
zonkGRHSs :: ZonkEnv
540 541
          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
          -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))
542

543
zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
544
    (new_env, new_binds) <- zonkLocalBinds env binds
545
    let
546
        zonk_grhs (GRHS guarded rhs)
ian@well-typed.com's avatar
ian@well-typed.com committed
547 548 549 550
          = 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
551
    return (GRHSs new_grhss (L l new_binds))
552

Austin Seipp's avatar
Austin Seipp committed
553 554 555
{-
************************************************************************
*                                                                      *
556
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
557 558 559
*                                                                      *
************************************************************************
-}
560

561 562 563
zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
564

565
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
566
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
567

568 569
zonkExpr env (HsVar (L l id))
  = return (HsVar (L l (zonkIdOcc env id)))
570

571
zonkExpr _ (HsIPVar id)
572
  = return (HsIPVar id)
573

Adam Gundry's avatar
Adam Gundry committed
574 575 576
zonkExpr _ (HsOverLabel l)
  = return (HsOverLabel l)

577
zonkExpr env (HsLit (HsRat f ty))
ian@well-typed.com's avatar
ian@well-typed.com committed
578 579
  = do new_ty <- zonkTcTypeToType env ty
       return (HsLit (HsRat f new_ty))
sof's avatar
sof committed
580

Ian Lynagh's avatar
Ian Lynagh committed
581
zonkExpr _ (HsLit lit)
582
  = return (HsLit lit)
583 584

zonkExpr env (HsOverLit lit)
585 586
  = do  { lit' <- zonkOverLit env lit
        ; return (HsOverLit lit') }
587

588
zonkExpr env (HsLam matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
589 590
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLam new_matches)
591

592
zonkExpr env (HsLamCase arg matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
593 594 595
  = do new_arg <- zonkTcTypeToType env arg
       new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLamCase new_arg new_matches)
596

597
zonkExpr env (HsApp e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
598 599 600
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (HsApp new_e1 new_e2)
601

gmainland's avatar
gmainland committed
602 603 604
zonkExpr _ e@(HsRnBracketOut _ _)
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

605
zonkExpr env (HsTcBracketOut body bs)
ian@well-typed.com's avatar
ian@well-typed.com committed
606
  = do bs' <- mapM zonk_b bs
607
       return (HsTcBracketOut body bs')
608
  where
609 610
    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
                                      return (PendingTcSplice n e')
gmainland's avatar
gmainland committed
611

612 613
zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE s)
614 615

zonkExpr env (OpApp e1 op fixity e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
616 617 618 619
  = 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)
620

621
zonkExpr env (NegApp expr op)
622 623
  = do (env', new_op) <- zonkSyntaxExpr env op
       new_expr <- zonkLExpr env' expr
ian@well-typed.com's avatar
ian@well-typed.com committed
624
       return (NegApp new_expr new_op)
625

626
zonkExpr env (HsPar e)
ian@well-typed.com's avatar
ian@well-typed.com committed
627 628
  = do new_e <- zonkLExpr env e
       return (HsPar new_e)
629 630

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

zonkExpr env (SectionR op expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
636 637 638
  = do new_op   <- zonkLExpr env op
       new_expr <- zonkLExpr env expr
       return (SectionR new_op new_expr)
639

640 641 642 643
zonkExpr env (ExplicitTuple tup_args boxed)
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
       ; return (ExplicitTuple new_tup_args boxed) }
  where
644 645 646 647
    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')) }
648

649
zonkExpr env (HsCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
650 651 652
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLExpr ms
       return (HsCase new_expr new_ms)
653

654 655 656 657 658 659 660 661 662 663 664 665
zonkExpr env (HsIf Nothing e1 e2 e3)
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       new_e3 <- zonkLExpr env e3
       return (HsIf Nothing new_e1 new_e2 new_e3)

zonkExpr env (HsIf (Just fun) e1 e2 e3)
  = do (env1, new_fun) <- zonkSyntaxExpr env fun
       new_e1 <- zonkLExpr env1 e1
       new_e2 <- zonkLExpr env1 e2
       new_e3 <- zonkLExpr env1 e3
       return (HsIf (Just new_fun) new_e1 new_e2 new_e3)
666

667 668 669
zonkExpr env (HsMultiIf ty alts)
  = do { alts' <- mapM (wrapLocM zonk_alt) alts
       ; ty'   <- zonkTcTypeToType env ty
670
       ; return $ HsMultiIf ty' alts' }
671
  where zonk_alt (GRHS guard expr)
672
          = do { (env', guard') <- zonkStmts env zonkLExpr guard
673
               ; expr'          <- zonkLExpr env' expr
674
               ; return $ GRHS guard' expr' }
675

676
zonkExpr env (HsLet (L l binds) expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
677 678
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_expr <- zonkLExpr new_env expr
679
       return (HsLet (L l new_binds) new_expr)
680

681
zonkExpr env (HsDo do_or_lc (L l stmts) ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
682 683
  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
       new_ty <- zonkTcTypeToType env ty
684
       return (HsDo do_or_lc (L l new_stmts) new_ty)
685

686
zonkExpr env (ExplicitList ty wit exprs)
687 688 689
  = do (env1, new_wit) <- zonkWit env wit
       new_ty <- zonkTcTypeToType env1 ty
       new_exprs <- zonkLExprs env1 exprs
ian@well-typed.com's avatar
ian@well-typed.com committed
690
       return (ExplicitList new_ty new_wit new_exprs)
691 692
   where zonkWit env Nothing    = return (env, Nothing)
         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
693 694

zonkExpr env (ExplicitPArr ty exprs)
ian@well-typed.com's avatar
ian@well-typed.com committed
695 696 697
  = do new_ty <- zonkTcTypeToType env ty
       new_exprs <- zonkLExprs env exprs
       return (ExplicitPArr new_ty new_exprs)
698

699
zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds })
700 701
  = do  { new_con_expr <- zonkExpr env con_expr
        ; new_rbinds   <- zonkRecFields env rbinds
702 703
        ; return (expr { rcon_con_expr = new_con_expr
                       , rcon_flds = new_rbinds }) }
704

705 706 707
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 })
708 709 710
  = do  { new_expr    <- zonkLExpr env expr
        ; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
        ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
711
        ; new_rbinds  <- zonkRecUpdFields env rbinds
Matthew Pickering's avatar
Matthew Pickering committed
712
        ; (_, new_recwrap) <- zonkCoFn env req_wrap
713 714 715
        ; 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 }) }
716

717
zonkExpr env (ExprWithTySigOut e ty)
718 719 720
  = do { e' <- zonkLExpr env e
       ; return (ExprWithTySigOut e' ty) }

721
zonkExpr env (ArithSeq expr wit info)
722 723 724
  = do (env1, new_wit) <- zonkWit env wit
       new_expr <- zonkExpr env expr
       new_info <- zonkArithSeq env1 info
ian@well-typed.com's avatar
ian@well-typed.com committed
725
       return (ArithSeq new_expr new_wit new_info)
726 727
   where zonkWit env Nothing    = return (env, Nothing)
         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
728

729
zonkExpr env (PArrSeq expr info)
ian@well-typed.com's avatar
ian@well-typed.com committed
730 731 732
  = do new_expr <- zonkExpr env expr
       new_info <- zonkArithSeq env info
       return (PArrSeq new_expr new_info)
733

Alan Zimmerman's avatar
Alan Zimmerman committed
734
zonkExpr env (HsSCC src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
735
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
736
       return (HsSCC src lbl new_expr)
737

738
zonkExpr env (HsTickPragma src info srcInfo expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
739
  = do new_expr <- zonkLExpr env expr
740
       return (HsTickPragma src info srcInfo new_expr)
andy@galois.com's avatar
andy@galois.com committed
741

742
-- hdaume: core annotations
Alan Zimmerman's avatar
Alan Zimmerman committed
743
zonkExpr env (HsCoreAnn src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
744
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
745
       return (HsCoreAnn src lbl new_expr)
746

747
-- arrow notation extensions
748
zonkExpr env (HsProc pat body)
749 750 751
  = do  { (env1, new_pat) <- zonkPat env pat
        ; new_body <- zonkCmdTop env1 body
        ; return (HsProc new_pat new_body) }
752

753 754 755 756
-- StaticPointers extension
zonkExpr env (HsStatic expr)
  = HsStatic <$> zonkLExpr env expr

757
zonkExpr env (HsWrap co_fn expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
758 759 760
  = do (env1, new_co_fn) <- zonkCoFn env co_fn
       new_expr <- zonkExpr env1 expr
       return (HsWrap new_co_fn new_expr)
761

762 763
zonkExpr _ (HsUnboundVar v)
  = return (HsUnboundVar v)
764

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

Ian Lynagh's avatar
Ian Lynagh committed
768
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
769

770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803
-------------------------------------------------------------------------
{-
Note [Skolems in zonkSyntaxExpr]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider rebindable syntax with something like

  (>>=) :: (forall x. blah) -> (forall y. blah') -> blah''

The x and y become skolems that are in scope when type-checking the
arguments to the bind. This means that we must extend the ZonkEnv with
these skolems when zonking the arguments to the bind. But the skolems
are different between the two arguments, and so we should theoretically
carry around different environments to use for the different arguments.

However, this becomes a logistical nightmare, especially in dealing with
the more exotic Stmt forms. So, we simplify by making the critical
assumption that the uniques of the skolems are different. (This assumption
is justified by the use of newUnique in TcMType.instSkolTyCoVarX.)
Now, we can safely just extend one environment.
-}

-- See Note [Skolems in zonkSyntaxExpr]
zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr TcId
               -> TcM (ZonkEnv, SyntaxExpr Id)
zonkSyntaxExpr env (SyntaxExpr { syn_expr      = expr
                               , syn_arg_wraps = arg_wraps
                               , syn_res_wrap  = res_wrap })
  = do { (env0, res_wrap')  <- zonkCoFn env res_wrap
       ; expr'              <- zonkExpr env0 expr
       ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps
       ; return (env1, SyntaxExpr { syn_expr      = expr'
                                  , syn_arg_wraps = arg_wraps'
                                  , syn_res_wrap  = res_wrap' }) }

804 805 806 807 808 809 810
-------------------------------------------------------------------------

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
811 812 813 814
zonkCmd env (HsCmdWrap w cmd)
  = do { (env1, w') <- zonkCoFn env w
       ; cmd' <- zonkCmd env1 cmd
       ; return (HsCmdWrap w' cmd') }
815
zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
ian@well-typed.com's avatar
ian@well-typed.com committed
816 817 818 819
  = 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)
820 821

zonkCmd env (HsCmdArrForm op fixity args)
ian@well-typed.com's avatar
ian@well-typed.com committed
822 823 824
  = do new_op <- zonkLExpr env op
       new_args <- mapM (zonkCmdTop env) args
       return (HsCmdArrForm new_op fixity new_args)
825 826

zonkCmd env (HsCmdApp c e)
ian@well-typed.com's avatar
ian@well-typed.com committed
827 828 829
  = do new_c <- zonkLCmd env c
       new_e <- zonkLExpr env e
       return (HsCmdApp new_c new_e)
830 831

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

835
zonkCmd env (HsCmdPar c)
ian@well-typed.com's avatar
ian@well-typed.com committed
836 837
  = do new_c <- zonkLCmd env c
       return (HsCmdPar new_c)
838 839

zonkCmd env (HsCmdCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
840 841 842
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLCmd ms
       return (HsCmdCase new_expr new_ms)
843 844

zonkCmd env (HsCmdIf eCond ePred cThen cElse)
845 846 847 848
  = do { (env1, new_eCond) <- zonkWit env eCond
       ; new_ePred <- zonkLExpr env1 ePred
       ; new_cThen <- zonkLCmd env1 cThen
       ; new_cElse <- zonkLCmd env1 cElse
849
       ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
850 851 852
  where
    zonkWit env Nothing  = return (env, Nothing)
    zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w
853

854
zonkCmd env (HsCmdLet (L l binds) cmd)
ian@well-typed.com's avatar
ian@well-typed.com committed
855 856
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_cmd <- zonkLCmd new_env cmd
857
       return (HsCmdLet (L l new_binds) new_cmd)
858

859
zonkCmd env (HsCmdDo (L l stmts) ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
860 861
  = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
       new_ty <- zonkTcTypeToType env ty
862
       return (HsCmdDo (L l new_stmts) new_ty)
863 864 865 866 867





868 869 870
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd

Ian Lynagh's avatar
Ian Lynagh committed
871
zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
872
zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
ian@well-typed.com's avatar
ian@well-typed.com committed
873 874 875 876 877
  = 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)
878

879
-------------------------------------------------------------------------
880
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
881
zonkCoFn env WpHole   = return (env, WpHole)
882
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
883 884
                                    ; (env2, c2') <- zonkCoFn env1 c2
                                    ; return (env2, WpCompose c1' c2') }
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
885 886 887 888
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') }
889
zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co
890
                              ; return (env, WpCast co') }
891
zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
892 893
                                 ; return (env', WpEvLam ev') }
zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg
894
                                 ; return (env, WpEvApp arg') }
895
zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
dreixel's avatar
dreixel committed
896
                              do { (env', tv') <- zonkTyBndrX env tv
897
                                 ; return (env', WpTyLam tv') }
898
zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToType env ty
899
                                 ; return (env, WpTyApp ty') }
900
zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs
901
                                 ; return (env1, WpLet bs') }
902

903 904
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
905
zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })