TcHsSyn.hs 68.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
{-# 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 22
        nlHsIntLit,
        shortCutLit, hsOverLitName,
23
        conLikeResTy,
24

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

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

40
#include "HsVersions.h"
41

42
import HsSyn
43
import Id
44
import IdInfo
45
import TcRnMonad
46
import PrelNames
47
import TcType
48
import TcMType
49
import TcEvidence
50
import TysPrim
51
import TyCon   ( isUnboxedTupleTyCon )
52
import TysWiredIn
dreixel's avatar
dreixel committed
53
import Type
54
import Coercion
55
import ConLike
56
import DataCon
niteria's avatar
niteria committed
57
import HscTypes
58
import Name
niteria's avatar
niteria committed
59
import NameEnv
60
import Var
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
       Extracting the type from HsSyn
Austin Seipp's avatar
Austin Seipp committed
80 81
*                                                                      *
************************************************************************
82

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

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

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

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

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

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

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

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

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

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

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

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

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

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

176 177 178
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
179

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

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

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


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

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

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

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

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

setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
260 261
setZonkType (ZonkEnv _ ty_env id_env) zonk_ty
  = ZonkEnv zonk_ty ty_env id_env
262

niteria's avatar
niteria committed
263 264 265 266 267
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
268 269

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

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

293
-- zonkIdBndr is used *after* typechecking to get the Id's type
294
-- to its final form.  The TyVarEnv give
295
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
296 297 298 299 300 301
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'))
302 303

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

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

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

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

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

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

331 332 333 334 335 336
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
337

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

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

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

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

362
zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
363 364
zonkTopExpr e = zonkExpr emptyZonkEnv e

365 366 367
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

614
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
615
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
616

617
zonkExpr env (HsVar (L l id))
618 619 620 621
  = ASSERT( isNothing (isDataConId_maybe id) )
    return (HsVar (L l (zonkIdOcc env id)))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

861 862 863 864 865 866 867
-------------------------------------------------------------------------

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

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

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

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

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

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

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

911
zonkCmd env