TcHsSyn.hs 60.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 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

        -- re-exported from TcMonad
        TcId, TcIdSet,

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

32
#include "HsVersions.h"
33

34
import HsSyn
35
import Id
36
import TcRnMonad
37
import PrelNames
38
import TcType
39
import TcMType
40
import TcEvidence
41 42
import TysPrim
import TysWiredIn
dreixel's avatar
dreixel committed
43
import Type
44
import Coercion
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 60
import qualified GHC.LanguageExtensions as LangExt

61
#if __GLASGOW_HASKELL__ < 709
cactus's avatar
cactus committed
62
import Data.Traversable ( traverse )
63
#endif
64 65
import Control.Monad
import Data.List  ( partition )
66

Austin Seipp's avatar
Austin Seipp committed
67 68 69
{-
************************************************************************
*                                                                      *
70
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
Austin Seipp's avatar
Austin Seipp committed
71 72
*                                                                      *
************************************************************************
73

74
Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
75
then something is wrong.
Austin Seipp's avatar
Austin Seipp committed
76 77
-}

78 79 80
hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat

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

102

103
hsLitType :: HsLit -> TcType
104 105 106 107 108 109 110 111 112 113 114 115 116
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
117

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

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

133
shortCutLit _ (HsFractional f) ty
134 135
  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim f))
  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
136 137
  | otherwise     = Nothing

138 139
shortCutLit _ (HsIsString src s) ty
  | isStringTy ty = Just (HsLit (HsString src s))
140 141 142 143 144 145 146 147 148 149 150
  | 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
151

Austin Seipp's avatar
Austin Seipp committed
152 153 154
{-
************************************************************************
*                                                                      *
155
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
Austin Seipp's avatar
Austin Seipp committed
156 157
*                                                                      *
************************************************************************
158

159 160
The rest of the zonking is done *after* typechecking.
The main zonking pass runs over the bindings
161 162 163

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

166 167
The type variables are converted by binding mutable tyvars to immutable ones
and then zonking as normal.
168

169 170 171
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
172

173
It's all pretty boring stuff, because HsSyn is such a large type, and
174
the environment manipulation is tiresome.
Austin Seipp's avatar
Austin Seipp committed
175
-}
176

177
type UnboundTyVarZonker = TcTyVar -> TcM Type
178
        -- How to zonk an unbound type variable
dreixel's avatar
dreixel committed
179 180
        -- Note [Zonking the LHS of a RULE]

181 182 183 184 185 186 187 188 189 190 191
-- | 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
-- 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.
192 193
data ZonkEnv
  = ZonkEnv
dreixel's avatar
dreixel committed
194
      UnboundTyVarZonker
195 196
      (TyCoVarEnv TyVar)
      (IdEnv      Var)         -- What variables are in scope
197 198 199 200 201 202 203
        -- 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
204 205 206
  ppr (ZonkEnv _ _ty_env var_env) = vcat (map ppr (varEnvElts var_env))


207
-- The EvBinds have to already be zonked, but that's usually the case.
Ian Lynagh's avatar
Ian Lynagh committed
208
emptyZonkEnv :: ZonkEnv
209 210 211 212
emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping

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

214 215 216 217 218
-- | 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
219
  = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
220 221 222 223 224 225 226 227 228 229 230 231
  -- 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
232

dreixel's avatar
dreixel committed
233
extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
234
extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id
dreixel's avatar
dreixel committed
235
  = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
236

dreixel's avatar
dreixel committed
237 238 239 240 241
extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) ty
  = ZonkEnv zonk_ty (extendVarEnv ty_env ty ty) id_env

setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
242 243
setZonkType (ZonkEnv _ ty_env id_env) zonk_ty
  = ZonkEnv zonk_ty ty_env id_env
244

245
zonkEnvIds :: ZonkEnv -> [Id]
dreixel's avatar
dreixel committed
246
zonkEnvIds (ZonkEnv _ _ id_env) = varEnvElts id_env
247 248

zonkIdOcc :: ZonkEnv -> TcId -> Id
249
-- Ids defined in this module should be in the envt;
250 251
-- ignore others.  (Actually, data constructors are also
-- not LocalVars, even when locally defined, but that is fine.)
252 253
-- (Also foreign-imported things aren't currently in the ZonkEnv;
--  that's ok because they don't need zonking.)
254 255
--
-- Actually, Template Haskell works in 'chunks' of declarations, and
256
-- an earlier chunk won't be in the 'env' that the zonking phase
257
-- carries around.  Instead it'll be in the tcg_gbl_env, already fully
258
-- zonked.  There's no point in looking it up there (except for error
259 260 261 262
-- 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
263
-- 'main' is done as a separate chunk.
264 265 266
zonkIdOcc (ZonkEnv _zonk_ty _ty_env id_env) id
  | isLocalVar id = lookupVarEnv id_env id `orElse`
                    id
267
  | otherwise     = id
268

Ian Lynagh's avatar
Ian Lynagh committed
269
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
270
zonkIdOccs env ids = map (zonkIdOcc env) ids
271

272
-- zonkIdBndr is used *after* typechecking to get the Id's type
273
-- to its final form.  The TyVarEnv give
274 275
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
zonkIdBndr env id
ian@well-typed.com's avatar
ian@well-typed.com committed
276
  = do ty' <- zonkTcTypeToType env (idType id)
277
       return (setIdType id ty')
278 279

zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
280
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
281 282 283

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

285 286 287
zonkFieldOcc :: ZonkEnv -> FieldOcc TcId -> TcM (FieldOcc Id)
zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel

288
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
289
zonkEvBndrsX = mapAccumLM zonkEvBndrX
290 291 292 293 294

zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
-- Works for dictionaries and coercions
zonkEvBndrX env var
  = do { var' <- zonkEvBndr env var
295
       ; return (extendZonkEnv env [var'], var') }
296 297 298 299

zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
-- Works for dictionaries and coercions
-- Does not extend the ZonkEnv
300
zonkEvBndr env var
301
  = do { let var_ty = varType var
302
       ; ty <-
303 304
           {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
           zonkTcTypeToType env var_ty
dreixel's avatar
dreixel committed
305
       ; return (setVarType var ty) }
306

307 308 309 310 311 312
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
313 314

zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
315
zonkTyBndrsX = mapAccumLM zonkTyBndrX
dreixel's avatar
dreixel committed
316 317

zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar)
318 319
-- 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
320
zonkTyBndrX env tv
321 322
  = ASSERT( isImmutableTyVar tv )
    do { ki <- zonkTcTypeToType env (tyVarKind tv)
323 324
       ; let tv' = mkTyVar (tyVarName tv) ki
       ; return (extendTyZonkEnv1 env tv', tv') }
325

326
zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
327 328
zonkTopExpr e = zonkExpr emptyZonkEnv e

329 330 331
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

332
zonkTopDecls :: Bag EvBind
Matthew Pickering's avatar
Matthew Pickering committed
333
             -> LHsBinds TcId
334
             -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
335
             -> TcM ([Id],
336
                     Bag EvBind,
cactus's avatar
cactus committed
337
                     LHsBinds Id,
338 339 340 341
                     [LForeignDecl Id],
                     [LTcSpecPrag],
                     [LRuleDecl    Id],
                     [LVectDecl    Id])
342
zonkTopDecls ev_binds binds rules vects imp_specs fords
343
  = do  { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
344
        ; (env2, binds') <- zonkRecMonoBinds env1 binds
345 346 347
                        -- Top level is implicitly recursive
        ; rules' <- zonkRules env2 rules
        ; vects' <- zonkVects env2 vects
348
        ; specs' <- zonkLTcSpecPrags env2 imp_specs
349 350
        ; fords' <- zonkForeignExports env2 fords
        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') }
351 352

---------------------------------------------
353 354 355 356
zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
zonkLocalBinds env EmptyLocalBinds
  = return (env, EmptyLocalBinds)

357 358 359
zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
  = panic "zonkLocalBinds" -- Not in typechecker output

360 361
zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs))
  = do  { (env1, new_binds) <- go env binds
362 363
        ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }
  where
364
    go env []
365
      = return (env, [])
366 367 368
    go env ((r,b):bs)
      = do { (env1, b')  <- zonkRecMonoBinds env b
           ; (env2, bs') <- go env1 bs
369
           ; return (env2, (r,b'):bs') }
370

ian@well-typed.com's avatar
ian@well-typed.com committed
371 372
zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do
    new_binds <- mapM (wrapLocM zonk_ip_bind) binds
373
    let
374
        env1 = extendIdZonkEnvRec env [ n | L _ (IPBind (Right n) _) <- new_binds]
ian@well-typed.com's avatar
ian@well-typed.com committed
375
    (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
376
    return (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
377
  where
378
    zonk_ip_bind (IPBind n e)
ian@well-typed.com's avatar
ian@well-typed.com committed
379 380 381
        = do n' <- mapIPNameTc (zonkIdBndr env) n
             e' <- zonkLExpr env e
             return (IPBind n' e')
382

383
---------------------------------------------
384 385
zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
zonkRecMonoBinds env binds
386
 = fixM (\ ~(_, new_binds) -> do
387
        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)
388
        ; binds' <- zonkMonoBinds env1 binds
389 390
        ; return (env1, binds') })

391
---------------------------------------------
392 393
zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
cactus's avatar
cactus committed
394

395 396
zonk_lbind :: ZonkEnv -> LHsBind TcId -> TcM (LHsBind Id)
zonk_lbind env = wrapLocM (zonk_bind env)
397

398 399
zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
400 401 402 403
  = 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 }) }
404

405
zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
406 407 408 409
  = do { new_var  <- zonkIdBndr env var
       ; new_expr <- zonkLExpr env expr
       ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }

410 411
zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
                            , fun_co_fn = co_fn })
412 413
  = do { new_var <- zonkIdBndr env var
       ; (env1, new_co_fn) <- zonkCoFn env co_fn
414
       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
415 416 417
       ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
                      , fun_co_fn = new_co_fn }) }

418 419 420 421
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                        , abs_ev_binds = ev_binds
                        , abs_exports = exports
                        , abs_binds = val_binds })
422
  = ASSERT( all isImmutableTyVar tyvars )
dreixel's avatar
dreixel committed
423 424
    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
425
       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
426
       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
427 428
         do { let env3 = extendIdZonkEnvRec env2
                           (collectHsBindsBinders new_val_binds)
429
            ; new_val_binds <- zonkMonoBinds env3 val_binds
430 431
            ; new_exports   <- mapM (zonkExport env3) exports
            ; return (new_val_binds, new_exports) }
dreixel's avatar
dreixel committed
432 433
       ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
                          , abs_ev_binds = new_ev_binds
434
                          , abs_exports = new_exports, abs_binds = new_val_bind }) }
sof's avatar
sof committed
435
  where
436 437
    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
438 439 440 441 442 443
        = 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 })
444

445 446 447 448
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
449 450
  = do { id' <- zonkIdBndr env id
       ; details' <- zonkPatSynDetails env details
451
       ; (env1, lpat') <- zonkPat env lpat
cactus's avatar
cactus committed
452
       ; (_env2, dir') <- zonkPatSynDir env1 dir
453 454 455 456 457
       ; return $ PatSynBind $
                  bind { psb_id = L loc id'
                       , psb_args = details'
                       , psb_def = lpat'
                       , psb_dir = dir' } }
cactus's avatar
cactus committed
458 459 460 461 462 463 464 465 466

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)
467 468 469
zonkPatSynDir env (ExplicitBidirectional mg) = do
    mg' <- zonkMatchGroup env zonkLExpr mg
    return (env, ExplicitBidirectional mg')
cactus's avatar
cactus committed
470

471 472
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
473
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
474
                                       ; return (SpecPrags ps') }
475 476 477 478

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
479
  where
480
    zonk_prag (L loc (SpecPrag id co_fn inl))
481 482
        = do { (_, co_fn') <- zonkCoFn env co_fn
             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
483

Austin Seipp's avatar
Austin Seipp committed
484 485 486
{-
************************************************************************
*                                                                      *
487
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
488 489 490
*                                                                      *
************************************************************************
-}
491

492
zonkMatchGroup :: ZonkEnv
493 494
               -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
               -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id)))
495 496
zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys
                             , mg_res_ty = res_ty, mg_origin = origin })
497 498 499
  = do  { ms' <- mapM (zonkMatch env zBody) ms
        ; arg_tys' <- zonkTcTypeToTypes env arg_tys
        ; res_ty'  <- zonkTcTypeToType env res_ty
500 501
        ; return (MG { mg_alts = L l ms', mg_arg_tys = arg_tys'
                     , mg_res_ty = res_ty', mg_origin = origin }) }
502

503
zonkMatch :: ZonkEnv
504 505
          -> (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
506
zonkMatch env zBody (L loc (Match mf pats _ grhss))
507 508
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
Alan Zimmerman's avatar
Alan Zimmerman committed
509
        ; return (L loc (Match mf new_pats Nothing new_grhss)) }
510

511
-------------------------------------------------------------------------
512
zonkGRHSs :: ZonkEnv
513 514
          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
          -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))
515

516
zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
517
    (new_env, new_binds) <- zonkLocalBinds env binds
518
    let
519
        zonk_grhs (GRHS guarded rhs)
ian@well-typed.com's avatar
ian@well-typed.com committed
520 521 522 523
          = 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
524
    return (GRHSs new_grhss (L l new_binds))
525

Austin Seipp's avatar
Austin Seipp committed
526 527 528
{-
************************************************************************
*                                                                      *
529
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
530 531 532
*                                                                      *
************************************************************************
-}
533

534 535 536
zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
537

538
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
539
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
540

541 542
zonkExpr env (HsVar (L l id))
  = return (HsVar (L l (zonkIdOcc env id)))
543

544
zonkExpr _ (HsIPVar id)
545
  = return (HsIPVar id)
546

Adam Gundry's avatar
Adam Gundry committed
547 548 549
zonkExpr _ (HsOverLabel l)
  = return (HsOverLabel l)

550
zonkExpr env (HsLit (HsRat f ty))
ian@well-typed.com's avatar
ian@well-typed.com committed
551 552
  = do new_ty <- zonkTcTypeToType env ty
       return (HsLit (HsRat f new_ty))
sof's avatar
sof committed
553

Ian Lynagh's avatar
Ian Lynagh committed
554
zonkExpr _ (HsLit lit)
555
  = return (HsLit lit)
556 557

zonkExpr env (HsOverLit lit)
558 559
  = do  { lit' <- zonkOverLit env lit
        ; return (HsOverLit lit') }
560

561
zonkExpr env (HsLam matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
562 563
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLam new_matches)
564

565
zonkExpr env (HsLamCase arg matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
566 567 568
  = do new_arg <- zonkTcTypeToType env arg
       new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLamCase new_arg new_matches)
569

570
zonkExpr env (HsApp e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
571 572 573
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (HsApp new_e1 new_e2)
574

gmainland's avatar
gmainland committed
575 576 577
zonkExpr _ e@(HsRnBracketOut _ _)
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

578
zonkExpr env (HsTcBracketOut body bs)
ian@well-typed.com's avatar
ian@well-typed.com committed
579
  = do bs' <- mapM zonk_b bs
580
       return (HsTcBracketOut body bs')
581
  where
582 583
    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
                                      return (PendingTcSplice n e')
gmainland's avatar
gmainland committed
584

585 586
zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE s)
587 588

zonkExpr env (OpApp e1 op fixity e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
589 590 591 592
  = 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)
593

594
zonkExpr env (NegApp expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
595 596 597
  = do new_expr <- zonkLExpr env expr
       new_op <- zonkExpr env op
       return (NegApp new_expr new_op)
598

599
zonkExpr env (HsPar e)
ian@well-typed.com's avatar
ian@well-typed.com committed
600 601
  = do new_e <- zonkLExpr env e
       return (HsPar new_e)
602 603

zonkExpr env (SectionL expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
604 605 606
  = do new_expr <- zonkLExpr env expr
       new_op   <- zonkLExpr env op
       return (SectionL new_expr new_op)
607 608

zonkExpr env (SectionR op expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
609 610 611
  = do new_op   <- zonkLExpr env op
       new_expr <- zonkLExpr env expr
       return (SectionR new_op new_expr)
612

613 614 615 616
zonkExpr env (ExplicitTuple tup_args boxed)
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
       ; return (ExplicitTuple new_tup_args boxed) }
  where
617 618 619 620
    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')) }
621

622
zonkExpr env (HsCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
623 624 625
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLExpr ms
       return (HsCase new_expr new_ms)
626

627 628 629 630 631
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
632
       ; return (HsIf new_e0 new_e1 new_e2 new_e3) }
633

634 635 636
zonkExpr env (HsMultiIf ty alts)
  = do { alts' <- mapM (wrapLocM zonk_alt) alts
       ; ty'   <- zonkTcTypeToType env ty
637
       ; return $ HsMultiIf ty' alts' }
638
  where zonk_alt (GRHS guard expr)
639
          = do { (env', guard') <- zonkStmts env zonkLExpr guard
640
               ; expr'          <- zonkLExpr env' expr
641
               ; return $ GRHS guard' expr' }
642

643
zonkExpr env (HsLet (L l binds) expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
644 645
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_expr <- zonkLExpr new_env expr
646
       return (HsLet (L l new_binds) new_expr)
647

648
zonkExpr env (HsDo do_or_lc (L l stmts) ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
649 650
  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
       new_ty <- zonkTcTypeToType env ty
651
       return (HsDo do_or_lc (L l new_stmts) new_ty)
652

653
zonkExpr env (ExplicitList ty wit exprs)
ian@well-typed.com's avatar
ian@well-typed.com committed
654 655 656 657
  = do new_ty <- zonkTcTypeToType env ty
       new_wit <- zonkWit env wit
       new_exprs <- zonkLExprs env exprs
       return (ExplicitList new_ty new_wit new_exprs)
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 (ExplicitPArr ty exprs)
ian@well-typed.com's avatar
ian@well-typed.com committed
663 664 665
  = do new_ty <- zonkTcTypeToType env ty
       new_exprs <- zonkLExprs env exprs
       return (ExplicitPArr new_ty new_exprs)
666

667
zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds })
668 669
  = do  { new_con_expr <- zonkExpr env con_expr
        ; new_rbinds   <- zonkRecFields env rbinds
670 671
        ; return (expr { rcon_con_expr = new_con_expr
                       , rcon_flds = new_rbinds }) }
672

673 674 675
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 })
676 677 678
  = do  { new_expr    <- zonkLExpr env expr
        ; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
        ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
679
        ; new_rbinds  <- zonkRecUpdFields env rbinds
Matthew Pickering's avatar
Matthew Pickering committed
680
        ; (_, new_recwrap) <- zonkCoFn env req_wrap
681 682 683
        ; 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 }) }
684

685
zonkExpr env (ExprWithTySigOut e ty)
686 687 688
  = do { e' <- zonkLExpr env e
       ; return (ExprWithTySigOut e' ty) }

689
zonkExpr env (ArithSeq expr wit info)
ian@well-typed.com's avatar
ian@well-typed.com committed
690 691 692 693
  = do new_expr <- zonkExpr env expr
       new_wit <- zonkWit env wit
       new_info <- zonkArithSeq env info
       return (ArithSeq new_expr new_wit new_info)
694
   where zonkWit _ Nothing = return Nothing
ian@well-typed.com's avatar
ian@well-typed.com committed
695 696
         zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
                                     return (Just new_fln)
697

698
zonkExpr env (PArrSeq expr info)
ian@well-typed.com's avatar
ian@well-typed.com committed
699 700 701
  = do new_expr <- zonkExpr env expr
       new_info <- zonkArithSeq env info
       return (PArrSeq new_expr new_info)
702

Alan Zimmerman's avatar
Alan Zimmerman committed
703
zonkExpr env (HsSCC src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
704
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
705
       return (HsSCC src lbl new_expr)
706

Alan Zimmerman's avatar
Alan Zimmerman committed
707
zonkExpr env (HsTickPragma src info expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
708
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
709
       return (HsTickPragma src info new_expr)
andy@galois.com's avatar
andy@galois.com committed
710

711
-- hdaume: core annotations
Alan Zimmerman's avatar
Alan Zimmerman committed
712
zonkExpr env (HsCoreAnn src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
713
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
714
       return (HsCoreAnn src lbl new_expr)
715

716
-- arrow notation extensions
717
zonkExpr env (HsProc pat body)
718 719 720
  = do  { (env1, new_pat) <- zonkPat env pat
        ; new_body <- zonkCmdTop env1 body
        ; return (HsProc new_pat new_body) }
721

722 723 724 725
-- StaticPointers extension
zonkExpr env (HsStatic expr)
  = HsStatic <$> zonkLExpr env expr

726
zonkExpr env (HsWrap co_fn expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
727 728 729
  = do (env1, new_co_fn) <- zonkCoFn env co_fn
       new_expr <- zonkExpr env1 expr
       return (HsWrap new_co_fn new_expr)
730

731 732
zonkExpr _ (HsUnboundVar v)
  = return (HsUnboundVar v)
733

Ian Lynagh's avatar
Ian Lynagh committed
734
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
735

736 737 738 739 740 741 742
-------------------------------------------------------------------------

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

zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd

743
zonkCmd env (HsCmdCast co cmd)
744
  = do { co' <- zonkCoToCo env co
745
       ; cmd' <- zonkCmd env cmd
746
       ; return (HsCmdCast co' cmd') }
747
zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
ian@well-typed.com's avatar
ian@well-typed.com committed
748 749 750 751
  = 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)
752 753

zonkCmd env (HsCmdArrForm op fixity args)
ian@well-typed.com's avatar
ian@well-typed.com committed
754 755 756
  = do new_op <- zonkLExpr env op
       new_args <- mapM (zonkCmdTop env) args
       return (HsCmdArrForm new_op fixity new_args)
757 758

zonkCmd env (HsCmdApp c e)
ian@well-typed.com's avatar
ian@well-typed.com committed
759 760 761
  = do new_c <- zonkLCmd env c
       new_e <- zonkLExpr env e
       return (HsCmdApp new_c new_e)
762 763

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

767
zonkCmd env (HsCmdPar c)
ian@well-typed.com's avatar
ian@well-typed.com committed
768 769
  = do new_c <- zonkLCmd env c
       return (HsCmdPar new_c)
770 771

zonkCmd env (HsCmdCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
772 773 774
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLCmd ms
       return (HsCmdCase new_expr new_ms)
775 776 777 778 779 780

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
781
       ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
782

783
zonkCmd env (HsCmdLet (L l binds) cmd)
ian@well-typed.com's avatar
ian@well-typed.com committed
784 785
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_cmd <- zonkLCmd new_env cmd
786
       return (HsCmdLet (L l new_binds) new_cmd)
787

788
zonkCmd env (HsCmdDo (L l stmts) ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
789 790
  = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
       new_ty <- zonkTcTypeToType env ty
791
       return (HsCmdDo (L l new_stmts) new_ty)
792 793 794 795 796





797 798 799
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd

Ian Lynagh's avatar
Ian Lynagh committed
800
zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
801
zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
ian@well-typed.com's avatar
ian@well-typed.com committed
802 803 804 805 806
  = 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)
807

808
-------------------------------------------------------------------------
809
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
810
zonkCoFn env WpHole   = return (env, WpHole)
811
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
812 813
                                    ; (env2, c2') <- zonkCoFn env1 c2
                                    ; return (env2, WpCompose c1' c2') }
814 815 816 817 818
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') }
819
zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co
820
                              ; return (env, WpCast co') }
821
zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
822 823
                                 ; return (env', WpEvLam ev') }
zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg
824
                                 ; return (env, WpEvApp arg') }
825
zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
dreixel's avatar
dreixel committed
826
                              do { (env', tv') <- zonkTyBndrX env tv
827
                                 ; return (env', WpTyLam tv') }
828
zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToType env ty
829
                                 ; return (env, WpTyApp ty') }
830
zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs
831
                                 ; return (env1, WpLet bs') }
832

833 834
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
835
zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
836 837 838
  = do  { ty' <- zonkTcTypeToType env ty
        ; e' <- zonkExpr env e
        ; return (lit { ol_witness = e', ol_type = ty' }) }
839

840
-------------------------------------------------------------------------
841
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
842

843
zonkArithSeq env (From e)
ian@well-typed.com's avatar
ian@well-typed.com committed
844 845
  = do new_e <- zonkLExpr env e
       return (From new_e)
846

847
zonkArithSeq env (FromThen e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
848 849 850
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (FromThen new_e1 new_e2)
851

852
zonkArithSeq env (FromTo e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
853 854 855
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (FromTo new_e1 new_e2)
856

857
zonkArithSeq env (FromThenTo e1 e2 e3)
ian@well-typed.com's avatar
ian@well-typed.com committed
858 859 860 861
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       new_e3 <- zonkLExpr env e3
       return (FromThenTo new_e1 new_e2 new_e3)
862

863

864
-------------------------------------------------------------------------
865
zonkStmts :: ZonkEnv
866 867 868 869 870 871 872
          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))