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

5 6

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

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

12 13
{-# LANGUAGE CPP #-}

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

        -- re-exported from TcMonad
        TcId, TcIdSet,

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

32
#include "HsVersions.h"
33

34
import HsSyn
35
import Id
36
import TcRnMonad
37
import PrelNames
38
import TcType
39
import TcMType
40
import TcEvidence
41 42
import TysPrim
import TysWiredIn
dreixel's avatar
dreixel committed
43
import Type
44
import Coercion
45
import ConLike
46
import DataCon
47 48
import Name
import Var
49
import VarSet
50
import VarEnv
51
import DynFlags
52
import Literal
53 54 55
import BasicTypes
import Maybes
import SrcLoc
sof's avatar
sof committed
56
import Bag
sof's avatar
sof committed
57
import Outputable
58
import Util
59 60
import qualified GHC.LanguageExtensions as LangExt

61 62
import Control.Monad
import Data.List  ( partition )
63
import Control.Arrow ( second )
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
hsPatType :: Pat Id -> Type
hsPatType (ParPat pat)                = hsLPatType pat
hsPatType (WildPat ty)                = ty
82
hsPatType (VarPat (L _ var))          = idType var
Ian Lynagh's avatar
Ian Lynagh committed
83 84 85 86 87
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 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
hsPatType (SigPatOut _ ty)            = ty
95 96
hsPatType (NPat _ _ _ ty)             = ty
hsPatType (NPlusKPat _ _ _ _ _ ty)    = ty
Ian Lynagh's avatar
Ian Lynagh committed
97 98
hsPatType (CoPat _ _ ty)              = ty
hsPatType p                           = pprPanic "hsPatType" (ppr p)
99

100

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

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

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

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

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

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

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

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

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

167 168 169
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
170

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

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

179 180 181 182 183 184 185 186 187 188 189
-- | A ZonkEnv carries around several bits.
-- The UnboundTyVarZonker just zaps unbouned meta-tyvars to Any (as
-- defined in zonkTypeZapping), except on the LHS of rules. See
-- Note [Zonking the LHS of a RULE]. The (TyCoVarEnv TyVar) and is just
-- an optimisation: when binding a tyvar or covar, we zonk the kind right away
-- and add a mapping to the env. This prevents re-zonking the kind at
-- every occurrence. But this is *just* an optimisation.
-- The final (IdEnv Var) optimises zonking for
-- Ids. It is knot-tied. We must be careful never to put coercion variables
-- (which are Ids, after all) in the knot-tied env, because coercions can
-- appear in types, and we sometimes inspect a zonked type in this module.
190 191
data ZonkEnv
  = ZonkEnv
dreixel's avatar
dreixel committed
192
      UnboundTyVarZonker
193 194
      (TyCoVarEnv TyVar)
      (IdEnv      Var)         -- What variables are in scope
195 196 197 198 199 200 201
        -- 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
202 203 204
  ppr (ZonkEnv _ _ty_env var_env) = vcat (map ppr (varEnvElts var_env))


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

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

212 213 214 215 216
-- | Extend the knot-tied environment.
extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv
extendIdZonkEnvRec (ZonkEnv zonk_ty ty_env id_env) ids
    -- NB: Don't look at the var to decide which env't to put it in. That
    -- would end up knot-tying all the env'ts.
dreixel's avatar
dreixel committed
217
  = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
218 219 220 221 222 223 224 225 226 227 228 229
  -- Given coercion variables will actually end up here. That's OK though:
  -- coercion variables are never looked up in the knot-tied env't, so zonking
  -- them simply doesn't get optimised. No one gets hurt. An improvement (?)
  -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the
  -- recursive groups. But perhaps the time it takes to do the analysis is
  -- more than the savings.

extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
extendZonkEnv (ZonkEnv zonk_ty tyco_env id_env) vars
  = ZonkEnv zonk_ty (extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars])
                    (extendVarEnvList id_env   [(id,id) | id <- ids])
  where (tycovars, ids) = partition isTyCoVar vars
230

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

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

setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
240 241
setZonkType (ZonkEnv _ ty_env id_env) zonk_ty
  = ZonkEnv zonk_ty ty_env id_env
242

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

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

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

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

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

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

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

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

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

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

305 306 307 308 309 310
zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm
zonkEvVarOcc env v
  | isCoVar v
  = EvCoercion <$> zonkCoVarOcc env v
  | otherwise
  = return (EvId $ zonkIdOcc env v)
dreixel's avatar
dreixel committed
311 312

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

zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar)
316 317
-- 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
318
zonkTyBndrX env tv
319 320
  = ASSERT( isImmutableTyVar tv )
    do { ki <- zonkTcTypeToType env (tyVarKind tv)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
321
               -- Internal names tidy up better, for iface files.
322 323
       ; let tv' = mkTyVar (tyVarName tv) ki
       ; return (extendTyZonkEnv1 env tv', tv') }
324

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

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

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

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

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

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

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

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

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

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

397 398
zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
399 400 401 402
  = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
        ; new_grhss <- zonkGRHSs env zonkLExpr grhss
        ; new_ty    <- zonkTcTypeToType env ty
        ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
403

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

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

417 418 419 420
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                        , abs_ev_binds = ev_binds
                        , abs_exports = exports
                        , abs_binds = val_binds })
421
  = ASSERT( all isImmutableTyVar tyvars )
dreixel's avatar
dreixel committed
422 423
    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
424
       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
425
       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
426 427
         do { let env3 = extendIdZonkEnvRec env2
                           (collectHsBindsBinders new_val_binds)
428
            ; new_val_binds <- zonkMonoBinds env3 val_binds
429 430
            ; new_exports   <- mapM (zonkExport env3) exports
            ; return (new_val_binds, new_exports) }
dreixel's avatar
dreixel committed
431 432
       ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
                          , abs_ev_binds = new_ev_binds
433
                          , abs_exports = new_exports, abs_binds = new_val_bind }) }
sof's avatar
sof committed
434
  where
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
435 436
    zonkExport env (ABE{ abe_wrap = wrap, abe_inst_wrap = inst_wrap
                       , abe_poly = poly_id
437
                       , abe_mono = mono_id, abe_prags = prags })
ian@well-typed.com's avatar
ian@well-typed.com committed
438 439
        = do new_poly_id <- zonkIdBndr env poly_id
             (_, new_wrap) <- zonkCoFn env wrap
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
440
             (_, new_inst_wrap) <- zonkCoFn env inst_wrap
ian@well-typed.com's avatar
ian@well-typed.com committed
441
             new_prags <- zonkSpecPrags env prags
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
442 443
             return (ABE{ abe_wrap = new_wrap, abe_inst_wrap = new_inst_wrap
                        , abe_poly = new_poly_id
ian@well-typed.com's avatar
ian@well-typed.com committed
444 445
                        , abe_mono = zonkIdOcc env mono_id
                        , abe_prags = new_prags })
446

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466
zonk_bind env (AbsBindsSig { abs_tvs         = tyvars
                           , abs_ev_vars     = evs
                           , abs_sig_export  = poly
                           , abs_sig_prags   = prags
                           , abs_sig_ev_bind = ev_bind
                           , abs_sig_bind    = bind })
  = ASSERT( all isImmutableTyVar tyvars )
    do { (env0, new_tyvars)  <- zonkTyBndrsX env  tyvars
       ; (env1, new_evs)     <- zonkEvBndrsX env0 evs
       ; (env2, new_ev_bind) <- zonkTcEvBinds env1 ev_bind
       ; new_val_bind        <- zonk_lbind env2 bind
       ; new_poly_id         <- zonkIdBndr env2 poly
       ; new_prags           <- zonkSpecPrags env2 prags
       ; return (AbsBindsSig { abs_tvs         = new_tyvars
                             , abs_ev_vars     = new_evs
                             , abs_sig_export  = new_poly_id
                             , abs_sig_prags   = new_prags
                             , abs_sig_ev_bind = new_ev_bind
                             , abs_sig_bind    = new_val_bind  }) }

467 468 469 470
zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id
                                    , psb_args = details
                                    , psb_def = lpat
                                    , psb_dir = dir }))
cactus's avatar
cactus committed
471 472
  = do { id' <- zonkIdBndr env id
       ; details' <- zonkPatSynDetails env details
473
       ; (env1, lpat') <- zonkPat env lpat
cactus's avatar
cactus committed
474
       ; (_env2, dir') <- zonkPatSynDir env1 dir
475 476 477 478 479
       ; return $ PatSynBind $
                  bind { psb_id = L loc id'
                       , psb_args = details'
                       , psb_def = lpat'
                       , psb_dir = dir' } }
cactus's avatar
cactus committed
480 481 482 483 484 485 486 487 488

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)
489 490 491
zonkPatSynDir env (ExplicitBidirectional mg) = do
    mg' <- zonkMatchGroup env zonkLExpr mg
    return (env, ExplicitBidirectional mg')
cactus's avatar
cactus committed
492

493 494
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
495
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
496
                                       ; return (SpecPrags ps') }
497 498 499 500

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
501
  where
502
    zonk_prag (L loc (SpecPrag id co_fn inl))
503 504
        = do { (_, co_fn') <- zonkCoFn env co_fn
             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
505

Austin Seipp's avatar
Austin Seipp committed
506 507 508
{-
************************************************************************
*                                                                      *
509
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
510 511 512
*                                                                      *
************************************************************************
-}
513

514
zonkMatchGroup :: ZonkEnv
515 516
               -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
               -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id)))
517 518
zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys
                             , mg_res_ty = res_ty, mg_origin = origin })
519 520 521
  = do  { ms' <- mapM (zonkMatch env zBody) ms
        ; arg_tys' <- zonkTcTypeToTypes env arg_tys
        ; res_ty'  <- zonkTcTypeToType env res_ty
522 523
        ; return (MG { mg_alts = L l ms', mg_arg_tys = arg_tys'
                     , mg_res_ty = res_ty', mg_origin = origin }) }
524

525
zonkMatch :: ZonkEnv
526 527
          -> (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
528
zonkMatch env zBody (L loc (Match mf pats _ grhss))
529 530
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
Alan Zimmerman's avatar
Alan Zimmerman committed
531
        ; return (L loc (Match mf new_pats Nothing new_grhss)) }
532

533
-------------------------------------------------------------------------
534
zonkGRHSs :: ZonkEnv
535 536
          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
          -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))
537

538
zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
539
    (new_env, new_binds) <- zonkLocalBinds env binds
540
    let
541
        zonk_grhs (GRHS guarded rhs)
ian@well-typed.com's avatar
ian@well-typed.com committed
542 543 544 545
          = 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
546
    return (GRHSs new_grhss (L l new_binds))
547

Austin Seipp's avatar
Austin Seipp committed
548 549 550
{-
************************************************************************
*                                                                      *
551
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
552 553 554
*                                                                      *
************************************************************************
-}
555

556 557 558
zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
559

560
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
561
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
562

563 564
zonkExpr env (HsVar (L l id))
  = return (HsVar (L l (zonkIdOcc env id)))
565

566
zonkExpr _ (HsIPVar id)
567
  = return (HsIPVar id)
568

Adam Gundry's avatar
Adam Gundry committed
569 570 571
zonkExpr _ (HsOverLabel l)
  = return (HsOverLabel l)

572
zonkExpr env (HsLit (HsRat f ty))
ian@well-typed.com's avatar
ian@well-typed.com committed
573 574
  = do new_ty <- zonkTcTypeToType env ty
       return (HsLit (HsRat f new_ty))
sof's avatar
sof committed
575

Ian Lynagh's avatar
Ian Lynagh committed
576
zonkExpr _ (HsLit lit)
577
  = return (HsLit lit)
578 579

zonkExpr env (HsOverLit lit)
580 581
  = do  { lit' <- zonkOverLit env lit
        ; return (HsOverLit lit') }
582

583
zonkExpr env (HsLam matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
584 585
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLam new_matches)
586

587
zonkExpr env (HsLamCase arg matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
588 589 590
  = do new_arg <- zonkTcTypeToType env arg
       new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLamCase new_arg new_matches)
591

592
zonkExpr env (HsApp e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
593 594 595
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (HsApp new_e1 new_e2)
596

gmainland's avatar
gmainland committed
597 598 599
zonkExpr _ e@(HsRnBracketOut _ _)
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

600
zonkExpr env (HsTcBracketOut body bs)
ian@well-typed.com's avatar
ian@well-typed.com committed
601
  = do bs' <- mapM zonk_b bs
602
       return (HsTcBracketOut body bs')
603
  where
604 605
    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
                                      return (PendingTcSplice n e')
gmainland's avatar
gmainland committed
606

607 608
zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE s)
609 610

zonkExpr env (OpApp e1 op fixity e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
611 612 613 614
  = 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)
615

616
zonkExpr env (NegApp expr op)
617 618
  = do (env', new_op) <- zonkSyntaxExpr env op
       new_expr <- zonkLExpr env' expr
ian@well-typed.com's avatar
ian@well-typed.com committed
619
       return (NegApp new_expr new_op)
620

621
zonkExpr env (HsPar e)
ian@well-typed.com's avatar
ian@well-typed.com committed
622 623
  = do new_e <- zonkLExpr env e
       return (HsPar new_e)
624 625

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

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

635 636 637 638
zonkExpr env (ExplicitTuple tup_args boxed)
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
       ; return (ExplicitTuple new_tup_args boxed) }
  where
639 640 641 642
    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')) }
643

644
zonkExpr env (HsCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
645 646 647
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLExpr ms
       return (HsCase new_expr new_ms)
648

649 650 651 652 653 654 655 656 657 658 659 660
zonkExpr env (HsIf Nothing e1 e2 e3)
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       new_e3 <- zonkLExpr env e3
       return (HsIf Nothing new_e1 new_e2 new_e3)

zonkExpr env (HsIf (Just fun) e1 e2 e3)
  = do (env1, new_fun) <- zonkSyntaxExpr env fun
       new_e1 <- zonkLExpr env1 e1
       new_e2 <- zonkLExpr env1 e2
       new_e3 <- zonkLExpr env1 e3
       return (HsIf (Just new_fun) new_e1 new_e2 new_e3)
661

662 663 664
zonkExpr env (HsMultiIf ty alts)
  = do { alts' <- mapM (wrapLocM zonk_alt) alts
       ; ty'   <- zonkTcTypeToType env ty
665
       ; return $ HsMultiIf ty' alts' }
666
  where zonk_alt (GRHS guard expr)
667
          = do { (env', guard') <- zonkStmts env zonkLExpr guard
668
               ; expr'          <- zonkLExpr env' expr
669
               ; return $ GRHS guard' expr' }
670

671
zonkExpr env (HsLet (L l binds) expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
672 673
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_expr <- zonkLExpr new_env expr
674
       return (HsLet (L l new_binds) new_expr)
675

676
zonkExpr env (HsDo do_or_lc (L l stmts) ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
677 678
  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
       new_ty <- zonkTcTypeToType env ty
679
       return (HsDo do_or_lc (L l new_stmts) new_ty)
680

681
zonkExpr env (ExplicitList ty wit exprs)
682 683 684
  = do (env1, new_wit) <- zonkWit env wit
       new_ty <- zonkTcTypeToType env1 ty
       new_exprs <- zonkLExprs env1 exprs
ian@well-typed.com's avatar
ian@well-typed.com committed
685
       return (ExplicitList new_ty new_wit new_exprs)
686 687
   where zonkWit env Nothing    = return (env, Nothing)
         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
688 689

zonkExpr env (ExplicitPArr ty exprs)
ian@well-typed.com's avatar
ian@well-typed.com committed
690 691 692
  = do new_ty <- zonkTcTypeToType env ty
       new_exprs <- zonkLExprs env exprs
       return (ExplicitPArr new_ty new_exprs)
693

694
zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds })
695 696
  = do  { new_con_expr <- zonkExpr env con_expr
        ; new_rbinds   <- zonkRecFields env rbinds
697 698
        ; return (expr { rcon_con_expr = new_con_expr
                       , rcon_flds = new_rbinds }) }
699

700 701 702
zonkExpr env (RecordUpd { rupd_expr = expr, rupd_flds = rbinds
                        , rupd_cons = cons, rupd_in_tys = in_tys
                        , rupd_out_tys = out_tys, rupd_wrap = req_wrap })
703 704 705
  = do  { new_expr    <- zonkLExpr env expr
        ; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
        ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
706
        ; new_rbinds  <- zonkRecUpdFields env rbinds
Matthew Pickering's avatar
Matthew Pickering committed
707
        ; (_, new_recwrap) <- zonkCoFn env req_wrap
708 709 710
        ; return (RecordUpd { rupd_expr = new_expr, rupd_flds =  new_rbinds
                            , rupd_cons = cons, rupd_in_tys = new_in_tys
                            , rupd_out_tys = new_out_tys, rupd_wrap = new_recwrap }) }
711

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

716
zonkExpr env (ArithSeq expr wit info)
717 718 719
  = do (env1, new_wit) <- zonkWit env wit
       new_expr <- zonkExpr env expr
       new_info <- zonkArithSeq env1 info
ian@well-typed.com's avatar
ian@well-typed.com committed
720
       return (ArithSeq new_expr new_wit new_info)
721 722
   where zonkWit env Nothing    = return (env, Nothing)
         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
723

724
zonkExpr env (PArrSeq expr info)
ian@well-typed.com's avatar
ian@well-typed.com committed
725 726 727
  = do new_expr <- zonkExpr env expr
       new_info <- zonkArithSeq env info
       return (PArrSeq new_expr new_info)
728

Alan Zimmerman's avatar
Alan Zimmerman committed
729
zonkExpr env (HsSCC src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
730
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
731
       return (HsSCC src lbl new_expr)
732

733
zonkExpr env (HsTickPragma src info srcInfo expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
734
  = do new_expr <- zonkLExpr env expr
735
       return (HsTickPragma src info srcInfo new_expr)
andy@galois.com's avatar
andy@galois.com committed
736

737
-- hdaume: core annotations
Alan Zimmerman's avatar
Alan Zimmerman committed
738
zonkExpr env (HsCoreAnn src lbl 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 (HsCoreAnn src lbl new_expr)
741

742
-- arrow notation extensions
743
zonkExpr env (HsProc pat body)
744 745 746
  = do  { (env1, new_pat) <- zonkPat env pat
        ; new_body <- zonkCmdTop env1 body
        ; return (HsProc new_pat new_body) }
747

748 749 750 751
-- StaticPointers extension
zonkExpr env (HsStatic expr)
  = HsStatic <$> zonkLExpr env expr

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

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
760 761 762
  -- nothing to do here. The payload is an LHsType, not a Type.
zonkExpr _ e@(HsTypeOut {}) = return e

Ian Lynagh's avatar
Ian Lynagh committed
763
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
764

765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798
-------------------------------------------------------------------------
{-
Note [Skolems in zonkSyntaxExpr]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider rebindable syntax with something like

  (>>=) :: (forall x. blah) -> (forall y. blah') -> blah''

The x and y become skolems that are in scope when type-checking the
arguments to the bind. This means that we must extend the ZonkEnv with
these skolems when zonking the arguments to the bind. But the skolems
are different between the two arguments, and so we should theoretically
carry around different environments to use for the different arguments.

However, this becomes a logistical nightmare, especially in dealing with
the more exotic Stmt forms. So, we simplify by making the critical
assumption that the uniques of the skolems are different. (This assumption
is justified by the use of newUnique in TcMType.instSkolTyCoVarX.)
Now, we can safely just extend one environment.
-}

-- See Note [Skolems in zonkSyntaxExpr]
zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr TcId
               -> TcM (ZonkEnv, SyntaxExpr Id)
zonkSyntaxExpr env (SyntaxExpr { syn_expr      = expr
                               , syn_arg_wraps = arg_wraps
                               , syn_res_wrap  = res_wrap })
  = do { (env0, res_wrap')  <- zonkCoFn env res_wrap
       ; expr'              <- zonkExpr env0 expr
       ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps
       ; return (env1, SyntaxExpr { syn_expr      = expr'
                                  , syn_arg_wraps = arg_wraps'
                                  , syn_res_wrap  = res_wrap' }) }

799 800 801 802 803 804 805
-------------------------------------------------------------------------

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

zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
806 807 808 809
zonkCmd env (HsCmdWrap w cmd)
  = do { (env1, w') <- zonkCoFn env w
       ; cmd' <- zonkCmd env1 cmd
       ; return (HsCmdWrap w' cmd') }
810
zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
ian@well-typed.com's avatar
ian@well-typed.com committed
811 812 813 814
  = 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)
815 816

zonkCmd env (HsCmdArrForm op fixity args)
ian@well-typed.com's avatar
ian@well-typed.com committed
817 818 819
  = do new_op <- zonkLExpr env op
       new_args <- mapM (zonkCmdTop env) args
       return (HsCmdArrForm new_op fixity new_args)
820 821

zonkCmd env (HsCmdApp c e)
ian@well-typed.com's avatar
ian@well-typed.com committed
822 823 824
  = do new_c <- zonkLCmd env c
       new_e <- zonkLExpr env e
       return (HsCmdApp new_c new_e)
825 826

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

830
zonkCmd env (HsCmdPar c)
ian@well-typed.com's avatar
ian@well-typed.com committed
831 832
  = do new_c <- zonkLCmd env c
       return (HsCmdPar new_c)
833 834

zonkCmd env (HsCmdCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
835 836 837
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLCmd ms
       return (HsCmdCase new_expr new_ms)
838 839

zonkCmd env (HsCmdIf eCond ePred cThen cElse)
840 841 842 843
  = do { (env1, new_eCond) <- zonkWit env eCond
       ; new_ePred <- zonkLExpr env1 ePred
       ; new_cThen <- zonkLCmd env1 cThen
       ; new_cElse <- zonkLCmd env1 cElse
844
       ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
845 846 847
  where
    zonkWit env Nothing  = return (env, Nothing)
    zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w
848

849
zonkCmd env (HsCmdLet (L l binds) cmd)
ian@well-typed.com's avatar
ian@well-typed.com committed
850 851
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_cmd <- zonkLCmd new_env cmd
852
       return (HsCmdLet (L l new_binds) new_cmd)
853

854
zonkCmd env (HsCmdDo (L l stmts) ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
855 856
  = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
       new_ty <- zonkTcTypeToType env ty
857
       return (HsCmdDo (L l new_stmts) new_ty)
858 859 860 861 862





863 864 865
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd

Ian Lynagh's avatar
Ian Lynagh committed
866
zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
867
zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
ian@well-typed.com's avatar
ian@well-typed.com committed
868 869 870 871 872
  = 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)
873

874
-------------------------------------------------------------------------
875
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
876
zonkCoFn env WpHole   = return (env, WpHole)
877
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
878 879
                                    ; (env2, c2') <- zonkCoFn env1 c2
                                    ; return (env2, WpCompose c1' c2') }
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
880 881 882 883
zonkCoFn env (WpFun c1 c2 t1) = do { (env1, c1') <- zonkCoFn env c1
                                   ; (env2, c2') <- zonkCoFn env1 c2
                                   ; t1'         <- zonkTcTypeToType env2 t1
                                   ; return (env2, WpFun c1' c2' t1') }
884
zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co
885
                              ; return (env, WpCast co') }
886
zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
887 888
                                 ; return (env', WpEvLam ev') }
zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg
889
                                 ; return (env, WpEvApp arg') }
890
zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
dreixel's avatar
dreixel committed
891
                              do { (env', tv') <- zonkTyBndrX env tv
892
                                 ; return (env', WpTyLam tv') }
893
zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToType env ty
894
                                 ; return (env, WpTyApp ty') }
895
zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs
896
                                 ; return (env1, WpLet bs') }
897

898 899
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
900
zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
901 902 903
  = do  { ty' <- zonkTcTypeToType env ty
        ; e' <- zonkExpr env e
        ; return (lit { ol_witness = e', ol_type = ty' }) }
904

905
-------------------------------------------------------------------------
906
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
907