TcHsSyn.hs 69.1 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
{-# LANGUAGE CPP, TypeFamilies #-}
14

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

        -- * Other HsSyn functions
        mkHsDictLet, mkHsApp,
21
        mkHsAppTy, mkHsCaseAlt,
22
        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,
37
        zonkEvBinds, zonkTcEvBinds
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
hsLPatType :: OutPat GhcTc -> Type
86 87
hsLPatType (L _ pat) = hsPatType pat

88
hsPatType :: Pat GhcTc -> Type
Ian Lynagh's avatar
Ian Lynagh committed
89 90
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 p -> TcType
111 112 113 114
hsLitType (HsChar _ _)       = charTy
hsLitType (HsCharPrim _ _)   = charPrimTy
hsLitType (HsString _ _)     = stringTy
hsLitType (HsStringPrim _ _) = addrPrimTy
115
hsLitType (HsInt _ _)        = intTy
116 117 118 119 120
hsLitType (HsIntPrim _ _)    = intPrimTy
hsLitType (HsWordPrim _ _)   = wordPrimTy
hsLitType (HsInt64Prim _ _)  = int64PrimTy
hsLitType (HsWord64Prim _ _) = word64PrimTy
hsLitType (HsInteger _ _ ty) = ty
121 122 123
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 GhcTcId)
128
shortCutLit dflags (HsIntegral int@(IL src neg i)) ty
129
  | isIntTy ty  && inIntRange  dflags i = Just (HsLit (HsInt def int))
130
  | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i))
131
  | isIntegerTy ty = Just (HsLit (HsInteger src i ty))
132
  | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty
133 134 135 136 137
        -- 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
138

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

308
zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc)
309 310
zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel

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

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

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

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

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

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

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

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

361
zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc)
362 363
zonkTopExpr e = zonkExpr emptyZonkEnv e

364
zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)
365 366
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

367
zonkTopDecls :: Bag EvBind
368 369 370
             -> LHsBinds GhcTcId
             -> [LRuleDecl GhcTcId] -> [LVectDecl GhcTcId] -> [LTcSpecPrag]
             -> [LForeignDecl GhcTcId]
niteria's avatar
niteria committed
371
             -> TcM (TypeEnv,
372
                     Bag EvBind,
373 374
                     LHsBinds GhcTc,
                     [LForeignDecl GhcTc],
375
                     [LTcSpecPrag],
376 377
                     [LRuleDecl    GhcTc],
                     [LVectDecl    GhcTc])
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
zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId
               -> TcM (ZonkEnv, HsLocalBinds GhcTc)
391 392 393
zonkLocalBinds env EmptyLocalBinds
  = return (env, EmptyLocalBinds)

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

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

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

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

428
---------------------------------------------
429
zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc)
430
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
cactus's avatar
cactus committed
431

432
zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc)
433
zonk_lbind env = wrapLocM (zonk_bind env)
434

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

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

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

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

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

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

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

541 542
zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId
              -> TcM (ZonkEnv, HsPatSynDir GhcTc)
cactus's avatar
cactus committed
543 544
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 573
            -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
            -> MatchGroup GhcTcId (Located (body GhcTcId))
            -> TcM (MatchGroup GhcTc (Located (body GhcTc)))
574 575
zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys
                             , mg_res_ty = res_ty, mg_origin = origin })
576 577 578
  = do  { ms' <- mapM (zonkMatch env zBody) ms
        ; arg_tys' <- zonkTcTypeToTypes env arg_tys
        ; res_ty'  <- zonkTcTypeToType env res_ty
579 580
        ; return (MG { mg_alts = L l ms', mg_arg_tys = arg_tys'
                     , mg_res_ty = res_ty', mg_origin = origin }) }
581

582
zonkMatch :: ZonkEnv
583 584 585
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> LMatch GhcTcId (Located (body GhcTcId))
          -> TcM (LMatch GhcTc (Located (body GhcTc)))
Alan Zimmerman's avatar
Alan Zimmerman committed
586
zonkMatch env zBody (L loc (Match mf pats _ grhss))
587 588
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
Alan Zimmerman's avatar
Alan Zimmerman committed
589
        ; return (L loc (Match mf new_pats Nothing new_grhss)) }
590

591
-------------------------------------------------------------------------
592
zonkGRHSs :: ZonkEnv
593 594 595
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> GRHSs GhcTcId (Located (body GhcTcId))
          -> TcM (GRHSs GhcTc (Located (body GhcTc)))
596

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

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

615 616 617
zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc]
zonkLExpr  :: ZonkEnv -> LHsExpr GhcTcId   -> TcM (LHsExpr GhcTc)
zonkExpr   :: ZonkEnv -> HsExpr GhcTcId    -> TcM (HsExpr GhcTc)
618

619
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
620
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
621

622
zonkExpr env (HsVar (L l id))
Ben Gamari's avatar
Ben Gamari committed
623
  = ASSERT2( isNothing (isDataConId_maybe id), ppr id )
624 625 626
    return (HsVar (L l (zonkIdOcc env id)))

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

628
zonkExpr _ (HsIPVar id)
629
  = return (HsIPVar id)
630

631
zonkExpr _ e@HsOverLabel{} = return e
Adam Gundry's avatar
Adam Gundry committed
632

633
zonkExpr env (HsLit (HsRat e f ty))
ian@well-typed.com's avatar
ian@well-typed.com committed
634
  = do new_ty <- zonkTcTypeToType env ty
635
       return (HsLit (HsRat e f new_ty))
sof's avatar
sof committed
636

Ian Lynagh's avatar
Ian Lynagh committed
637
zonkExpr _ (HsLit lit)
638
  = return (HsLit lit)
639 640

zonkExpr env (HsOverLit lit)
641 642
  = do  { lit' <- zonkOverLit env lit
        ; return (HsOverLit lit') }
643

644
zonkExpr env (HsLam matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
645 646
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLam new_matches)
647

Simon Peyton Jones's avatar
Simon Peyton Jones committed
648 649 650
zonkExpr env (HsLamCase matches)
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLamCase new_matches)
651

652
zonkExpr env (HsApp e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
653 654 655
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (HsApp new_e1 new_e2)
656

657 658 659 660 661
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
662 663 664
zonkExpr _ e@(HsRnBracketOut _ _)
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

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

672 673
zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE s)
674 675

zonkExpr env (OpApp e1 op fixity e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
676 677 678 679
  = 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)
680

681
zonkExpr env (NegApp expr op)
682 683
  = do (env', new_op) <- zonkSyntaxExpr env op
       new_expr <- zonkLExpr env' expr
ian@well-typed.com's avatar
ian@well-typed.com committed
684
       return (NegApp new_expr new_op)
685

686
zonkExpr env (HsPar e)
ian@well-typed.com's avatar
ian@well-typed.com committed
687 688
  = do new_e <- zonkLExpr env e
       return (HsPar new_e)
689 690

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

zonkExpr env (SectionR op expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
696 697 698
  = do new_op   <- zonkLExpr env op
       new_expr <- zonkLExpr env expr
       return (SectionR new_op new_expr)
699

700 701 702 703
zonkExpr env (ExplicitTuple tup_args boxed)
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
       ; return (ExplicitTuple new_tup_args boxed) }
  where
704 705 706 707
    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')) }
708

709 710 711 712 713
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)

714
zonkExpr env (HsCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
715 716 717
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLExpr ms
       return (HsCase new_expr new_ms)
718

719 720 721 722 723 724 725 726 727 728 729 730
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)
731

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

741
zonkExpr env (HsLet (L l binds) expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
742 743
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_expr <- zonkLExpr new_env expr
744
       return (HsLet (L l new_binds) new_expr)
745

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

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

zonkExpr env (ExplicitPArr ty exprs)
ian@well-typed.com's avatar
ian@well-typed.com committed
760 761 762
  = do new_ty <- zonkTcTypeToType env ty
       new_exprs <- zonkLExprs env exprs
       return (ExplicitPArr new_ty new_exprs)
763

764
zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds })
765 766
  = do  { new_con_expr <- zonkExpr env con_expr
        ; new_rbinds   <- zonkRecFields env rbinds
767 768
        ; return (expr { rcon_con_expr = new_con_expr
                       , rcon_flds = new_rbinds }) }
769

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

782
zonkExpr env (ExprWithTySigOut e ty)
783 784 785
  = do { e' <- zonkLExpr env e
       ; return (ExprWithTySigOut e' ty) }

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

794
zonkExpr env (PArrSeq expr info)
ian@well-typed.com's avatar
ian@well-typed.com committed
795 796 797
  = do new_expr <- zonkExpr env expr
       new_info <- zonkArithSeq env info
       return (PArrSeq new_expr new_info)
798

Alan Zimmerman's avatar
Alan Zimmerman committed
799
zonkExpr env (HsSCC src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
800
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
801
       return (HsSCC src lbl new_expr)
802

803
zonkExpr env (HsTickPragma src info srcInfo expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
804
  = do new_expr <- zonkLExpr env expr
805
       return (HsTickPragma src info srcInfo new_expr)
andy@galois.com's avatar
andy@galois.com committed
806

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

812
-- arrow notation extensions
813
zonkExpr env (HsProc pat body)
814 815 816
  = do  { (env1, new_pat) <- zonkPat env pat
        ; new_body <- zonkCmdTop env1 body
        ; return (HsProc new_pat new_body) }
817

818
-- StaticPointers extension
819 820
zonkExpr env (HsStatic fvs expr)
  = HsStatic fvs <$> zonkLExpr env expr
821

822
zonkExpr env (HsWrap co_fn expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
823 824 825
  = do (env1, new_co_fn) <- zonkCoFn env co_fn
       new_expr <- zonkExpr env1 expr
       return (HsWrap new_co_fn new_expr)
826

827
zonkExpr _ e@(HsUnboundVar {}) = return e
828

Ian Lynagh's avatar
Ian Lynagh committed
829
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
830

831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852
-------------------------------------------------------------------------
{-
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]
853 854
zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTcId
               -> TcM (ZonkEnv, SyntaxExpr GhcTc)
855 856 857 858 859 860 861 862 863 864
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' }) }

865 866
-------------------------------------------------------------------------

867 868
zonkLCmd  :: ZonkEnv -> LHsCmd GhcTcId   -> TcM (LHsCmd GhcTc)
zonkCmd   :: ZonkEnv -> HsCmd GhcTcId    -> TcM (HsCmd GhcTc)
869 870 871

zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd

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