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

5 6

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

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

12 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 42
import TysPrim
import TysWiredIn
dreixel's avatar
dreixel committed
43
import Type
44
import ConLike
45
import DataCon
46
import PatSyn( patSynInstResTy )
47
import Name
48
import NameSet
49
import Var
50
import VarSet
51
import VarEnv
52
import DynFlags
53
import Literal
54 55 56
import BasicTypes
import Maybes
import SrcLoc
sof's avatar
sof committed
57
import Bag
58
import FastString
sof's avatar
sof committed
59
import Outputable
60
import Util
61
#if __GLASGOW_HASKELL__ < 709
cactus's avatar
cactus committed
62
import Data.Traversable ( traverse )
63
#endif
64

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

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

76 77 78
hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat

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

100 101 102 103
conLikeResTy :: ConLike -> [Type] -> Type
conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys
conLikeResTy (PatSynCon ps)    tys = patSynInstResTy ps tys

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

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

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

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

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

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

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

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

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

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

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

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

182 183
data ZonkEnv
  = ZonkEnv
dreixel's avatar
dreixel committed
184
      UnboundTyVarZonker
185 186 187 188 189 190 191 192 193
      (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
194 195 196
  ppr (ZonkEnv _ _ty_env var_env) = vcat (map ppr (varEnvElts var_env))


Ian Lynagh's avatar
Ian Lynagh committed
197
emptyZonkEnv :: ZonkEnv
198 199 200 201
emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping

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

dreixel's avatar
dreixel committed
203
extendIdZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
204
extendIdZonkEnv (ZonkEnv zonk_ty ty_env id_env) ids
dreixel's avatar
dreixel committed
205
  = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
206

dreixel's avatar
dreixel committed
207
extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
208
extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id
dreixel's avatar
dreixel committed
209
  = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
210

dreixel's avatar
dreixel committed
211 212 213 214
extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) ty
  = ZonkEnv zonk_ty (extendVarEnv ty_env ty ty) id_env

215 216 217
mkTyVarZonkEnv :: [TyVar] -> ZonkEnv
mkTyVarZonkEnv tvs = ZonkEnv zonkTypeZapping (mkVarEnv [(tv,tv) | tv <- tvs]) emptyVarEnv

dreixel's avatar
dreixel committed
218 219
setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
setZonkType (ZonkEnv _ ty_env id_env) zonk_ty = ZonkEnv zonk_ty ty_env id_env
220

221
zonkEnvIds :: ZonkEnv -> [Id]
dreixel's avatar
dreixel committed
222
zonkEnvIds (ZonkEnv _ _ id_env) = varEnvElts id_env
223 224

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

Ian Lynagh's avatar
Ian Lynagh committed
244
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
245
zonkIdOccs env ids = map (zonkIdOcc env) ids
246

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

zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
255
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
256 257 258

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

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

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

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

zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar
zonkEvVarOcc env v = zonkIdOcc env v
dreixel's avatar
dreixel committed
281 282

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

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

293
zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
294 295
zonkTopExpr e = zonkExpr emptyZonkEnv e

296 297 298
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

299
zonkTopDecls :: Bag EvBind
300
             -> LHsBinds TcId -> Bag OccName -> NameSet
301
             -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
302
             -> TcM ([Id],
303
                     Bag EvBind,
cactus's avatar
cactus committed
304
                     LHsBinds Id,
305 306 307 308
                     [LForeignDecl Id],
                     [LTcSpecPrag],
                     [LRuleDecl    Id],
                     [LVectDecl    Id])
309
zonkTopDecls ev_binds binds exports sig_ns rules vects imp_specs fords
310
  = do  { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
311

312 313
         -- Warn about missing signatures
         -- Do this only when we we have a type to offer
314
        ; warn_missing_sigs <- woptM Opt_WarnMissingSigs
315 316 317 318 319
        ; warn_only_exported <- woptM Opt_WarnMissingExportedSigs
        ; let sig_warn
                | warn_only_exported = topSigWarnIfExported exports sig_ns
                | warn_missing_sigs  = topSigWarn sig_ns
                | otherwise          = noSigWarn
320 321

        ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds
322 323 324
                        -- Top level is implicitly recursive
        ; rules' <- zonkRules env2 rules
        ; vects' <- zonkVects env2 vects
325
        ; specs' <- zonkLTcSpecPrags env2 imp_specs
326 327
        ; fords' <- zonkForeignExports env2 fords
        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') }
328 329

---------------------------------------------
330 331 332 333
zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
zonkLocalBinds env EmptyLocalBinds
  = return (env, EmptyLocalBinds)

334 335 336 337
zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
  = panic "zonkLocalBinds" -- Not in typechecker output

zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs))
338
  = do  { warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs
339 340 341
        ; let sig_warn | not warn_missing_sigs = noSigWarn
                       | otherwise             = localSigWarn sig_ns
              sig_ns = getTypeSigNames vb
342
        ; (env1, new_binds) <- go env sig_warn binds
343 344 345 346
        ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }
  where
    go env _ []
      = return (env, [])
347
    go env sig_warn ((r,b):bs)
348
      = do { (env1, b')  <- zonkRecMonoBinds env sig_warn b
349 350
           ; (env2, bs') <- go env1 sig_warn bs
           ; return (env2, (r,b'):bs') }
351

ian@well-typed.com's avatar
ian@well-typed.com committed
352 353
zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do
    new_binds <- mapM (wrapLocM zonk_ip_bind) binds
354
    let
355
        env1 = extendIdZonkEnv env [ n | L _ (IPBind (Right n) _) <- new_binds]
ian@well-typed.com's avatar
ian@well-typed.com committed
356
    (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
357
    return (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
358
  where
359
    zonk_ip_bind (IPBind n e)
ian@well-typed.com's avatar
ian@well-typed.com committed
360 361 362
        = do n' <- mapIPNameTc (zonkIdBndr env) n
             e' <- zonkLExpr env e
             return (IPBind n' e')
363

364
---------------------------------------------
365
zonkRecMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
366 367 368
zonkRecMonoBinds env sig_warn binds
 = fixM (\ ~(_, new_binds) -> do
        { let env1 = extendIdZonkEnv env (collectHsBindsBinders new_binds)
369
        ; binds' <- zonkMonoBinds env1 sig_warn binds
370 371
        ; return (env1, binds') })

372
---------------------------------------------
373
type SigWarn = Bool -> [Id] -> TcM ()
374 375 376 377 378 379
     -- Missing-signature warning
     -- The Bool is True for an AbsBinds, False otherwise

noSigWarn :: SigWarn
noSigWarn _ _ = return ()

380 381 382 383 384 385 386 387 388 389 390
topSigWarnIfExported :: Bag OccName -> NameSet -> SigWarn
topSigWarnIfExported exported sig_ns _ ids
  = mapM_ (topSigWarnIdIfExported exported sig_ns) ids

topSigWarnIdIfExported :: Bag OccName -> NameSet -> Id -> TcM ()
topSigWarnIdIfExported exported sig_ns id
  | getOccName id `elemBag` exported
  = topSigWarnId sig_ns id
  | otherwise
  = return ()

391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416
topSigWarn :: NameSet -> SigWarn
topSigWarn sig_ns _ ids = mapM_ (topSigWarnId sig_ns) ids

topSigWarnId :: NameSet -> Id -> TcM ()
-- The NameSet is the Ids that *lack* a signature
-- We have to do it this way round because there are
-- lots of top-level bindings that are generated by GHC
-- and that don't have signatures
topSigWarnId sig_ns id
  | idName id `elemNameSet` sig_ns = warnMissingSig msg id
  | otherwise                      = return ()
  where
    msg = ptext (sLit "Top-level binding with no type signature:")

localSigWarn :: NameSet -> SigWarn
localSigWarn sig_ns is_abs_bind ids
  | not is_abs_bind = return ()
  | otherwise       = mapM_ (localSigWarnId sig_ns) ids

localSigWarnId :: NameSet -> Id -> TcM ()
-- NameSet are the Ids that *have* type signatures
localSigWarnId sig_ns id
  | not (isSigmaTy (idType id))    = return ()
  | idName id `elemNameSet` sig_ns = return ()
  | otherwise                      = warnMissingSig msg id
  where
Gabor Greif's avatar
Gabor Greif committed
417
    msg = ptext (sLit "Polymorphic local binding with no type signature:")
418 419 420 421 422 423 424

warnMissingSig :: SDoc -> Id -> TcM ()
warnMissingSig msg id
  = do  { env0 <- tcInitTidyEnv
        ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
        ; addWarnTcM (env1, mk_msg tidy_ty) }
  where
425
    mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
426 427 428

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

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

434 435
zonk_bind :: ZonkEnv -> SigWarn -> HsBind TcId -> TcM (HsBind Id)
zonk_bind env sig_warn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
436
  = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
437
        ; sig_warn False (collectPatBinders new_pat)
438 439 440
        ; 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 443 444 445 446 447 448 449 450 451 452
zonk_bind env sig_warn (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
  = do { new_var  <- zonkIdBndr env var
       ; sig_warn False [new_var]
       ; new_expr <- zonkLExpr env expr
       ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }

zonk_bind env sig_warn bind@(FunBind { fun_id = L loc var, fun_matches = ms
                                     , fun_co_fn = co_fn })
  = do { new_var <- zonkIdBndr env var
       ; sig_warn False [new_var]
       ; (env1, new_co_fn) <- zonkCoFn env co_fn
453
       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
454 455 456 457 458
       ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
                      , fun_co_fn = new_co_fn }) }

zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                                 , abs_ev_binds = ev_binds
459
                                 , abs_exports = exports
460
                                 , abs_binds = val_binds })
461
  = ASSERT( all isImmutableTyVar tyvars )
dreixel's avatar
dreixel committed
462 463
    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
464 465
       ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
dreixel's avatar
dreixel committed
466
         do { let env3 = extendIdZonkEnv env2 (collectHsBindsBinders new_val_binds)
467 468 469
            ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds
            ; new_exports   <- mapM (zonkExport env3) exports
            ; return (new_val_binds, new_exports) }
470
       ; sig_warn True (map abe_poly new_exports)
dreixel's avatar
dreixel committed
471 472
       ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
                          , abs_ev_binds = new_ev_binds
473
                          , abs_exports = new_exports, abs_binds = new_val_bind }) }
sof's avatar
sof committed
474
  where
475 476
    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
477 478 479 480 481 482
        = 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 })
483

484 485 486 487
zonk_bind env _sig_warn (PatSynBind bind@(PSB { psb_id = L loc id
                                              , psb_args = details
                                              , psb_def = lpat
                                              , psb_dir = dir }))
cactus's avatar
cactus committed
488 489 490 491
  = do { id' <- zonkIdBndr env id
       ; details' <- zonkPatSynDetails env details
       ;(env1, lpat') <- zonkPat env lpat
       ; (_env2, dir') <- zonkPatSynDir env1 dir
492 493 494 495 496
       ; return $ PatSynBind $
                  bind { psb_id = L loc id'
                       , psb_args = details'
                       , psb_def = lpat'
                       , psb_dir = dir' } }
cactus's avatar
cactus committed
497 498 499 500 501 502 503 504 505

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)
506 507 508
zonkPatSynDir env (ExplicitBidirectional mg) = do
    mg' <- zonkMatchGroup env zonkLExpr mg
    return (env, ExplicitBidirectional mg')
cactus's avatar
cactus committed
509

510 511
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
512
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
513
                                       ; return (SpecPrags ps') }
514 515 516 517

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
518
  where
519
    zonk_prag (L loc (SpecPrag id co_fn inl))
520 521
        = do { (_, co_fn') <- zonkCoFn env co_fn
             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
522

Austin Seipp's avatar
Austin Seipp committed
523 524 525
{-
************************************************************************
*                                                                      *
526
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
527 528 529
*                                                                      *
************************************************************************
-}
530

531
zonkMatchGroup :: ZonkEnv
532 533
               -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
               -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id)))
534
zonkMatchGroup env zBody (MG { mg_alts = ms, mg_arg_tys = arg_tys, mg_res_ty = res_ty, mg_origin = origin })
535 536 537
  = do  { ms' <- mapM (zonkMatch env zBody) ms
        ; arg_tys' <- zonkTcTypeToTypes env arg_tys
        ; res_ty'  <- zonkTcTypeToType env res_ty
538
        ; return (MG { mg_alts = ms', mg_arg_tys = arg_tys', mg_res_ty = res_ty', mg_origin = origin }) }
539

540
zonkMatch :: ZonkEnv
541 542 543
          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
          -> LMatch TcId (Located (body TcId)) -> TcM (LMatch Id (Located (body Id)))
zonkMatch env zBody (L loc (Match pats _ grhss))
544 545 546
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
        ; return (L loc (Match new_pats Nothing new_grhss)) }
547

548
-------------------------------------------------------------------------
549
zonkGRHSs :: ZonkEnv
550 551
          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
          -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))
552

ian@well-typed.com's avatar
ian@well-typed.com committed
553 554
zonkGRHSs env zBody (GRHSs grhss binds) = do
    (new_env, new_binds) <- zonkLocalBinds env binds
555
    let
556
        zonk_grhs (GRHS guarded rhs)
ian@well-typed.com's avatar
ian@well-typed.com committed
557 558 559 560
          = 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
561
    return (GRHSs new_grhss new_binds)
562

Austin Seipp's avatar
Austin Seipp committed
563 564 565
{-
************************************************************************
*                                                                      *
566
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
567 568 569
*                                                                      *
************************************************************************
-}
570

571 572 573
zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
574

575
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
576
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
577

578
zonkExpr env (HsVar id)
579
  = return (HsVar (zonkIdOcc env id))
580

581
zonkExpr _ (HsIPVar id)
582
  = return (HsIPVar id)
583

584
zonkExpr env (HsLit (HsRat f ty))
ian@well-typed.com's avatar
ian@well-typed.com committed
585 586
  = do new_ty <- zonkTcTypeToType env ty
       return (HsLit (HsRat f new_ty))
sof's avatar
sof committed
587

Ian Lynagh's avatar
Ian Lynagh committed
588
zonkExpr _ (HsLit lit)
589
  = return (HsLit lit)
590 591

zonkExpr env (HsOverLit lit)
592 593
  = do  { lit' <- zonkOverLit env lit
        ; return (HsOverLit lit') }
594

595
zonkExpr env (HsLam matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
596 597
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLam new_matches)
598

599
zonkExpr env (HsLamCase arg matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
600 601 602
  = do new_arg <- zonkTcTypeToType env arg
       new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLamCase new_arg new_matches)
603

604
zonkExpr env (HsApp e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
605 606 607
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (HsApp new_e1 new_e2)
608

gmainland's avatar
gmainland committed
609 610 611
zonkExpr _ e@(HsRnBracketOut _ _)
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

612
zonkExpr env (HsTcBracketOut body bs)
ian@well-typed.com's avatar
ian@well-typed.com committed
613
  = do bs' <- mapM zonk_b bs
614
       return (HsTcBracketOut body bs')
615
  where
616 617
    zonk_b (PendSplice n e) = do e' <- zonkLExpr env e
                                 return (PendSplice n e')
gmainland's avatar
gmainland committed
618

619 620
zonkExpr _ (HsSpliceE t s) = WARN( True, ppr s ) -- Should not happen
                             return (HsSpliceE t s)
621 622

zonkExpr env (OpApp e1 op fixity e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
623 624 625 626
  = 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)
627

628
zonkExpr env (NegApp expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
629 630 631
  = do new_expr <- zonkLExpr env expr
       new_op <- zonkExpr env op
       return (NegApp new_expr new_op)
632

633
zonkExpr env (HsPar e)
ian@well-typed.com's avatar
ian@well-typed.com committed
634 635
  = do new_e <- zonkLExpr env e
       return (HsPar new_e)
636 637

zonkExpr env (SectionL expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
638 639 640
  = do new_expr <- zonkLExpr env expr
       new_op   <- zonkLExpr env op
       return (SectionL new_expr new_op)
641 642

zonkExpr env (SectionR op expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
643 644 645
  = do new_op   <- zonkLExpr env op
       new_expr <- zonkLExpr env expr
       return (SectionR new_op new_expr)
646

647 648 649 650
zonkExpr env (ExplicitTuple tup_args boxed)
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
       ; return (ExplicitTuple new_tup_args boxed) }
  where
651 652 653 654
    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')) }
655

656
zonkExpr env (HsCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
657 658 659
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLExpr ms
       return (HsCase new_expr new_ms)
660

661 662 663 664 665
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
666
       ; return (HsIf new_e0 new_e1 new_e2 new_e3) }
667

668 669 670
zonkExpr env (HsMultiIf ty alts)
  = do { alts' <- mapM (wrapLocM zonk_alt) alts
       ; ty'   <- zonkTcTypeToType env ty
671
       ; return $ HsMultiIf ty' alts' }
672
  where zonk_alt (GRHS guard expr)
673
          = do { (env', guard') <- zonkStmts env zonkLExpr guard
674
               ; expr'          <- zonkLExpr env' expr
675
               ; return $ GRHS guard' expr' }
676

677
zonkExpr env (HsLet binds expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
678 679 680
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_expr <- zonkLExpr new_env expr
       return (HsLet new_binds new_expr)
681

682
zonkExpr env (HsDo do_or_lc stmts ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
683 684 685
  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
       new_ty <- zonkTcTypeToType env ty
       return (HsDo do_or_lc new_stmts new_ty)
686

687
zonkExpr env (ExplicitList ty wit exprs)
ian@well-typed.com's avatar
ian@well-typed.com committed
688 689 690 691
  = do new_ty <- zonkTcTypeToType env ty
       new_wit <- zonkWit env wit
       new_exprs <- zonkLExprs env exprs
       return (ExplicitList new_ty new_wit new_exprs)
692
   where zonkWit _ Nothing = return Nothing
ian@well-typed.com's avatar
ian@well-typed.com committed
693 694
         zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
                                     return (Just new_fln)
695 696

zonkExpr env (ExplicitPArr ty exprs)
ian@well-typed.com's avatar
ian@well-typed.com committed
697 698 699
  = do new_ty <- zonkTcTypeToType env ty
       new_exprs <- zonkLExprs env exprs
       return (ExplicitPArr new_ty new_exprs)
700

701
zonkExpr env (RecordCon data_con con_expr rbinds)
702 703 704
  = do  { new_con_expr <- zonkExpr env con_expr
        ; new_rbinds   <- zonkRecFields env rbinds
        ; return (RecordCon data_con new_con_expr new_rbinds) }
705

706
zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
707 708 709 710 711
  = do  { new_expr    <- zonkLExpr env expr
        ; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
        ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
        ; new_rbinds  <- zonkRecFields env rbinds
        ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) }
712

713
zonkExpr env (ExprWithTySigOut e ty)
714 715 716
  = do { e' <- zonkLExpr env e
       ; return (ExprWithTySigOut e' ty) }

thomasw's avatar
thomasw committed
717
zonkExpr _ (ExprWithTySig _ _ _) = panic "zonkExpr env:ExprWithTySig"
718

719
zonkExpr env (ArithSeq expr wit info)
ian@well-typed.com's avatar
ian@well-typed.com committed
720 721 722 723
  = do new_expr <- zonkExpr env expr
       new_wit <- zonkWit env wit
       new_info <- zonkArithSeq env info
       return (ArithSeq new_expr new_wit new_info)
724
   where zonkWit _ Nothing = return Nothing
ian@well-typed.com's avatar
ian@well-typed.com committed
725 726
         zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
                                     return (Just new_fln)
727

728
zonkExpr env (PArrSeq expr info)
ian@well-typed.com's avatar
ian@well-typed.com committed
729 730 731
  = do new_expr <- zonkExpr env expr
       new_info <- zonkArithSeq env info
       return (PArrSeq new_expr new_info)
732 733

zonkExpr env (HsSCC lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
734 735
  = do new_expr <- zonkLExpr env expr
       return (HsSCC lbl new_expr)
736

andy@galois.com's avatar
andy@galois.com committed
737
zonkExpr env (HsTickPragma info expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
738 739
  = do new_expr <- zonkLExpr env expr
       return (HsTickPragma info new_expr)
andy@galois.com's avatar
andy@galois.com committed
740

741 742
-- hdaume: core annotations
zonkExpr env (HsCoreAnn lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
743 744
  = do new_expr <- zonkLExpr env expr
       return (HsCoreAnn lbl new_expr)
745

746
-- arrow notation extensions
747
zonkExpr env (HsProc pat body)
748 749 750
  = do  { (env1, new_pat) <- zonkPat env pat
        ; new_body <- zonkCmdTop env1 body
        ; return (HsProc new_pat new_body) }
751

752
zonkExpr env (HsWrap co_fn expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
753 754 755
  = do (env1, new_co_fn) <- zonkCoFn env co_fn
       new_expr <- zonkExpr env1 expr
       return (HsWrap new_co_fn new_expr)
756

757 758
zonkExpr _ (HsUnboundVar v)
  = return (HsUnboundVar v)
759

Ian Lynagh's avatar
Ian Lynagh committed
760
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
761

762 763 764 765 766 767 768
-------------------------------------------------------------------------

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

zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd

769
zonkCmd env (HsCmdCast co cmd)
Joachim Breitner's avatar
Joachim Breitner committed
770
  = do { co' <- zonkTcCoToCo env co
771
       ; cmd' <- zonkCmd env cmd
772
       ; return (HsCmdCast co' cmd') }
773
zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
ian@well-typed.com's avatar
ian@well-typed.com committed
774 775 776 777
  = 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)
778 779

zonkCmd env (HsCmdArrForm op fixity args)
ian@well-typed.com's avatar
ian@well-typed.com committed
780 781 782
  = do new_op <- zonkLExpr env op
       new_args <- mapM (zonkCmdTop env) args
       return (HsCmdArrForm new_op fixity new_args)
783 784

zonkCmd env (HsCmdApp c e)
ian@well-typed.com's avatar
ian@well-typed.com committed
785 786 787
  = do new_c <- zonkLCmd env c
       new_e <- zonkLExpr env e
       return (HsCmdApp new_c new_e)
788 789

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

793
zonkCmd env (HsCmdPar c)
ian@well-typed.com's avatar
ian@well-typed.com committed
794 795
  = do new_c <- zonkLCmd env c
       return (HsCmdPar new_c)
796 797

zonkCmd env (HsCmdCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
798 799 800
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLCmd ms
       return (HsCmdCase new_expr new_ms)
801 802 803 804 805 806

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
807
       ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
808 809

zonkCmd env (HsCmdLet binds cmd)
ian@well-typed.com's avatar
ian@well-typed.com committed
810 811 812
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_cmd <- zonkLCmd new_env cmd
       return (HsCmdLet new_binds new_cmd)
813 814

zonkCmd env (HsCmdDo stmts ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
815 816 817
  = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
       new_ty <- zonkTcTypeToType env ty
       return (HsCmdDo new_stmts new_ty)
818 819 820 821 822





823 824 825
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd

Ian Lynagh's avatar
Ian Lynagh committed
826
zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
827
zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
ian@well-typed.com's avatar
ian@well-typed.com committed
828 829 830 831 832
  = 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)
833

834
-------------------------------------------------------------------------
835
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
836
zonkCoFn env WpHole   = return (env, WpHole)
837
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
838 839
                                    ; (env2, c2') <- zonkCoFn env1 c2
                                    ; return (env2, WpCompose c1' c2') }
840 841 842 843 844
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
845
zonkCoFn env (WpCast co) = do { co' <- zonkTcCoToCo env co
846
                              ; return (env, WpCast co') }
847
zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
848 849
                                 ; return (env', WpEvLam ev') }
zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg
850
                                 ; return (env, WpEvApp arg') }
851
zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
dreixel's avatar
dreixel committed
852
                              do { (env', tv') <- zonkTyBndrX env tv
853
                                 ; return (env', WpTyLam tv') }
854
zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToType env ty
855
                                 ; return (env, WpTyApp ty') }
856
zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs
857
                                 ; return (env1, WpLet bs') }
858

859 860
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
861
zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
862 863 864
  = do  { ty' <- zonkTcTypeToType env ty
        ; e' <- zonkExpr env e
        ; return (lit { ol_witness = e', ol_type = ty' }) }
865

866
-------------------------------------------------------------------------
867
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
868

869
zonkArithSeq env (From e)
ian@well-typed.com's avatar
ian@well-typed.com committed
870 871
  = do new_e <- zonkLExpr env e
       return (From new_e)
872

873
zonkArithSeq env (FromThen e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
874 875 876
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (FromThen new_e1 new_e2)
877

878
zonkArithSeq env (FromTo e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
879 880 881
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (FromTo new_e1 new_e2)
882

883
zonkArithSeq env (FromThenTo e1 e2 e3)
ian@well-typed.com's avatar
ian@well-typed.com committed
884 885 886 887
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       new_e3 <- zonkLExpr env e3
       return (FromThenTo new_e1 new_e2 new_e3)
888

889

890
-------------------------------------------------------------------------
891
zonkStmts :: ZonkEnv
892 893 894 895 896 897 898
          -> (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') }

899
zonkStmt :: ZonkEnv
900 901 902
         -> (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)
903 904
  = do { new_stmts_w_bndrs <- mapM zonk_branch stmts_w_bndrs
       ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs]
905
             env1 = extendIdZonkEnv env new_binders
906 907 908
       ; new_mzip <- zonkExpr env1 mzip_op
       ; new_bind <- zonkExpr env1 bind_op
       ; return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind) }