TcHsSyn.hs 60.8 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1996-1998

5 6

TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker
7 8 9

This module is an extension of @HsSyn@ syntax, for use in the type
checker.
Austin Seipp's avatar
Austin Seipp committed
10
-}
11

12 13
{-# LANGUAGE CPP #-}

14
module TcHsSyn (
15 16 17 18 19
        mkHsConApp, mkHsDictLet, mkHsApp,
        hsLitType, hsLPatType, hsPatType,
        mkHsAppTy, mkSimpleHsAlt,
        nlHsIntLit,
        shortCutLit, hsOverLitName,
20
        conLikeResTy,
21 22 23 24 25 26 27

        -- re-exported from TcMonad
        TcId, TcIdSet,

        zonkTopDecls, zonkTopExpr, zonkTopLExpr,
        zonkTopBndrs, zonkTyBndrsX,
        emptyZonkEnv, mkEmptyZonkEnv, mkTyVarZonkEnv,
28
        zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
29 30
  ) where

31
#include "HsVersions.h"
32

33
import HsSyn
34
import Id
35
import TcRnMonad
36
import PrelNames
37
import TypeRep     -- We can see the representation of types
38
import TcType
39
import TcMType ( defaultKindVarToStar, zonkQuantifiedTyVar, writeMetaTyVar )
40
import TcEvidence
41
import Coercion
42 43
import TysPrim
import TysWiredIn
dreixel's avatar
dreixel committed
44
import Type
45
import ConLike
46
import DataCon
47 48
import Name
import Var
49
import VarSet
50
import VarEnv
51
import DynFlags
52
import Literal
53 54 55
import BasicTypes
import Maybes
import SrcLoc
sof's avatar
sof committed
56
import Bag
sof's avatar
sof committed
57
import Outputable
58
import Util
59
#if __GLASGOW_HASKELL__ < 709
cactus's avatar
cactus committed
60
import Data.Traversable ( traverse )
61
#endif
62

Austin Seipp's avatar
Austin Seipp committed
63 64 65
{-
************************************************************************
*                                                                      *
66
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
Austin Seipp's avatar
Austin Seipp committed
67 68
*                                                                      *
************************************************************************
69

70
Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
71
then something is wrong.
Austin Seipp's avatar
Austin Seipp committed
72 73
-}

74 75 76
hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat

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

98

99
hsLitType :: HsLit -> TcType
100 101 102 103 104 105 106 107 108 109 110 111 112
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
113

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

116
shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr TcId)
117 118 119 120 121
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))
122
  | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit i)) ty
123 124 125 126 127
        -- 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
128

129
shortCutLit _ (HsFractional f) ty
130 131
  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim f))
  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
132 133
  | otherwise     = Nothing

134 135
shortCutLit _ (HsIsString src s) ty
  | isStringTy ty = Just (HsLit (HsString src s))
136 137 138 139 140 141 142 143 144 145 146
  | 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
147

Austin Seipp's avatar
Austin Seipp committed
148 149 150
{-
************************************************************************
*                                                                      *
151
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
Austin Seipp's avatar
Austin Seipp committed
152 153
*                                                                      *
************************************************************************
154

155 156
The rest of the zonking is done *after* typechecking.
The main zonking pass runs over the bindings
157 158 159

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

162 163
The type variables are converted by binding mutable tyvars to immutable ones
and then zonking as normal.
164

165 166 167
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
168

169
It's all pretty boring stuff, because HsSyn is such a large type, and
170
the environment manipulation is tiresome.
Austin Seipp's avatar
Austin Seipp committed
171
-}
172

173 174
type UnboundTyVarZonker = TcTyVar-> TcM Type
        -- How to zonk an unbound type variable
dreixel's avatar
dreixel committed
175 176
        -- Note [Zonking the LHS of a RULE]

177 178
data ZonkEnv
  = ZonkEnv
dreixel's avatar
dreixel committed
179
      UnboundTyVarZonker
180 181 182 183 184 185 186 187 188
      (TyVarEnv TyVar)          --
      (IdEnv    Var)            -- What variables are in scope
        -- 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
189 190 191
  ppr (ZonkEnv _ _ty_env var_env) = vcat (map ppr (varEnvElts var_env))


Ian Lynagh's avatar
Ian Lynagh committed
192
emptyZonkEnv :: ZonkEnv
193 194 195 196
emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping

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

dreixel's avatar
dreixel committed
198
extendIdZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
199
extendIdZonkEnv (ZonkEnv zonk_ty ty_env id_env) ids
dreixel's avatar
dreixel committed
200
  = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
201

dreixel's avatar
dreixel committed
202
extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
203
extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id
dreixel's avatar
dreixel committed
204
  = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
205

dreixel's avatar
dreixel committed
206 207 208 209
extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) ty
  = ZonkEnv zonk_ty (extendVarEnv ty_env ty ty) id_env

210 211 212
mkTyVarZonkEnv :: [TyVar] -> ZonkEnv
mkTyVarZonkEnv tvs = ZonkEnv zonkTypeZapping (mkVarEnv [(tv,tv) | tv <- tvs]) emptyVarEnv

dreixel's avatar
dreixel committed
213 214
setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
setZonkType (ZonkEnv _ ty_env id_env) zonk_ty = ZonkEnv zonk_ty ty_env id_env
215

216
zonkEnvIds :: ZonkEnv -> [Id]
dreixel's avatar
dreixel committed
217
zonkEnvIds (ZonkEnv _ _ id_env) = varEnvElts id_env
218 219

zonkIdOcc :: ZonkEnv -> TcId -> Id
220
-- Ids defined in this module should be in the envt;
221 222
-- ignore others.  (Actually, data constructors are also
-- not LocalVars, even when locally defined, but that is fine.)
223 224
-- (Also foreign-imported things aren't currently in the ZonkEnv;
--  that's ok because they don't need zonking.)
225 226
--
-- Actually, Template Haskell works in 'chunks' of declarations, and
227
-- an earlier chunk won't be in the 'env' that the zonking phase
228
-- carries around.  Instead it'll be in the tcg_gbl_env, already fully
229
-- zonked.  There's no point in looking it up there (except for error
230 231 232 233
-- 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
234
-- 'main' is done as a separate chunk.
235
zonkIdOcc (ZonkEnv _zonk_ty _ty_env env) id
236
  | isLocalVar id = lookupVarEnv env id `orElse` id
237
  | otherwise     = id
238

Ian Lynagh's avatar
Ian Lynagh committed
239
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
240
zonkIdOccs env ids = map (zonkIdOcc env) ids
241

242
-- zonkIdBndr is used *after* typechecking to get the Id's type
243
-- to its final form.  The TyVarEnv give
244 245
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
zonkIdBndr env id
ian@well-typed.com's avatar
ian@well-typed.com committed
246 247
  = do ty' <- zonkTcTypeToType env (idType id)
       return (Id.setIdType id ty')
248 249

zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
250
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
251 252 253

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

255 256 257
zonkFieldOcc :: ZonkEnv -> FieldOcc TcId -> TcM (FieldOcc Id)
zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel

258
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
259
zonkEvBndrsX = mapAccumLM zonkEvBndrX
260 261 262 263 264

zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
-- Works for dictionaries and coercions
zonkEvBndrX env var
  = do { var' <- zonkEvBndr env var
dreixel's avatar
dreixel committed
265
       ; return (extendIdZonkEnv1 env var', var') }
266 267 268 269

zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
-- Works for dictionaries and coercions
-- Does not extend the ZonkEnv
270
zonkEvBndr env var
271
  = do { let var_ty = varType var
272
       ; ty <-
273 274
           {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
           zonkTcTypeToType env var_ty
dreixel's avatar
dreixel committed
275
       ; return (setVarType var ty) }
276 277 278

zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar
zonkEvVarOcc env v = zonkIdOcc env v
dreixel's avatar
dreixel committed
279 280

zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
281
zonkTyBndrsX = mapAccumLM zonkTyBndrX
dreixel's avatar
dreixel committed
282 283

zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar)
284 285
-- 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
286 287
zonkTyBndrX env tv
  = do { ki <- zonkTcTypeToType env (tyVarKind tv)
288 289
       ; let tv' = mkTyVar (tyVarName tv) ki
       ; return (extendTyZonkEnv1 env tv', tv') }
290

291
zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
292 293
zonkTopExpr e = zonkExpr emptyZonkEnv e

294 295 296
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

297
zonkTopDecls :: Bag EvBind
Matthew Pickering's avatar
Matthew Pickering committed
298
             -> LHsBinds TcId
299
             -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
300
             -> TcM ([Id],
301
                     Bag EvBind,
cactus's avatar
cactus committed
302
                     LHsBinds Id,
303 304 305 306
                     [LForeignDecl Id],
                     [LTcSpecPrag],
                     [LRuleDecl    Id],
                     [LVectDecl    Id])
307
zonkTopDecls ev_binds binds rules vects imp_specs fords
308
  = do  { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
309
        ; (env2, binds') <- zonkRecMonoBinds env1 binds
310 311 312
                        -- Top level is implicitly recursive
        ; rules' <- zonkRules env2 rules
        ; vects' <- zonkVects env2 vects
313
        ; specs' <- zonkLTcSpecPrags env2 imp_specs
314 315
        ; fords' <- zonkForeignExports env2 fords
        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') }
316 317

---------------------------------------------
318 319 320 321
zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
zonkLocalBinds env EmptyLocalBinds
  = return (env, EmptyLocalBinds)

322 323 324
zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
  = panic "zonkLocalBinds" -- Not in typechecker output

325 326
zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs))
  = do  { (env1, new_binds) <- go env binds
327 328
        ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }
  where
329
    go env []
330
      = return (env, [])
331 332 333
    go env ((r,b):bs)
      = do { (env1, b')  <- zonkRecMonoBinds env b
           ; (env2, bs') <- go env1 bs
334
           ; return (env2, (r,b'):bs') }
335

ian@well-typed.com's avatar
ian@well-typed.com committed
336 337
zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do
    new_binds <- mapM (wrapLocM zonk_ip_bind) binds
338
    let
339
        env1 = extendIdZonkEnv env [ n | L _ (IPBind (Right n) _) <- new_binds]
ian@well-typed.com's avatar
ian@well-typed.com committed
340
    (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
341
    return (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
342
  where
343
    zonk_ip_bind (IPBind n e)
ian@well-typed.com's avatar
ian@well-typed.com committed
344 345 346
        = do n' <- mapIPNameTc (zonkIdBndr env) n
             e' <- zonkLExpr env e
             return (IPBind n' e')
347

348
---------------------------------------------
349 350
zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
zonkRecMonoBinds env binds
351 352
 = fixM (\ ~(_, new_binds) -> do
        { let env1 = extendIdZonkEnv env (collectHsBindsBinders new_binds)
353
        ; binds' <- zonkMonoBinds env1 binds
354 355
        ; return (env1, binds') })

356
---------------------------------------------
357 358
zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
cactus's avatar
cactus committed
359

360 361
zonk_lbind :: ZonkEnv -> LHsBind TcId -> TcM (LHsBind Id)
zonk_lbind env = wrapLocM (zonk_bind env)
362

363 364
zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
365 366 367 368
  = 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 }) }
369

370
zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
371 372 373 374
  = do { new_var  <- zonkIdBndr env var
       ; new_expr <- zonkLExpr env expr
       ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }

375 376
zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
                            , fun_co_fn = co_fn })
377 378
  = do { new_var <- zonkIdBndr env var
       ; (env1, new_co_fn) <- zonkCoFn env co_fn
379
       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
380 381 382
       ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
                      , fun_co_fn = new_co_fn }) }

383 384 385 386
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                        , abs_ev_binds = ev_binds
                        , abs_exports = exports
                        , abs_binds = val_binds })
387
  = ASSERT( all isImmutableTyVar tyvars )
dreixel's avatar
dreixel committed
388 389
    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
390
       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
391
       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
dreixel's avatar
dreixel committed
392
         do { let env3 = extendIdZonkEnv env2 (collectHsBindsBinders new_val_binds)
393
            ; new_val_binds <- zonkMonoBinds env3 val_binds
394 395
            ; new_exports   <- mapM (zonkExport env3) exports
            ; return (new_val_binds, new_exports) }
dreixel's avatar
dreixel committed
396 397
       ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
                          , abs_ev_binds = new_ev_binds
398
                          , abs_exports = new_exports, abs_binds = new_val_bind }) }
sof's avatar
sof committed
399
  where
400 401
    zonkExport env (ABE{ abe_wrap = wrap, abe_poly = poly_id
                       , abe_mono = mono_id, abe_prags = prags })
ian@well-typed.com's avatar
ian@well-typed.com committed
402 403 404 405 406 407
        = do new_poly_id <- zonkIdBndr env poly_id
             (_, new_wrap) <- zonkCoFn env wrap
             new_prags <- zonkSpecPrags env prags
             return (ABE{ abe_wrap = new_wrap, abe_poly = new_poly_id
                        , abe_mono = zonkIdOcc env mono_id
                        , abe_prags = new_prags })
408

409 410 411 412
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
413 414
  = do { id' <- zonkIdBndr env id
       ; details' <- zonkPatSynDetails env details
415
       ; (env1, lpat') <- zonkPat env lpat
cactus's avatar
cactus committed
416
       ; (_env2, dir') <- zonkPatSynDir env1 dir
417 418 419 420 421
       ; return $ PatSynBind $
                  bind { psb_id = L loc id'
                       , psb_args = details'
                       , psb_def = lpat'
                       , psb_dir = dir' } }
cactus's avatar
cactus committed
422 423 424 425 426 427 428 429 430

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)
431 432 433
zonkPatSynDir env (ExplicitBidirectional mg) = do
    mg' <- zonkMatchGroup env zonkLExpr mg
    return (env, ExplicitBidirectional mg')
cactus's avatar
cactus committed
434

435 436
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
437
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
438
                                       ; return (SpecPrags ps') }
439 440 441 442

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
443
  where
444
    zonk_prag (L loc (SpecPrag id co_fn inl))
445 446
        = do { (_, co_fn') <- zonkCoFn env co_fn
             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
447

Austin Seipp's avatar
Austin Seipp committed
448 449 450
{-
************************************************************************
*                                                                      *
451
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
452 453 454
*                                                                      *
************************************************************************
-}
455

456
zonkMatchGroup :: ZonkEnv
457 458
               -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
               -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id)))
459 460
zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys
                             , mg_res_ty = res_ty, mg_origin = origin })
461 462 463
  = do  { ms' <- mapM (zonkMatch env zBody) ms
        ; arg_tys' <- zonkTcTypeToTypes env arg_tys
        ; res_ty'  <- zonkTcTypeToType env res_ty
464 465
        ; return (MG { mg_alts = L l ms', mg_arg_tys = arg_tys'
                     , mg_res_ty = res_ty', mg_origin = origin }) }
466

467
zonkMatch :: ZonkEnv
468 469
          -> (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
470
zonkMatch env zBody (L loc (Match mf pats _ grhss))
471 472
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
Alan Zimmerman's avatar
Alan Zimmerman committed
473
        ; return (L loc (Match mf new_pats Nothing new_grhss)) }
474

475
-------------------------------------------------------------------------
476
zonkGRHSs :: ZonkEnv
477 478
          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
          -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))
479

480
zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
481
    (new_env, new_binds) <- zonkLocalBinds env binds
482
    let
483
        zonk_grhs (GRHS guarded rhs)
ian@well-typed.com's avatar
ian@well-typed.com committed
484 485 486 487
          = 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
488
    return (GRHSs new_grhss (L l new_binds))
489

Austin Seipp's avatar
Austin Seipp committed
490 491 492
{-
************************************************************************
*                                                                      *
493
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
494 495 496
*                                                                      *
************************************************************************
-}
497

498 499 500
zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
501

502
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
503
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
504

505 506
zonkExpr env (HsVar (L l id))
  = return (HsVar (L l (zonkIdOcc env id)))
507

508
zonkExpr _ (HsIPVar id)
509
  = return (HsIPVar id)
510

Adam Gundry's avatar
Adam Gundry committed
511 512 513
zonkExpr _ (HsOverLabel l)
  = return (HsOverLabel l)

514
zonkExpr env (HsLit (HsRat f ty))
ian@well-typed.com's avatar
ian@well-typed.com committed
515 516
  = do new_ty <- zonkTcTypeToType env ty
       return (HsLit (HsRat f new_ty))
sof's avatar
sof committed
517

Ian Lynagh's avatar
Ian Lynagh committed
518
zonkExpr _ (HsLit lit)
519
  = return (HsLit lit)
520 521

zonkExpr env (HsOverLit lit)
522 523
  = do  { lit' <- zonkOverLit env lit
        ; return (HsOverLit lit') }
524

525
zonkExpr env (HsLam matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
526 527
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLam new_matches)
528

529
zonkExpr env (HsLamCase arg matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
530 531 532
  = do new_arg <- zonkTcTypeToType env arg
       new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLamCase new_arg new_matches)
533

534
zonkExpr env (HsApp e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
535 536 537
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (HsApp new_e1 new_e2)
538

gmainland's avatar
gmainland committed
539 540 541
zonkExpr _ e@(HsRnBracketOut _ _)
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

542
zonkExpr env (HsTcBracketOut body bs)
ian@well-typed.com's avatar
ian@well-typed.com committed
543
  = do bs' <- mapM zonk_b bs
544
       return (HsTcBracketOut body bs')
545
  where
546 547
    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
                                      return (PendingTcSplice n e')
gmainland's avatar
gmainland committed
548

549 550
zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE s)
551 552

zonkExpr env (OpApp e1 op fixity e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
553 554 555 556
  = 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)
557

558
zonkExpr env (NegApp expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
559 560 561
  = do new_expr <- zonkLExpr env expr
       new_op <- zonkExpr env op
       return (NegApp new_expr new_op)
562

563
zonkExpr env (HsPar e)
ian@well-typed.com's avatar
ian@well-typed.com committed
564 565
  = do new_e <- zonkLExpr env e
       return (HsPar new_e)
566 567

zonkExpr env (SectionL expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
568 569 570
  = do new_expr <- zonkLExpr env expr
       new_op   <- zonkLExpr env op
       return (SectionL new_expr new_op)
571 572

zonkExpr env (SectionR op expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
573 574 575
  = do new_op   <- zonkLExpr env op
       new_expr <- zonkLExpr env expr
       return (SectionR new_op new_expr)
576

577 578 579 580
zonkExpr env (ExplicitTuple tup_args boxed)
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
       ; return (ExplicitTuple new_tup_args boxed) }
  where
581 582 583 584
    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')) }
585

586
zonkExpr env (HsCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
587 588 589
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLExpr ms
       return (HsCase new_expr new_ms)
590

591 592 593 594 595
zonkExpr env (HsIf e0 e1 e2 e3)
  = do { new_e0 <- fmapMaybeM (zonkExpr env) e0
       ; new_e1 <- zonkLExpr env e1
       ; new_e2 <- zonkLExpr env e2
       ; new_e3 <- zonkLExpr env e3
596
       ; return (HsIf new_e0 new_e1 new_e2 new_e3) }
597

598 599 600
zonkExpr env (HsMultiIf ty alts)
  = do { alts' <- mapM (wrapLocM zonk_alt) alts
       ; ty'   <- zonkTcTypeToType env ty
601
       ; return $ HsMultiIf ty' alts' }
602
  where zonk_alt (GRHS guard expr)
603
          = do { (env', guard') <- zonkStmts env zonkLExpr guard
604
               ; expr'          <- zonkLExpr env' expr
605
               ; return $ GRHS guard' expr' }
606

607
zonkExpr env (HsLet (L l binds) expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
608 609
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_expr <- zonkLExpr new_env expr
610
       return (HsLet (L l new_binds) new_expr)
611

612
zonkExpr env (HsDo do_or_lc (L l stmts) ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
613 614
  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
       new_ty <- zonkTcTypeToType env ty
615
       return (HsDo do_or_lc (L l new_stmts) new_ty)
616

617
zonkExpr env (ExplicitList ty wit exprs)
ian@well-typed.com's avatar
ian@well-typed.com committed
618 619 620 621
  = do new_ty <- zonkTcTypeToType env ty
       new_wit <- zonkWit env wit
       new_exprs <- zonkLExprs env exprs
       return (ExplicitList new_ty new_wit new_exprs)
622
   where zonkWit _ Nothing = return Nothing
ian@well-typed.com's avatar
ian@well-typed.com committed
623 624
         zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
                                     return (Just new_fln)
625 626

zonkExpr env (ExplicitPArr ty exprs)
ian@well-typed.com's avatar
ian@well-typed.com committed
627 628 629
  = do new_ty <- zonkTcTypeToType env ty
       new_exprs <- zonkLExprs env exprs
       return (ExplicitPArr new_ty new_exprs)
630

631
zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds })
632 633
  = do  { new_con_expr <- zonkExpr env con_expr
        ; new_rbinds   <- zonkRecFields env rbinds
634 635
        ; return (expr { rcon_con_expr = new_con_expr
                       , rcon_flds = new_rbinds }) }
636

637 638 639
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 })
640 641 642
  = do  { new_expr    <- zonkLExpr env expr
        ; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
        ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
643
        ; new_rbinds  <- zonkRecUpdFields env rbinds
Matthew Pickering's avatar
Matthew Pickering committed
644
        ; (_, new_recwrap) <- zonkCoFn env req_wrap
645 646 647
        ; 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 }) }
648

649
zonkExpr env (ExprWithTySigOut e ty)
650 651 652
  = do { e' <- zonkLExpr env e
       ; return (ExprWithTySigOut e' ty) }

653
zonkExpr env (ArithSeq expr wit info)
ian@well-typed.com's avatar
ian@well-typed.com committed
654 655 656 657
  = do new_expr <- zonkExpr env expr
       new_wit <- zonkWit env wit
       new_info <- zonkArithSeq env info
       return (ArithSeq new_expr new_wit new_info)
658
   where zonkWit _ Nothing = return Nothing
ian@well-typed.com's avatar
ian@well-typed.com committed
659 660
         zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
                                     return (Just new_fln)
661

662
zonkExpr env (PArrSeq expr info)
ian@well-typed.com's avatar
ian@well-typed.com committed
663 664 665
  = do new_expr <- zonkExpr env expr
       new_info <- zonkArithSeq env info
       return (PArrSeq new_expr new_info)
666

Alan Zimmerman's avatar
Alan Zimmerman committed
667
zonkExpr env (HsSCC src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
668
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
669
       return (HsSCC src lbl new_expr)
670

Alan Zimmerman's avatar
Alan Zimmerman committed
671
zonkExpr env (HsTickPragma src info expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
672
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
673
       return (HsTickPragma src info new_expr)
andy@galois.com's avatar
andy@galois.com committed
674

675
-- hdaume: core annotations
Alan Zimmerman's avatar
Alan Zimmerman committed
676
zonkExpr env (HsCoreAnn src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
677
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
678
       return (HsCoreAnn src lbl new_expr)
679

680
-- arrow notation extensions
681
zonkExpr env (HsProc pat body)
682 683 684
  = do  { (env1, new_pat) <- zonkPat env pat
        ; new_body <- zonkCmdTop env1 body
        ; return (HsProc new_pat new_body) }
685

686 687 688 689
-- StaticPointers extension
zonkExpr env (HsStatic expr)
  = HsStatic <$> zonkLExpr env expr

690
zonkExpr env (HsWrap co_fn expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
691 692 693
  = do (env1, new_co_fn) <- zonkCoFn env co_fn
       new_expr <- zonkExpr env1 expr
       return (HsWrap new_co_fn new_expr)
694

695 696
zonkExpr _ (HsUnboundVar v)
  = return (HsUnboundVar v)
697

Ian Lynagh's avatar
Ian Lynagh committed
698
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
699

700 701 702 703 704 705 706
-------------------------------------------------------------------------

zonkLCmd  :: ZonkEnv -> LHsCmd TcId   -> TcM (LHsCmd Id)
zonkCmd   :: ZonkEnv -> HsCmd TcId    -> TcM (HsCmd Id)

zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd

707
zonkCmd env (HsCmdCast co cmd)
Joachim Breitner's avatar
Joachim Breitner committed
708
  = do { co' <- zonkTcCoToCo env co
709
       ; cmd' <- zonkCmd env cmd
710
       ; return (HsCmdCast co' cmd') }
711
zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
ian@well-typed.com's avatar
ian@well-typed.com committed
712 713 714 715
  = 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)
716 717

zonkCmd env (HsCmdArrForm op fixity args)
ian@well-typed.com's avatar
ian@well-typed.com committed
718 719 720
  = do new_op <- zonkLExpr env op
       new_args <- mapM (zonkCmdTop env) args
       return (HsCmdArrForm new_op fixity new_args)
721 722

zonkCmd env (HsCmdApp c e)
ian@well-typed.com's avatar
ian@well-typed.com committed
723 724 725
  = do new_c <- zonkLCmd env c
       new_e <- zonkLExpr env e
       return (HsCmdApp new_c new_e)
726 727

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

731
zonkCmd env (HsCmdPar c)
ian@well-typed.com's avatar
ian@well-typed.com committed
732 733
  = do new_c <- zonkLCmd env c
       return (HsCmdPar new_c)
734 735

zonkCmd env (HsCmdCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
736 737 738
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLCmd ms
       return (HsCmdCase new_expr new_ms)
739 740 741 742 743 744

zonkCmd env (HsCmdIf eCond ePred cThen cElse)
  = do { new_eCond <- fmapMaybeM (zonkExpr env) eCond
       ; new_ePred <- zonkLExpr env ePred
       ; new_cThen <- zonkLCmd env cThen
       ; new_cElse <- zonkLCmd env cElse
745
       ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
746

747
zonkCmd env (HsCmdLet (L l binds) cmd)
ian@well-typed.com's avatar
ian@well-typed.com committed
748 749
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_cmd <- zonkLCmd new_env cmd
750
       return (HsCmdLet (L l new_binds) new_cmd)
751

752
zonkCmd env (HsCmdDo (L l stmts) ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
753 754
  = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
       new_ty <- zonkTcTypeToType env ty
755
       return (HsCmdDo (L l new_stmts) new_ty)
756 757 758 759 760





761 762 763
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd

Ian Lynagh's avatar
Ian Lynagh committed
764
zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
765
zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
ian@well-typed.com's avatar
ian@well-typed.com committed
766 767 768 769 770
  = do new_cmd <- zonkLCmd env cmd
       new_stack_tys <- zonkTcTypeToType env stack_tys
       new_ty <- zonkTcTypeToType env ty
       new_ids <- mapSndM (zonkExpr env) ids
       return (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
771

772
-------------------------------------------------------------------------
773
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
774
zonkCoFn env WpHole   = return (env, WpHole)
775
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
776 777
                                    ; (env2, c2') <- zonkCoFn env1 c2
                                    ; return (env2, WpCompose c1' c2') }
778 779 780 781 782
zonkCoFn env (WpFun c1 c2 t1 t2) = do { (env1, c1') <- zonkCoFn env c1
                                      ; (env2, c2') <- zonkCoFn env1 c2
                                      ; t1'         <- zonkTcTypeToType env2 t1
                                      ; t2'         <- zonkTcTypeToType env2 t2
                                      ; return (env2, WpFun c1' c2' t1' t2') }
Joachim Breitner's avatar
Joachim Breitner committed
783
zonkCoFn env (WpCast co) = do { co' <- zonkTcCoToCo env co
784
                              ; return (env, WpCast co') }
785
zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
786 787
                                 ; return (env', WpEvLam ev') }
zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg
788
                                 ; return (env, WpEvApp arg') }
789
zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
dreixel's avatar
dreixel committed
790
                              do { (env', tv') <- zonkTyBndrX env tv
791
                                 ; return (env', WpTyLam tv') }
792
zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToType env ty
793
                                 ; return (env, WpTyApp ty') }
794
zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs
795
                                 ; return (env1, WpLet bs') }
796

797 798
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
799
zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
800 801 802
  = do  { ty' <- zonkTcTypeToType env ty
        ; e' <- zonkExpr env e
        ; return (lit { ol_witness = e', ol_type = ty' }) }
803

804
-------------------------------------------------------------------------
805
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
806

807
zonkArithSeq env (From e)
ian@well-typed.com's avatar
ian@well-typed.com committed
808 809
  = do new_e <- zonkLExpr env e
       return (From new_e)
810

811
zonkArithSeq env (FromThen e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
812 813 814
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (FromThen new_e1 new_e2)
815

816
zonkArithSeq env (FromTo e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
817 818 819
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (FromTo new_e1 new_e2)
820

821
zonkArithSeq env (FromThenTo e1 e2 e3)
ian@well-typed.com's avatar
ian@well-typed.com committed
822 823 824 825
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       new_e3 <- zonkLExpr env e3
       return (FromThenTo new_e1 new_e2 new_e3)
826

827

828
-------------------------------------------------------------------------
829
zonkStmts :: ZonkEnv
830 831 832 833 834 835 836
          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
          -> [LStmt TcId (Located (body TcId))] -> TcM (ZonkEnv, [LStmt Id (Located (body Id))])
zonkStmts env _ []     = return (env, [])
zonkStmts env zBody (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env zBody) s
                                ; (env2, ss') <- zonkStmts env1 zBody ss
                                ; return (env2, s' : ss') }

837
zonkStmt :: ZonkEnv
838 839 840
         -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
         -> Stmt TcId (Located (body TcId)) -> TcM (ZonkEnv, Stmt Id (Located (body Id)))
zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op)
841 842
  = do { new_stmts_w_bndrs <- mapM zonk_branch stmts_w_bndrs
       ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs]
843
             env1 = extendIdZonkEnv env new_binders
844 845 846
       ; new_mzip <- zonkExpr env1 mzip_op
       ; new_bind <- zonkExpr env1 bind_op
       ; return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind) }
847
  where
848
    zonk_branch (ParStmtBlock stmts bndrs return_op)
849
       = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
850
            ; new_return <- zonkExpr env1 return_op