TcHsSyn.hs 72.5 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
        mkHsDictLet, mkHsApp,
16
        hsLitType, hsLPatType, hsPatType,
17
        mkHsAppTy, mkHsCaseAlt,
18 19
        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
        zonkTopDecls, zonkTopExpr, zonkTopLExpr,
29
        zonkTopBndrs, zonkTyBndrsX,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
30
        zonkTyVarBindersX, zonkTyVarBinderX,
31
        emptyZonkEnv, mkEmptyZonkEnv,
32
        zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
33
        zonkCoToCo, zonkSigType,
conal's avatar
conal committed
34
        zonkEvBinds,
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
35 36 37

        -- * Validity checking
        checkForRepresentationPolymorphism
38 39
  ) where

40
#include "HsVersions.h"
41

42
import HsSyn
43
import Id
44
import TcRnMonad
45
import PrelNames
46
import TcType
47
import TcMType
48
import TcEvidence
49 50
import TysPrim
import TysWiredIn
dreixel's avatar
dreixel committed
51
import Type
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
52
import TyCon
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 VarSet
61
import VarEnv
62
import DynFlags
63
import Literal
64 65 66
import BasicTypes
import Maybes
import SrcLoc
sof's avatar
sof committed
67
import Bag
sof's avatar
sof committed
68
import Outputable
69
import Util
70
import UniqFM
71

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

Austin Seipp's avatar
Austin Seipp committed
76 77 78
{-
************************************************************************
*                                                                      *
79
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
Austin Seipp's avatar
Austin Seipp committed
80 81
*                                                                      *
************************************************************************
82

83
Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
84
then something is wrong.
Austin Seipp's avatar
Austin Seipp committed
85 86
-}

87 88 89
hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat

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

112

113
hsLitType :: HsLit -> TcType
114 115 116 117 118 119 120 121 122 123 124 125 126
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
127

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

130
shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr TcId)
131 132 133 134 135
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))
136
  | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit i)) ty
137 138 139 140 141
        -- 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
142

143
shortCutLit _ (HsFractional f) ty
144 145
  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim f))
  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
146 147
  | otherwise     = Nothing

148 149
shortCutLit _ (HsIsString src s) ty
  | isStringTy ty = Just (HsLit (HsString src s))
150 151 152 153 154 155 156 157 158 159 160
  | 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
161

Austin Seipp's avatar
Austin Seipp committed
162 163 164
{-
************************************************************************
*                                                                      *
165
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
Austin Seipp's avatar
Austin Seipp committed
166 167
*                                                                      *
************************************************************************
168

169 170
The rest of the zonking is done *after* typechecking.
The main zonking pass runs over the bindings
171 172 173

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

176 177
The type variables are converted by binding mutable tyvars to immutable ones
and then zonking as normal.
178

179 180 181
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
182

183
It's all pretty boring stuff, because HsSyn is such a large type, and
184
the environment manipulation is tiresome.
Austin Seipp's avatar
Austin Seipp committed
185
-}
186

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

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


228
-- The EvBinds have to already be zonked, but that's usually the case.
Ian Lynagh's avatar
Ian Lynagh committed
229
emptyZonkEnv :: ZonkEnv
230 231 232 233
emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping

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

235 236 237 238 239
-- | 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
240
  = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
241 242 243 244 245 246 247 248 249 250 251 252
  -- 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
253

dreixel's avatar
dreixel committed
254
extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
255
extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id
dreixel's avatar
dreixel committed
256
  = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
257

dreixel's avatar
dreixel committed
258
extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
259 260
extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) tv
  = ZonkEnv zonk_ty (extendVarEnv ty_env tv tv) id_env
dreixel's avatar
dreixel committed
261 262

setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
263 264
setZonkType (ZonkEnv _ ty_env id_env) zonk_ty
  = ZonkEnv zonk_ty ty_env id_env
265

niteria's avatar
niteria committed
266 267 268 269 270
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
271 272

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

Ian Lynagh's avatar
Ian Lynagh committed
293
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
294
zonkIdOccs env ids = map (zonkIdOcc env) ids
295

296
-- zonkIdBndr is used *after* typechecking to get the Id's type
297
-- to its final form.  The TyVarEnv give
298 299
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
zonkIdBndr env id
ian@well-typed.com's avatar
ian@well-typed.com committed
300
  = do ty' <- zonkTcTypeToType env (idType id)
301 302
       ensureNotRepresentationPolymorphic ty'
         (text "In the type of binder" <+> quotes (ppr id))
303
       return (setIdType id ty')
304 305

zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
306
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
307 308 309

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

311 312 313
zonkFieldOcc :: ZonkEnv -> FieldOcc TcId -> TcM (FieldOcc Id)
zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel

314
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
315
zonkEvBndrsX = mapAccumLM zonkEvBndrX
316 317 318 319 320

zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
-- Works for dictionaries and coercions
zonkEvBndrX env var
  = do { var' <- zonkEvBndr env var
321
       ; return (extendZonkEnv env [var'], var') }
322 323 324 325

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

333 334 335 336 337 338
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
339

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

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
353 354 355
zonkTyVarBindersX :: ZonkEnv -> [TyVarBndr TcTyVar vis]
                             -> TcM (ZonkEnv, [TyVarBndr TyVar vis])
zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX
356

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

364
zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
365 366
zonkTopExpr e = zonkExpr emptyZonkEnv e

367 368 369
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

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

---------------------------------------------
391 392 393 394
zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
zonkLocalBinds env EmptyLocalBinds
  = return (env, EmptyLocalBinds)

395 396 397
zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
  = panic "zonkLocalBinds" -- Not in typechecker output

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

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

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

429
---------------------------------------------
430 431
zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
cactus's avatar
cactus committed
432

433 434
zonk_lbind :: ZonkEnv -> LHsBind TcId -> TcM (LHsBind Id)
zonk_lbind env = wrapLocM (zonk_bind env)
435

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

443
zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
444 445 446 447
  = do { new_var  <- zonkIdBndr env var
       ; new_expr <- zonkLExpr env expr
       ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }

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

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

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
485 486 487 488 489 490 491 492 493
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
494 495 496 497
  = 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
498 499 500 501 502 503 504 505 506 507
           -- 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
508 509
       ; new_poly_id         <- zonkIdBndr env2 poly
       ; new_prags           <- zonkSpecPrags env2 prags
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
510 511 512
       ; 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
513 514 515 516 517 518 519
       ; 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
520 521 522
  | otherwise
  = pprPanic "zonk_bind" (ppr outer_bind)

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

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)
545 546 547
zonkPatSynDir env (ExplicitBidirectional mg) = do
    mg' <- zonkMatchGroup env zonkLExpr mg
    return (env, ExplicitBidirectional mg')
cactus's avatar
cactus committed
548

549 550
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
551
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
552
                                       ; return (SpecPrags ps') }
553 554 555 556

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

Austin Seipp's avatar
Austin Seipp committed
562 563 564
{-
************************************************************************
*                                                                      *
565
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
566 567 568
*                                                                      *
************************************************************************
-}
569

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

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

589
-------------------------------------------------------------------------
590
zonkGRHSs :: ZonkEnv
591 592
          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
          -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))
593

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

Austin Seipp's avatar
Austin Seipp committed
604 605 606
{-
************************************************************************
*                                                                      *
607
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
608 609 610
*                                                                      *
************************************************************************
-}
611

612 613 614
zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
615

616
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
617
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
618

619 620
zonkExpr env (HsVar (L l id))
  = return (HsVar (L l (zonkIdOcc env id)))
621

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

Adam Gundry's avatar
Adam Gundry committed
625 626 627
zonkExpr _ (HsOverLabel l)
  = return (HsOverLabel l)

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

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

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

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

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

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

652 653 654 655 656
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
657 658 659
zonkExpr _ e@(HsRnBracketOut _ _)
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

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

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

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

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

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

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

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

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

704 705 706 707 708
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)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

822
zonkExpr _ e@(HsUnboundVar {}) = return e
823

Ian Lynagh's avatar
Ian Lynagh committed
824
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
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 858 859
-------------------------------------------------------------------------
{-
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' }) }

860 861 862 863 864 865 866
-------------------------------------------------------------------------

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

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

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

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

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

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

zonkCmd env (HsCmdIf eCond ePred cThen cElse)
901 902 903 904
  = do { (env1, new_eCond) <- zonkWit env eCond
       ; new_ePred <- zonkLExpr env1 ePred
       ; new_cThen <- zonkLCmd env1 cThen
       ; new_cElse <- zonkLCmd env1 cElse
905
       ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
906 907 908
  where
    zonkWit env Nothing  = return (env, Nothing)
    zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w