TcHsSyn.hs 62.4 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 RdrName ( RdrName, rdrNameOcc )
40
import TcMType ( defaultKindVarToStar, zonkQuantifiedTyVar, writeMetaTyVar )
41
import TcEvidence
42
import Coercion
43 44
import TysPrim
import TysWiredIn
dreixel's avatar
dreixel committed
45
import Type
46
import ConLike
47
import DataCon
48
import PatSyn( patSynInstResTy )
49
import Name
50
import NameSet
51
import Var
52
import VarSet
53
import VarEnv
54
import DynFlags
55
import Literal
56 57 58
import BasicTypes
import Maybes
import SrcLoc
sof's avatar
sof committed
59
import Bag
60
import FastString
sof's avatar
sof committed
61
import Outputable
62
import Util
63
#if __GLASGOW_HASKELL__ < 709
cactus's avatar
cactus committed
64
import Data.Traversable ( traverse )
65
#endif
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 84 85 86 87 88 89
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
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
Austin Seipp's avatar
Austin Seipp committed
93
hsPatType (TuplePat _ bx tys)         = mkTupleTy (boxityNormalTupleSort 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 104 105
conLikeResTy :: ConLike -> [Type] -> Type
conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys
conLikeResTy (PatSynCon ps)    tys = patSynInstResTy ps tys

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

316 317
         -- Warn about missing signatures
         -- Do this only when we we have a type to offer
318
        ; warn_missing_sigs <- woptM Opt_WarnMissingSigs
319
        ; warn_only_exported <- woptM Opt_WarnMissingExportedSigs
320 321 322 323 324
        ; let export_occs  = maybe emptyBag
                                   (listToBag . map (rdrNameOcc . ieName . unLoc) . unLoc)
                                   export_ies
              sig_warn
                | warn_only_exported = topSigWarnIfExported export_occs sig_ns
325 326
                | warn_missing_sigs  = topSigWarn sig_ns
                | otherwise          = noSigWarn
327 328

        ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds
329 330 331
                        -- Top level is implicitly recursive
        ; rules' <- zonkRules env2 rules
        ; vects' <- zonkVects env2 vects
332
        ; specs' <- zonkLTcSpecPrags env2 imp_specs
333 334
        ; fords' <- zonkForeignExports env2 fords
        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') }
335 336

---------------------------------------------
337 338 339 340
zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
zonkLocalBinds env EmptyLocalBinds
  = return (env, EmptyLocalBinds)

341 342 343 344
zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
  = panic "zonkLocalBinds" -- Not in typechecker output

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

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

371
---------------------------------------------
372
zonkRecMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
373 374 375
zonkRecMonoBinds env sig_warn binds
 = fixM (\ ~(_, new_binds) -> do
        { let env1 = extendIdZonkEnv env (collectHsBindsBinders new_binds)
376
        ; binds' <- zonkMonoBinds env1 sig_warn binds
377 378
        ; return (env1, binds') })

379
---------------------------------------------
380
type SigWarn = Bool -> [Id] -> TcM ()
381 382 383 384 385 386
     -- Missing-signature warning
     -- The Bool is True for an AbsBinds, False otherwise

noSigWarn :: SigWarn
noSigWarn _ _ = return ()

387 388 389 390 391 392 393 394 395 396 397
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 ()

398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423
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
424
    msg = ptext (sLit "Polymorphic local binding with no type signature:")
425 426 427 428 429 430 431

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
432
    mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
433 434 435

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

438 439
zonk_lbind :: ZonkEnv -> SigWarn -> LHsBind TcId -> TcM (LHsBind Id)
zonk_lbind env sig_warn = wrapLocM (zonk_bind env sig_warn)
440

441 442
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})
443
  = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
444
        ; sig_warn False (collectPatBinders new_pat)
445 446 447
        ; 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 }) }
448

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

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

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)
513 514 515
zonkPatSynDir env (ExplicitBidirectional mg) = do
    mg' <- zonkMatchGroup env zonkLExpr mg
    return (env, ExplicitBidirectional mg')
cactus's avatar
cactus committed
516

517 518
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
519
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
520
                                       ; return (SpecPrags ps') }
521 522 523 524

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
525
  where
526
    zonk_prag (L loc (SpecPrag id co_fn inl))
527 528
        = do { (_, co_fn') <- zonkCoFn env co_fn
             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
529

Austin Seipp's avatar
Austin Seipp committed
530 531 532
{-
************************************************************************
*                                                                      *
533
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
534 535 536
*                                                                      *
************************************************************************
-}
537

538
zonkMatchGroup :: ZonkEnv
539 540
               -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
               -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id)))
541
zonkMatchGroup env zBody (MG { mg_alts = ms, mg_arg_tys = arg_tys, mg_res_ty = res_ty, mg_origin = origin })
542 543 544
  = do  { ms' <- mapM (zonkMatch env zBody) ms
        ; arg_tys' <- zonkTcTypeToTypes env arg_tys
        ; res_ty'  <- zonkTcTypeToType env res_ty
545
        ; return (MG { mg_alts = ms', mg_arg_tys = arg_tys', mg_res_ty = res_ty', mg_origin = origin }) }
546

547
zonkMatch :: ZonkEnv
548 549
          -> (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
550
zonkMatch env zBody (L loc (Match mf pats _ grhss))
551 552
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
Alan Zimmerman's avatar
Alan Zimmerman committed
553
        ; return (L loc (Match mf new_pats Nothing new_grhss)) }
554

555
-------------------------------------------------------------------------
556
zonkGRHSs :: ZonkEnv
557 558
          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
          -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))
559

560
zonkGRHSs env zBody (GRHSs grhss binds) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
561
    (new_env, new_binds) <- zonkLocalBinds env binds
562
    let
563
        zonk_grhs (GRHS guarded rhs)
ian@well-typed.com's avatar
ian@well-typed.com committed
564 565 566 567
          = 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
568
    return (GRHSs new_grhss new_binds)
569

Austin Seipp's avatar
Austin Seipp committed
570 571 572
{-
************************************************************************
*                                                                      *
573
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
574 575 576
*                                                                      *
************************************************************************
-}
577

578 579 580
zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
581

582
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
583
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
584

585
zonkExpr env (HsVar id)
586
  = return (HsVar (zonkIdOcc env id))
587

588
zonkExpr _ (HsIPVar id)
589
  = return (HsIPVar id)
590

591
zonkExpr env (HsLit (HsRat f ty))
ian@well-typed.com's avatar
ian@well-typed.com committed
592 593
  = do new_ty <- zonkTcTypeToType env ty
       return (HsLit (HsRat f new_ty))
sof's avatar
sof committed
594

Ian Lynagh's avatar
Ian Lynagh committed
595
zonkExpr _ (HsLit lit)
596
  = return (HsLit lit)
597 598

zonkExpr env (HsOverLit lit)
599 600
  = do  { lit' <- zonkOverLit env lit
        ; return (HsOverLit lit') }
601

602
zonkExpr env (HsLam matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
603 604
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLam new_matches)
605

606
zonkExpr env (HsLamCase arg matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
607 608 609
  = do new_arg <- zonkTcTypeToType env arg
       new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLamCase new_arg new_matches)
610

611
zonkExpr env (HsApp e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
612 613 614
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (HsApp new_e1 new_e2)
615

gmainland's avatar
gmainland committed
616 617 618
zonkExpr _ e@(HsRnBracketOut _ _)
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

619
zonkExpr env (HsTcBracketOut body bs)
ian@well-typed.com's avatar
ian@well-typed.com committed
620
  = do bs' <- mapM zonk_b bs
621
       return (HsTcBracketOut body bs')
622
  where
623 624
    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
                                      return (PendingTcSplice n e')
gmainland's avatar
gmainland committed
625

626 627
zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE s)
628 629

zonkExpr env (OpApp e1 op fixity e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
630 631 632 633
  = 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)
634

635
zonkExpr env (NegApp expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
636 637 638
  = do new_expr <- zonkLExpr env expr
       new_op <- zonkExpr env op
       return (NegApp new_expr new_op)
639

640
zonkExpr env (HsPar e)
ian@well-typed.com's avatar
ian@well-typed.com committed
641 642
  = do new_e <- zonkLExpr env e
       return (HsPar new_e)
643 644

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

zonkExpr env (SectionR op expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
650 651 652
  = do new_op   <- zonkLExpr env op
       new_expr <- zonkLExpr env expr
       return (SectionR new_op new_expr)
653

654 655 656 657
zonkExpr env (ExplicitTuple tup_args boxed)
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
       ; return (ExplicitTuple new_tup_args boxed) }
  where
658 659 660 661
    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')) }
662

663
zonkExpr env (HsCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
664 665 666
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLExpr ms
       return (HsCase new_expr new_ms)
667

668 669 670 671 672
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
673
       ; return (HsIf new_e0 new_e1 new_e2 new_e3) }
674

675 676 677
zonkExpr env (HsMultiIf ty alts)
  = do { alts' <- mapM (wrapLocM zonk_alt) alts
       ; ty'   <- zonkTcTypeToType env ty
678
       ; return $ HsMultiIf ty' alts' }
679
  where zonk_alt (GRHS guard expr)
680
          = do { (env', guard') <- zonkStmts env zonkLExpr guard
681
               ; expr'          <- zonkLExpr env' expr
682
               ; return $ GRHS guard' expr' }
683

684
zonkExpr env (HsLet binds expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
685 686
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_expr <- zonkLExpr new_env expr
687
       return (HsLet new_binds new_expr)
688

689
zonkExpr env (HsDo do_or_lc stmts ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
690 691
  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
       new_ty <- zonkTcTypeToType env ty
692
       return (HsDo do_or_lc new_stmts new_ty)
693

694
zonkExpr env (ExplicitList ty wit exprs)
ian@well-typed.com's avatar
ian@well-typed.com committed
695 696 697 698
  = do new_ty <- zonkTcTypeToType env ty
       new_wit <- zonkWit env wit
       new_exprs <- zonkLExprs env exprs
       return (ExplicitList new_ty new_wit new_exprs)
699
   where zonkWit _ Nothing = return Nothing
ian@well-typed.com's avatar
ian@well-typed.com committed
700 701
         zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
                                     return (Just new_fln)
702 703

zonkExpr env (ExplicitPArr ty exprs)
ian@well-typed.com's avatar
ian@well-typed.com committed
704 705 706
  = do new_ty <- zonkTcTypeToType env ty
       new_exprs <- zonkLExprs env exprs
       return (ExplicitPArr new_ty new_exprs)
707

708
zonkExpr env (RecordCon data_con con_expr rbinds)
709 710 711
  = do  { new_con_expr <- zonkExpr env con_expr
        ; new_rbinds   <- zonkRecFields env rbinds
        ; return (RecordCon data_con new_con_expr new_rbinds) }
712

713
zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
714 715 716 717 718
  = 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) }
719

720
zonkExpr env (ExprWithTySigOut e ty)
721 722 723
  = do { e' <- zonkLExpr env e
       ; return (ExprWithTySigOut e' ty) }

thomasw's avatar
thomasw committed
724
zonkExpr _ (ExprWithTySig _ _ _) = panic "zonkExpr env:ExprWithTySig"
725

726
zonkExpr env (ArithSeq expr wit info)
ian@well-typed.com's avatar
ian@well-typed.com committed
727 728 729 730
  = do new_expr <- zonkExpr env expr
       new_wit <- zonkWit env wit
       new_info <- zonkArithSeq env info
       return (ArithSeq new_expr new_wit new_info)
731
   where zonkWit _ Nothing = return Nothing
ian@well-typed.com's avatar
ian@well-typed.com committed
732 733
         zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
                                     return (Just new_fln)
734

735
zonkExpr env (PArrSeq expr info)
ian@well-typed.com's avatar
ian@well-typed.com committed
736 737 738
  = do new_expr <- zonkExpr env expr
       new_info <- zonkArithSeq env info
       return (PArrSeq new_expr new_info)
739

Alan Zimmerman's avatar
Alan Zimmerman committed
740
zonkExpr env (HsSCC src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
741
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
742
       return (HsSCC src lbl new_expr)
743

Alan Zimmerman's avatar
Alan Zimmerman committed
744
zonkExpr env (HsTickPragma src info expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
745
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
746
       return (HsTickPragma src info new_expr)
andy@galois.com's avatar
andy@galois.com committed
747

748
-- hdaume: core annotations
Alan Zimmerman's avatar
Alan Zimmerman committed
749
zonkExpr env (HsCoreAnn src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
750
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
751
       return (HsCoreAnn src lbl new_expr)
752

753
-- arrow notation extensions
754
zonkExpr env (HsProc pat body)
755 756 757
  = do  { (env1, new_pat) <- zonkPat env pat
        ; new_body <- zonkCmdTop env1 body
        ; return (HsProc new_pat new_body) }
758

759 760 761 762
-- StaticPointers extension
zonkExpr env (HsStatic expr)
  = HsStatic <$> zonkLExpr env expr

763
zonkExpr env (HsWrap co_fn expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
764 765 766
  = do (env1, new_co_fn) <- zonkCoFn env co_fn
       new_expr <- zonkExpr env1 expr
       return (HsWrap new_co_fn new_expr)
767

768 769
zonkExpr _ (HsUnboundVar v)
  = return (HsUnboundVar v)
770

Ian Lynagh's avatar
Ian Lynagh committed
771
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
772

773 774 775 776 777 778 779
-------------------------------------------------------------------------

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

zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd

780
zonkCmd env (HsCmdCast co cmd)
Joachim Breitner's avatar
Joachim Breitner committed
781
  = do { co' <- zonkTcCoToCo env co
782
       ; cmd' <- zonkCmd env cmd
783
       ; return (HsCmdCast co' cmd') }
784
zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
ian@well-typed.com's avatar
ian@well-typed.com committed
785 786 787 788
  = 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)
789 790

zonkCmd env (HsCmdArrForm op fixity args)
ian@well-typed.com's avatar
ian@well-typed.com committed
791 792 793
  = do new_op <- zonkLExpr env op
       new_args <- mapM (zonkCmdTop env) args
       return (HsCmdArrForm new_op fixity new_args)
794 795

zonkCmd env (HsCmdApp c e)
ian@well-typed.com's avatar
ian@well-typed.com committed
796 797 798
  = do new_c <- zonkLCmd env c
       new_e <- zonkLExpr env e
       return (HsCmdApp new_c new_e)
799 800

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

804
zonkCmd env (HsCmdPar c)
ian@well-typed.com's avatar
ian@well-typed.com committed
805 806
  = do new_c <- zonkLCmd env c
       return (HsCmdPar new_c)
807 808

zonkCmd env (HsCmdCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
809 810 811
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLCmd ms
       return (HsCmdCase new_expr new_ms)
812 813 814 815 816 817

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

820
zonkCmd env (HsCmdLet binds cmd)
ian@well-typed.com's avatar
ian@well-typed.com committed
821 822
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_cmd <- zonkLCmd new_env cmd
823
       return (HsCmdLet new_binds new_cmd)
824

825
zonkCmd env (HsCmdDo stmts ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
826 827
  = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
       new_ty <- zonkTcTypeToType env ty
828
       return (HsCmdDo new_stmts new_ty)
829 830 831 832 833





834 835 836
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd

Ian Lynagh's avatar
Ian Lynagh committed
837
zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
838
zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
ian@well-typed.com's avatar
ian@well-typed.com committed
839 840 841 842 843
  = 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)
844

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

870 871
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
872
zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
873 874 875
  = do  { ty' <- zonkTcTypeToType env ty
        ; e' <- zonkExpr env e
        ; return (lit { ol_witness = e', ol_type = ty' }) }
876

877
-------------------------------------------------------------------------
878
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
879

880
zonkArithSeq env (From e)
ian@well-typed.com's avatar
ian@well-typed.com committed
881 882
  = do new_e <- zonkLExpr env e
       return (From new_e)
883

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

simonpj's avatar