TcHsSyn.hs 68.6 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
{-# LANGUAGE CPP, TupleSections #-}
13

14
module TcHsSyn (
15
        -- * Extracting types from HsSyn
16
        hsLitType, hsLPatType, hsPatType,
17 18 19

        -- * Other HsSyn functions
        mkHsDictLet, mkHsApp,
20
        mkHsAppTy, mkHsCaseAlt,
21
        shortCutLit, hsOverLitName,
22
        conLikeResTy,
23

24
        -- * re-exported from TcMonad
25 26
        TcId, TcIdSet,

27 28 29
        -- * Zonking
        -- | For a description of "zonking", see Note [What is zonking?]
        -- in TcMType
30
        zonkTopDecls, zonkTopExpr, zonkTopLExpr,
31
        zonkTopBndrs, zonkTyBndrsX,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
32
        zonkTyVarBindersX, zonkTyVarBinderX,
33
        emptyZonkEnv, mkEmptyZonkEnv,
34
        zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
35
        zonkCoToCo, zonkSigType,
conal's avatar
conal committed
36
        zonkEvBinds,
37 38
  ) where

39
#include "HsVersions.h"
40

41
import HsSyn
42
import Id
43
import IdInfo
44
import TcRnMonad
45
import PrelNames
46
import TcType
47
import TcMType
48
import TcEvidence
49
import TysPrim
50
import TyCon   ( isUnboxedTupleTyCon )
51
import TysWiredIn
dreixel's avatar
dreixel committed
52
import Type
53
import Coercion
54
import ConLike
55
import DataCon
niteria's avatar
niteria committed
56
import HscTypes
57
import Name
niteria's avatar
niteria committed
58
import NameEnv
59
import Var
60
import VarEnv
61
import DynFlags
62
import Literal
63 64 65
import BasicTypes
import Maybes
import SrcLoc
sof's avatar
sof committed
66
import Bag
sof's avatar
sof committed
67
import Outputable
68
import Util
69
import UniqFM
70

71 72
import Control.Monad
import Data.List  ( partition )
73
import Control.Arrow ( second )
74

Austin Seipp's avatar
Austin Seipp committed
75 76 77
{-
************************************************************************
*                                                                      *
78
       Extracting the type from HsSyn
Austin Seipp's avatar
Austin Seipp committed
79 80
*                                                                      *
************************************************************************
81

Austin Seipp's avatar
Austin Seipp committed
82 83
-}

84 85 86
hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat

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

hsLitType :: HsLit -> TcType
110 111 112 113
hsLitType (HsChar _ _)       = charTy
hsLitType (HsCharPrim _ _)   = charPrimTy
hsLitType (HsString _ _)     = stringTy
hsLitType (HsStringPrim _ _) = addrPrimTy
114
hsLitType (HsInt _)          = intTy
115 116 117 118 119 120 121 122
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
123

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

126
shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr TcId)
127 128 129
shortCutLit dflags (HsIntegral int@(IL src neg i)) ty
  | isIntTy ty  && inIntRange  dflags i = Just (HsLit (HsInt int))
  | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i))
130
  | isIntegerTy ty = Just (HsLit (HsInteger src i ty))
131
  | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty
132 133 134 135 136
        -- 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
137

138
shortCutLit _ (HsFractional f) ty
139 140
  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim f))
  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
141 142
  | otherwise     = Nothing

143 144
shortCutLit _ (HsIsString src s) ty
  | isStringTy ty = Just (HsLit (HsString src s))
145 146 147
  | otherwise     = Nothing

mkLit :: DataCon -> HsLit -> HsExpr Id
148
mkLit con lit = HsApp (nlHsDataCon con) (nlHsLit lit)
149 150 151 152 153 154 155

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

Austin Seipp's avatar
Austin Seipp committed
157 158 159
{-
************************************************************************
*                                                                      *
160
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
Austin Seipp's avatar
Austin Seipp committed
161 162
*                                                                      *
************************************************************************
163

164 165
The rest of the zonking is done *after* typechecking.
The main zonking pass runs over the bindings
166 167 168

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

171 172
The type variables are converted by binding mutable tyvars to immutable ones
and then zonking as normal.
173

174 175 176
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
177

178
It's all pretty boring stuff, because HsSyn is such a large type, and
179
the environment manipulation is tiresome.
Austin Seipp's avatar
Austin Seipp committed
180
-}
181

182
-- Confused by zonking? See Note [What is zonking?] in TcMType.
183
type UnboundTyVarZonker = TcTyVar -> TcM Type
184
        -- How to zonk an unbound type variable
185 186 187
        -- The TcTyVar is
        --     (a) a MetaTv
        --     (b) Flexi and
Gabor Greif's avatar
Gabor Greif committed
188
        --     (c) its kind is already zonked
dreixel's avatar
dreixel committed
189 190
        -- Note [Zonking the LHS of a RULE]

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
194 195 196 197 198 199 200 201 202 203 204 205
-- 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.
206 207
--
-- Confused by zonking? See Note [What is zonking?] in TcMType.
208 209
data ZonkEnv
  = ZonkEnv
dreixel's avatar
dreixel committed
210
      UnboundTyVarZonker
211 212
      (TyCoVarEnv TyVar)
      (IdEnv      Var)         -- What variables are in scope
213 214 215 216 217 218 219
        -- 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
220
  ppr (ZonkEnv _ _ty_env var_env) = pprUFM var_env (vcat . map ppr)
221 222


223
-- The EvBinds have to already be zonked, but that's usually the case.
Ian Lynagh's avatar
Ian Lynagh committed
224
emptyZonkEnv :: ZonkEnv
225 226 227 228
emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping

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

230 231 232 233 234
-- | 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
235
  = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
236 237 238 239 240 241 242 243 244 245 246 247
  -- 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
248

dreixel's avatar
dreixel committed
249
extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
250
extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id
dreixel's avatar
dreixel committed
251
  = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
252

dreixel's avatar
dreixel committed
253
extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
254 255
extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) tv
  = ZonkEnv zonk_ty (extendVarEnv ty_env tv tv) id_env
dreixel's avatar
dreixel committed
256 257

setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
258 259
setZonkType (ZonkEnv _ ty_env id_env) zonk_ty
  = ZonkEnv zonk_ty ty_env id_env
260

niteria's avatar
niteria committed
261 262 263 264 265
zonkEnvIds :: ZonkEnv -> TypeEnv
zonkEnvIds (ZonkEnv _ _ id_env) =
  mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env]
  -- It's OK to use nonDetEltsUFM here because we forget the ordering
  -- immediately by creating a TypeEnv
266 267

zonkIdOcc :: ZonkEnv -> TcId -> Id
268
-- Ids defined in this module should be in the envt;
269 270
-- ignore others.  (Actually, data constructors are also
-- not LocalVars, even when locally defined, but that is fine.)
271 272
-- (Also foreign-imported things aren't currently in the ZonkEnv;
--  that's ok because they don't need zonking.)
273 274
--
-- Actually, Template Haskell works in 'chunks' of declarations, and
275
-- an earlier chunk won't be in the 'env' that the zonking phase
276
-- carries around.  Instead it'll be in the tcg_gbl_env, already fully
277
-- zonked.  There's no point in looking it up there (except for error
278 279 280 281
-- 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
282
-- 'main' is done as a separate chunk.
283 284 285
zonkIdOcc (ZonkEnv _zonk_ty _ty_env id_env) id
  | isLocalVar id = lookupVarEnv id_env id `orElse`
                    id
286
  | otherwise     = id
287

Ian Lynagh's avatar
Ian Lynagh committed
288
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
289
zonkIdOccs env ids = map (zonkIdOcc env) ids
290

291
-- zonkIdBndr is used *after* typechecking to get the Id's type
292
-- to its final form.  The TyVarEnv give
293
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
294 295 296 297 298 299
zonkIdBndr env v
  = do ty' <- zonkTcTypeToType env (idType v)
       ensureNotLevPoly ty'
         (text "In the type of binder" <+> quotes (ppr v))

       return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty'))
300 301

zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
302
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
303 304 305

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

307 308 309
zonkFieldOcc :: ZonkEnv -> FieldOcc TcId -> TcM (FieldOcc Id)
zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel

310
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
311
zonkEvBndrsX = mapAccumLM zonkEvBndrX
312 313 314 315 316

zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
-- Works for dictionaries and coercions
zonkEvBndrX env var
  = do { var' <- zonkEvBndr env var
317
       ; return (extendZonkEnv env [var'], var') }
318 319 320 321

zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
-- Works for dictionaries and coercions
-- Does not extend the ZonkEnv
322
zonkEvBndr env var
323
  = do { let var_ty = varType var
324
       ; ty <-
325 326
           {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
           zonkTcTypeToType env var_ty
dreixel's avatar
dreixel committed
327
       ; return (setVarType var ty) }
328

329 330 331 332 333 334
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
335

Simon Peyton Jones's avatar
Simon Peyton Jones committed
336
zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
337
zonkTyBndrsX = mapAccumLM zonkTyBndrX
dreixel's avatar
dreixel committed
338

Simon Peyton Jones's avatar
Simon Peyton Jones committed
339
zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
340 341
-- 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
342
zonkTyBndrX env tv
343 344
  = ASSERT( isImmutableTyVar tv )
    do { ki <- zonkTcTypeToType env (tyVarKind tv)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
345
               -- Internal names tidy up better, for iface files.
346 347
       ; let tv' = mkTyVar (tyVarName tv) ki
       ; return (extendTyZonkEnv1 env tv', tv') }
348

Simon Peyton Jones's avatar
Simon Peyton Jones committed
349 350 351
zonkTyVarBindersX :: ZonkEnv -> [TyVarBndr TcTyVar vis]
                             -> TcM (ZonkEnv, [TyVarBndr TyVar vis])
zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX
352

Simon Peyton Jones's avatar
Simon Peyton Jones committed
353 354 355 356
zonkTyVarBinderX :: ZonkEnv -> TyVarBndr TcTyVar vis
                            -> TcM (ZonkEnv, TyVarBndr TyVar vis)
-- Takes a TcTyVar and guarantees to return a TyVar
zonkTyVarBinderX env (TvBndr tv vis)
357
  = do { (env', tv') <- zonkTyBndrX env tv
358
       ; return (env', TvBndr tv' vis) }
359

360
zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
361 362
zonkTopExpr e = zonkExpr emptyZonkEnv e

363 364 365
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

366
zonkTopDecls :: Bag EvBind
Matthew Pickering's avatar
Matthew Pickering committed
367
             -> LHsBinds TcId
368
             -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
niteria's avatar
niteria committed
369
             -> TcM (TypeEnv,
370
                     Bag EvBind,
cactus's avatar
cactus committed
371
                     LHsBinds Id,
372 373 374 375
                     [LForeignDecl Id],
                     [LTcSpecPrag],
                     [LRuleDecl    Id],
                     [LVectDecl    Id])
376
zonkTopDecls ev_binds binds rules vects imp_specs fords
377
  = do  { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
378
        ; (env2, binds') <- zonkRecMonoBinds env1 binds
379 380 381
                        -- Top level is implicitly recursive
        ; rules' <- zonkRules env2 rules
        ; vects' <- zonkVects env2 vects
382
        ; specs' <- zonkLTcSpecPrags env2 imp_specs
383 384
        ; fords' <- zonkForeignExports env2 fords
        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') }
385 386

---------------------------------------------
387 388 389 390
zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
zonkLocalBinds env EmptyLocalBinds
  = return (env, EmptyLocalBinds)

391 392 393
zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
  = panic "zonkLocalBinds" -- Not in typechecker output

394 395
zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs))
  = do  { (env1, new_binds) <- go env binds
396 397
        ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }
  where
398
    go env []
399
      = return (env, [])
400 401 402
    go env ((r,b):bs)
      = do { (env1, b')  <- zonkRecMonoBinds env b
           ; (env2, bs') <- go env1 bs
403
           ; return (env2, (r,b'):bs') }
404

ian@well-typed.com's avatar
ian@well-typed.com committed
405 406
zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do
    new_binds <- mapM (wrapLocM zonk_ip_bind) binds
407
    let
408
        env1 = extendIdZonkEnvRec env [ n | L _ (IPBind (Right n) _) <- new_binds]
ian@well-typed.com's avatar
ian@well-typed.com committed
409
    (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
410
    return (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
411
  where
412
    zonk_ip_bind (IPBind n e)
ian@well-typed.com's avatar
ian@well-typed.com committed
413 414 415
        = do n' <- mapIPNameTc (zonkIdBndr env) n
             e' <- zonkLExpr env e
             return (IPBind n' e')
416

417
---------------------------------------------
418 419
zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
zonkRecMonoBinds env binds
420
 = fixM (\ ~(_, new_binds) -> do
421
        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)
422
        ; binds' <- zonkMonoBinds env1 binds
423 424
        ; return (env1, binds') })

425
---------------------------------------------
426 427
zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
cactus's avatar
cactus committed
428

429 430
zonk_lbind :: ZonkEnv -> LHsBind TcId -> TcM (LHsBind Id)
zonk_lbind env = wrapLocM (zonk_bind env)
431

432 433
zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
434 435 436 437
  = 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 }) }
438

439
zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
440 441 442 443
  = do { new_var  <- zonkIdBndr env var
       ; new_expr <- zonkLExpr env expr
       ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }

444 445
zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
                            , fun_co_fn = co_fn })
446 447
  = do { new_var <- zonkIdBndr env var
       ; (env1, new_co_fn) <- zonkCoFn env co_fn
448
       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
449 450 451
       ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
                      , fun_co_fn = new_co_fn }) }

452 453 454 455
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                        , abs_ev_binds = ev_binds
                        , abs_exports = exports
                        , abs_binds = val_binds })
456
  = ASSERT( all isImmutableTyVar tyvars )
dreixel's avatar
dreixel committed
457 458
    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
459
       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
460
       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
461 462
         do { let env3 = extendIdZonkEnvRec env2
                           (collectHsBindsBinders new_val_binds)
463
            ; new_val_binds <- zonkMonoBinds env3 val_binds
464 465
            ; new_exports   <- mapM (zonkExport env3) exports
            ; return (new_val_binds, new_exports) }
dreixel's avatar
dreixel committed
466 467
       ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
                          , abs_ev_binds = new_ev_binds
468
                          , abs_exports = new_exports, abs_binds = new_val_bind }) }
sof's avatar
sof committed
469
  where
470
    zonkExport env (ABE{ abe_wrap = wrap
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
471
                       , abe_poly = poly_id
472
                       , abe_mono = mono_id, abe_prags = prags })
ian@well-typed.com's avatar
ian@well-typed.com committed
473 474 475
        = do new_poly_id <- zonkIdBndr env poly_id
             (_, new_wrap) <- zonkCoFn env wrap
             new_prags <- zonkSpecPrags env prags
476
             return (ABE{ abe_wrap = new_wrap
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
477
                        , abe_poly = new_poly_id
ian@well-typed.com's avatar
ian@well-typed.com committed
478 479
                        , abe_mono = zonkIdOcc env mono_id
                        , abe_prags = new_prags })
480

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
481 482 483 484 485 486 487 488 489
zonk_bind env outer_bind@(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    = lbind })
  | L bind_loc bind@(FunBind { fun_id      = L loc local
                             , fun_matches = ms
                             , fun_co_fn   = co_fn }) <- lbind
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
490 491 492 493
  = 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
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
494 495 496 497 498 499 500 501 502 503
           -- Inline zonk_bind (FunBind ...) because we wish to skip
           -- the check for representation-polymorphic binders. The
           -- local binder in the FunBind in an AbsBindsSig is never actually
           -- bound in Core -- indeed, that's the whole point of AbsBindsSig.
           -- just calling zonk_bind causes #11405.
       ; new_local           <- updateVarTypeM (zonkTcTypeToType env2) local
       ; (env3, new_co_fn)   <- zonkCoFn env2 co_fn
       ; new_ms              <- zonkMatchGroup env3 zonkLExpr ms
           -- If there is a representation polymorphism problem, it will
           -- be caught here:
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
504 505
       ; new_poly_id         <- zonkIdBndr env2 poly
       ; new_prags           <- zonkSpecPrags env2 prags
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
506 507 508
       ; let new_val_bind = L bind_loc (bind { fun_id      = L loc new_local
                                             , fun_matches = new_ms
                                             , fun_co_fn   = new_co_fn })
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
509 510 511 512 513 514 515
       ; 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  }) }

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
516 517 518
  | otherwise
  = pprPanic "zonk_bind" (ppr outer_bind)

519 520 521 522
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
523 524
  = do { id' <- zonkIdBndr env id
       ; details' <- zonkPatSynDetails env details
525
       ; (env1, lpat') <- zonkPat env lpat
cactus's avatar
cactus committed
526
       ; (_env2, dir') <- zonkPatSynDir env1 dir
527 528 529 530 531
       ; return $ PatSynBind $
                  bind { psb_id = L loc id'
                       , psb_args = details'
                       , psb_def = lpat'
                       , psb_dir = dir' } }
cactus's avatar
cactus committed
532 533 534 535 536 537 538 539 540

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)
541 542 543
zonkPatSynDir env (ExplicitBidirectional mg) = do
    mg' <- zonkMatchGroup env zonkLExpr mg
    return (env, ExplicitBidirectional mg')
cactus's avatar
cactus committed
544

545 546
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
547
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
548
                                       ; return (SpecPrags ps') }
549 550 551 552

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
553
  where
554
    zonk_prag (L loc (SpecPrag id co_fn inl))
555 556
        = do { (_, co_fn') <- zonkCoFn env co_fn
             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
557

Austin Seipp's avatar
Austin Seipp committed
558 559 560
{-
************************************************************************
*                                                                      *
561
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
562 563 564
*                                                                      *
************************************************************************
-}
565

566
zonkMatchGroup :: ZonkEnv
567 568
               -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
               -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id)))
569 570
zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys
                             , mg_res_ty = res_ty, mg_origin = origin })
571 572 573
  = do  { ms' <- mapM (zonkMatch env zBody) ms
        ; arg_tys' <- zonkTcTypeToTypes env arg_tys
        ; res_ty'  <- zonkTcTypeToType env res_ty
574 575
        ; return (MG { mg_alts = L l ms', mg_arg_tys = arg_tys'
                     , mg_res_ty = res_ty', mg_origin = origin }) }
576

577
zonkMatch :: ZonkEnv
578 579
          -> (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
580
zonkMatch env zBody (L loc (Match mf pats _ grhss))
581 582
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
Alan Zimmerman's avatar
Alan Zimmerman committed
583
        ; return (L loc (Match mf new_pats Nothing new_grhss)) }
584

585
-------------------------------------------------------------------------
586
zonkGRHSs :: ZonkEnv
587 588
          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
          -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))
589

590
zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
591
    (new_env, new_binds) <- zonkLocalBinds env binds
592
    let
593
        zonk_grhs (GRHS guarded rhs)
ian@well-typed.com's avatar
ian@well-typed.com committed
594 595 596 597
          = 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
598
    return (GRHSs new_grhss (L l new_binds))
599

Austin Seipp's avatar
Austin Seipp committed
600 601 602
{-
************************************************************************
*                                                                      *
603
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
604 605 606
*                                                                      *
************************************************************************
-}
607

608 609 610
zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
611

612
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
613
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
614

615
zonkExpr env (HsVar (L l id))
Ben Gamari's avatar
Ben Gamari committed
616
  = ASSERT2( isNothing (isDataConId_maybe id), ppr id )
617 618 619
    return (HsVar (L l (zonkIdOcc env id)))

zonkExpr _ e@(HsConLikeOut {}) = return e
620

621
zonkExpr _ (HsIPVar id)
622
  = return (HsIPVar id)
623

624
zonkExpr _ e@HsOverLabel{} = return e
Adam Gundry's avatar
Adam Gundry committed
625

626
zonkExpr env (HsLit (HsRat f ty))
ian@well-typed.com's avatar
ian@well-typed.com committed
627 628
  = do new_ty <- zonkTcTypeToType env ty
       return (HsLit (HsRat f new_ty))
sof's avatar
sof committed
629

Ian Lynagh's avatar
Ian Lynagh committed
630
zonkExpr _ (HsLit lit)
631
  = return (HsLit lit)
632 633

zonkExpr env (HsOverLit lit)
634 635
  = do  { lit' <- zonkOverLit env lit
        ; return (HsOverLit lit') }
636

637
zonkExpr env (HsLam matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
638 639
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLam new_matches)
640

Simon Peyton Jones's avatar
Simon Peyton Jones committed
641 642 643
zonkExpr env (HsLamCase matches)
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLamCase new_matches)
644

645
zonkExpr env (HsApp e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
646 647 648
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (HsApp new_e1 new_e2)
649

650 651 652 653 654
zonkExpr env (HsAppTypeOut e t)
  = do new_e <- zonkLExpr env e
       return (HsAppTypeOut new_e t)
       -- NB: the type is an HsType; can't zonk that!

gmainland's avatar
gmainland committed
655 656 657
zonkExpr _ e@(HsRnBracketOut _ _)
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

658
zonkExpr env (HsTcBracketOut body bs)
ian@well-typed.com's avatar
ian@well-typed.com committed
659
  = do bs' <- mapM zonk_b bs
660
       return (HsTcBracketOut body bs')
661
  where
662 663
    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
                                      return (PendingTcSplice n e')
gmainland's avatar
gmainland committed
664

665 666
zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE s)
667 668

zonkExpr env (OpApp e1 op fixity e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
669 670 671 672
  = 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)
673

674
zonkExpr env (NegApp expr op)
675 676
  = do (env', new_op) <- zonkSyntaxExpr env op
       new_expr <- zonkLExpr env' expr
ian@well-typed.com's avatar
ian@well-typed.com committed
677
       return (NegApp new_expr new_op)
678

679
zonkExpr env (HsPar e)
ian@well-typed.com's avatar
ian@well-typed.com committed
680 681
  = do new_e <- zonkLExpr env e
       return (HsPar new_e)
682 683

zonkExpr env (SectionL expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
684 685 686
  = do new_expr <- zonkLExpr env expr
       new_op   <- zonkLExpr env op
       return (SectionL new_expr new_op)
687 688

zonkExpr env (SectionR op expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
689 690 691
  = do new_op   <- zonkLExpr env op
       new_expr <- zonkLExpr env expr
       return (SectionR new_op new_expr)
692

693 694 695 696
zonkExpr env (ExplicitTuple tup_args boxed)
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
       ; return (ExplicitTuple new_tup_args boxed) }
  where
697 698 699 700
    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')) }
701

702 703 704 705 706
zonkExpr env (ExplicitSum alt arity expr args)
  = do new_args <- mapM (zonkTcTypeToType env) args
       new_expr <- zonkLExpr env expr
       return (ExplicitSum alt arity new_expr new_args)

707
zonkExpr env (HsCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
708 709 710
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLExpr ms
       return (HsCase new_expr new_ms)
711

712 713 714 715 716 717 718 719 720 721 722 723
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)
724

725 726 727
zonkExpr env (HsMultiIf ty alts)
  = do { alts' <- mapM (wrapLocM zonk_alt) alts
       ; ty'   <- zonkTcTypeToType env ty
728
       ; return $ HsMultiIf ty' alts' }
729
  where zonk_alt (GRHS guard expr)
730
          = do { (env', guard') <- zonkStmts env zonkLExpr guard
731
               ; expr'          <- zonkLExpr env' expr
732
               ; return $ GRHS guard' expr' }
733

734
zonkExpr env (HsLet (L l binds) expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
735 736
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_expr <- zonkLExpr new_env expr
737
       return (HsLet (L l new_binds) new_expr)
738

739
zonkExpr env (HsDo do_or_lc (L l stmts) ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
740 741
  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
       new_ty <- zonkTcTypeToType env ty
742
       return (HsDo do_or_lc (L l new_stmts) new_ty)
743

744
zonkExpr env (ExplicitList ty wit exprs)
745 746 747
  = 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
748
       return (ExplicitList new_ty new_wit new_exprs)
749 750
   where zonkWit env Nothing    = return (env, Nothing)
         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
751 752

zonkExpr env (ExplicitPArr ty exprs)
ian@well-typed.com's avatar
ian@well-typed.com committed
753 754 755
  = do new_ty <- zonkTcTypeToType env ty
       new_exprs <- zonkLExprs env exprs
       return (ExplicitPArr new_ty new_exprs)
756

757
zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds })
758 759
  = do  { new_con_expr <- zonkExpr env con_expr
        ; new_rbinds   <- zonkRecFields env rbinds
760 761
        ; return (expr { rcon_con_expr = new_con_expr
                       , rcon_flds = new_rbinds }) }
762

763 764 765
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 })
766 767 768
  = do  { new_expr    <- zonkLExpr env expr
        ; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
        ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
769
        ; new_rbinds  <- zonkRecUpdFields env rbinds
Matthew Pickering's avatar
Matthew Pickering committed
770
        ; (_, new_recwrap) <- zonkCoFn env req_wrap
771 772 773
        ; 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 }) }
774

775
zonkExpr env (ExprWithTySigOut e ty)
776 777 778
  = do { e' <- zonkLExpr env e
       ; return (ExprWithTySigOut e' ty) }

779
zonkExpr env (ArithSeq expr wit info)
780 781 782
  = 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
783
       return (ArithSeq new_expr new_wit new_info)
784 785
   where zonkWit env Nothing    = return (env, Nothing)
         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
786

787
zonkExpr env (PArrSeq expr info)
ian@well-typed.com's avatar
ian@well-typed.com committed
788 789 790
  = do new_expr <- zonkExpr env expr
       new_info <- zonkArithSeq env info
       return (PArrSeq new_expr new_info)
791

Alan Zimmerman's avatar
Alan Zimmerman committed
792
zonkExpr env (HsSCC src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
793
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
794
       return (HsSCC src lbl new_expr)
795

796
zonkExpr env (HsTickPragma src info srcInfo expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
797
  = do new_expr <- zonkLExpr env expr
798
       return (HsTickPragma src info srcInfo new_expr)
andy@galois.com's avatar
andy@galois.com committed
799

800
-- hdaume: core annotations
Alan Zimmerman's avatar
Alan Zimmerman committed
801
zonkExpr env (HsCoreAnn src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
802
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
803
       return (HsCoreAnn src lbl new_expr)
804

805
-- arrow notation extensions
806
zonkExpr env (HsProc pat body)
807 808 809
  = do  { (env1, new_pat) <- zonkPat env pat
        ; new_body <- zonkCmdTop env1 body
        ; return (HsProc new_pat new_body) }
810

811
-- StaticPointers extension
812 813
zonkExpr env (HsStatic fvs expr)
  = HsStatic fvs <$> zonkLExpr env expr
814

815
zonkExpr env (HsWrap co_fn expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
816 817 818
  = do (env1, new_co_fn) <- zonkCoFn env co_fn
       new_expr <- zonkExpr env1 expr
       return (HsWrap new_co_fn new_expr)
819

820
zonkExpr _ e@(HsUnboundVar {}) = return e
821

Ian Lynagh's avatar
Ian Lynagh committed
822
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
823

824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857
-------------------------------------------------------------------------
{-
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' }) }

858 859 860 861 862 863 864
-------------------------------------------------------------------------

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
865 866 867 868
zonkCmd env (HsCmdWrap w cmd)
  = do { (env1, w') <- zonkCoFn env w
       ; cmd' <- zonkCmd env1 cmd
       ; return (HsCmdWrap w' cmd') }
869
zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
ian@well-typed.com's avatar
ian@well-typed.com committed
870 871 872 873
  = 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)
874

875
zonkCmd env (HsCmdArrForm op f fixity args)
ian@well-typed.com's avatar
ian@well-typed.com committed
876 877
  = do new_op <- zonkLExpr env op
       new_args <- mapM (zonkCmdTop env) args
878
       return (HsCmdArrForm new_op f fixity new_args)
879 880

zonkCmd env (HsCmdApp c e)
ian@well-typed.com's avatar
ian@well-typed.com committed
881 882 883
  = do new_c <- zonkLCmd env c
       new_e <- zonkLExpr env e
       return (HsCmdApp new_c new_e)
884 885

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

889
zonkCmd env (HsCmdPar c)
ian@well-typed.com's avatar
ian@well-typed.com committed
890 891
  = do new_c <- zonkLCmd env c
       return (HsCmdPar new_c)
892 893

zonkCmd env (HsCmdCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
894 895 896
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLCmd ms
       return (HsCmdCase new_expr new_ms)
897 898

zonkCmd env (HsCmdIf eCond ePred cThen cElse)
899 900 901 902
  = do { (env1, new_eCond) <- zonkWit env eCond
       ; new_ePred <- zonkLExpr env1 ePred
       ; new_cThen <- zonkLCmd env1 cThen
       ; new_cElse <- zonkLCmd env1 cElse
903