TcHsSyn.hs 61.7 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
import PatSyn( patSynInstResTy )
48
import Name
49
import NameSet
50
import Var
51
import VarSet
52
import VarEnv
53
import DynFlags
54
import Literal
55 56 57
import BasicTypes
import Maybes
import SrcLoc
sof's avatar
sof committed
58
import Bag
59
import FastString
sof's avatar
sof committed
60
import Outputable
61
import Util
62
#if __GLASGOW_HASKELL__ < 709
cactus's avatar
cactus committed
63
import Data.Traversable ( traverse )
64
#endif
65

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

noSigWarn :: SigWarn
noSigWarn _ _ = return ()

381 382 383 384 385 386 387 388 389 390 391
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 ()

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 417
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
418
    msg = ptext (sLit "Polymorphic local binding with no type signature:")
419 420 421 422 423 424 425

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
426
    mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
427 428 429

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

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

435 436
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})
437
  = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
438
        ; sig_warn False (collectPatBinders new_pat)
439 440 441
        ; 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 }) }
442

443 444 445 446 447 448 449 450 451 452 453
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
454
       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
455 456 457 458 459
       ; 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
460
                                 , abs_exports = exports
461
                                 , abs_binds = val_binds })
462
  = ASSERT( all isImmutableTyVar tyvars )
dreixel's avatar
dreixel committed
463 464
    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
465
       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
466
       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
dreixel's avatar
dreixel committed
467
         do { let env3 = extendIdZonkEnv env2 (collectHsBindsBinders new_val_binds)
468 469 470
            ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds
            ; new_exports   <- mapM (zonkExport env3) exports
            ; return (new_val_binds, new_exports) }
471
       ; sig_warn True (map abe_poly new_exports)
dreixel's avatar
dreixel committed
472 473
       ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
                          , abs_ev_binds = new_ev_binds
474
                          , abs_exports = new_exports, abs_binds = new_val_bind }) }
sof's avatar
sof committed
475
  where
476 477
    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
478 479 480 481 482 483
        = 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 })
484

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

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

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

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

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

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

541
zonkMatch :: ZonkEnv
542 543
          -> (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
544
zonkMatch env zBody (L loc (Match mf pats _ grhss))
545 546
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
Alan Zimmerman's avatar
Alan Zimmerman committed
547
        ; return (L loc (Match mf new_pats Nothing new_grhss)) }
548

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

707
zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
708 709 710 711 712
  = 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) }
713

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

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

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

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

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

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

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

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

753 754 755 756
-- StaticPointers extension
zonkExpr env (HsStatic expr)
  = HsStatic <$> zonkLExpr env expr

757
zonkExpr env (HsWrap co_fn expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
758 759 760
  = do (env1, new_co_fn) <- zonkCoFn env co_fn
       new_expr <- zonkExpr env1 expr
       return (HsWrap new_co_fn new_expr)
761

762 763
zonkExpr _ (HsUnboundVar v)
  = return (HsUnboundVar v)
764

Ian Lynagh's avatar
Ian Lynagh committed
765
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
766

767 768 769 770 771 772 773
-------------------------------------------------------------------------

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

zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd

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

zonkCmd env (HsCmdArrForm op fixity args)
ian@well-typed.com's avatar
ian@well-typed.com committed
785 786 787
  = do new_op <- zonkLExpr env op
       new_args <- mapM (zonkCmdTop env) args
       return (HsCmdArrForm new_op fixity new_args)
788 789

zonkCmd env (HsCmdApp c e)
ian@well-typed.com's avatar
ian@well-typed.com committed
790 791 792
  = do new_c <- zonkLCmd env c
       new_e <- zonkLExpr env e
       return (HsCmdApp new_c new_e)
793 794

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

798
zonkCmd env (HsCmdPar c)
ian@well-typed.com's avatar
ian@well-typed.com committed
799 800
  = do new_c <- zonkLCmd env c
       return (HsCmdPar new_c)
801 802

zonkCmd env (HsCmdCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
803 804 805
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLCmd ms
       return (HsCmdCase new_expr new_ms)
806 807 808 809 810 811

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
812
       ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
813 814

zonkCmd env (HsCmdLet binds cmd)
ian@well-typed.com's avatar
ian@well-typed.com committed
815 816 817
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_cmd <- zonkLCmd new_env cmd
       return (HsCmdLet new_binds new_cmd)
818 819

zonkCmd env (HsCmdDo stmts ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
820 821 822
  = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
       new_ty <- zonkTcTypeToType env ty
       return (HsCmdDo new_stmts new_ty)
823 824 825 826 827





828 829 830
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd

Ian Lynagh's avatar
Ian Lynagh committed
831
zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
832
zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
ian@well-typed.com's avatar
ian@well-typed.com committed
833 834 835 836 837
  = 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)
838

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

864 865
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
866
zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
867 868 869
  = do  { ty' <- zonkTcTypeToType env ty
        ; e' <- zonkExpr env e
        ; return (lit { ol_witness = e', ol_type = ty' }) }
870

871
-------------------------------------------------------------------------
872
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
873

874
zonkArithSeq env (From e)
ian@well-typed.com's avatar
ian@well-typed.com committed
875 876
  = do new_e <- zonkLExpr env e
       return (From new_e)
877

878
zonkArithSeq env (FromThen 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 (FromThen new_e1 new_e2)
882

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

888
zonkArithSeq env (FromThenTo e1 e2 e3)
ian@well-typed.com's avatar
ian@well-typed.com committed
889 890 891 892
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       new_e3 <- zonkLExpr env e3
       return (FromThenTo new_e1 new_e2 new_e3)
893

894

895
-------------------------------------------------------------------------
896
zonkStmts :: ZonkEnv
Simon Peyton Jones's avatar