TcHsSyn.hs 71 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
{-# LANGUAGE CPP, TupleSections #-}
13

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

22
        -- * re-exported from TcMonad
23 24
        TcId, TcIdSet,

25 26 27
        -- * Zonking
        -- | For a description of "zonking", see Note [What is zonking?]
        -- in TcMType
28
        zonkTopDecls, zonkTopExpr, zonkTopLExpr,
29
        zonkTopBndrs, zonkTyBndrsX, zonkTyBinders,
30
        emptyZonkEnv, mkEmptyZonkEnv,
31
        zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
32
        zonkCoToCo, zonkTcKindToKind,
conal's avatar
conal committed
33
        zonkEvBinds,
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
34 35 36

        -- * Validity checking
        checkForRepresentationPolymorphism
37 38
  ) where

39
#include "HsVersions.h"
40

41
import HsSyn
42
import Id
43
import TcRnMonad
44
import PrelNames
45
import TcType
46
import TcMType
47
import TcEvidence
48 49
import TysPrim
import TysWiredIn
dreixel's avatar
dreixel committed
50
import Type
51
import TyCoRep  ( TyBinder(..) )
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
52
import TyCon
53
import Coercion
54
import ConLike
55
import DataCon
56 57
import Name
import Var
58
import VarSet
59
import VarEnv
60
import DynFlags
61
import Literal
62 63 64
import BasicTypes
import Maybes
import SrcLoc
sof's avatar
sof committed
65
import Bag
sof's avatar
sof committed
66
import Outputable
67
import Util
68
import UniqFM
69

70 71
import Control.Monad
import Data.List  ( partition )
72
import Control.Arrow ( second )
73

Austin Seipp's avatar
Austin Seipp committed
74 75 76
{-
************************************************************************
*                                                                      *
77
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
Austin Seipp's avatar
Austin Seipp committed
78 79
*                                                                      *
************************************************************************
80

81
Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
82
then something is wrong.
Austin Seipp's avatar
Austin Seipp committed
83 84
-}

85 86 87
hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat

Ian Lynagh's avatar
Ian Lynagh committed
88 89 90
hsPatType :: Pat Id -> Type
hsPatType (ParPat pat)                = hsLPatType pat
hsPatType (WildPat ty)                = ty
91
hsPatType (VarPat (L _ var))          = idType var
Ian Lynagh's avatar
Ian Lynagh committed
92 93 94 95 96
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
97 98
hsPatType (ListPat _ ty Nothing)      = mkListTy ty
hsPatType (ListPat _ _ (Just (ty,_))) = ty
Ian Lynagh's avatar
Ian Lynagh committed
99
hsPatType (PArrPat _ ty)              = mkPArrTy ty
100
hsPatType (TuplePat _ bx tys)         = mkTupleTy bx tys
101
hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys })
102
                                      = conLikeResTy con tys
Ian Lynagh's avatar
Ian Lynagh committed
103
hsPatType (SigPatOut _ ty)            = ty
104 105
hsPatType (NPat _ _ _ ty)             = ty
hsPatType (NPlusKPat _ _ _ _ _ ty)    = ty
Ian Lynagh's avatar
Ian Lynagh committed
106 107
hsPatType (CoPat _ _ ty)              = ty
hsPatType p                           = pprPanic "hsPatType" (ppr p)
108

109

110
hsLitType :: HsLit -> TcType
111 112 113 114 115 116 117 118 119 120 121 122 123
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
124

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

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

140
shortCutLit _ (HsFractional f) ty
141 142
  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim f))
  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
143 144
  | otherwise     = Nothing

145 146
shortCutLit _ (HsIsString src s) ty
  | isStringTy ty = Just (HsLit (HsString src s))
147 148 149 150 151 152 153 154 155 156 157
  | 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
158

Austin Seipp's avatar
Austin Seipp committed
159 160 161
{-
************************************************************************
*                                                                      *
162
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
Austin Seipp's avatar
Austin Seipp committed
163 164
*                                                                      *
************************************************************************
165

166 167
The rest of the zonking is done *after* typechecking.
The main zonking pass runs over the bindings
168 169 170

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

173 174
The type variables are converted by binding mutable tyvars to immutable ones
and then zonking as normal.
175

176 177 178
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
179

180
It's all pretty boring stuff, because HsSyn is such a large type, and
181
the environment manipulation is tiresome.
Austin Seipp's avatar
Austin Seipp committed
182
-}
183

184
-- Confused by zonking? See Note [What is zonking?] in TcMType.
185
type UnboundTyVarZonker = TcTyVar -> TcM Type
186
        -- How to zonk an unbound type variable
dreixel's avatar
dreixel committed
187 188
        -- Note [Zonking the LHS of a RULE]

189 190 191
-- | A ZonkEnv carries around several bits.
-- The UnboundTyVarZonker just zaps unbouned meta-tyvars to Any (as
-- defined in zonkTypeZapping), except on the LHS of rules. See
192 193 194 195 196 197 198 199 200 201 202 203
-- 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.
204 205
--
-- Confused by zonking? See Note [What is zonking?] in TcMType.
206 207
data ZonkEnv
  = ZonkEnv
dreixel's avatar
dreixel committed
208
      UnboundTyVarZonker
209 210
      (TyCoVarEnv TyVar)
      (IdEnv      Var)         -- What variables are in scope
211 212 213 214 215 216 217
        -- 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
218
  ppr (ZonkEnv _ _ty_env var_env) = pprUFM var_env (vcat . map ppr)
219 220


221
-- The EvBinds have to already be zonked, but that's usually the case.
Ian Lynagh's avatar
Ian Lynagh committed
222
emptyZonkEnv :: ZonkEnv
223 224 225 226
emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping

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

228 229 230 231 232
-- | 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
233
  = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
234 235 236 237 238 239 240 241 242 243 244 245
  -- 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
246

dreixel's avatar
dreixel committed
247
extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
248
extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id
dreixel's avatar
dreixel committed
249
  = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
250

dreixel's avatar
dreixel committed
251 252 253 254 255
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
256 257
setZonkType (ZonkEnv _ ty_env id_env) zonk_ty
  = ZonkEnv zonk_ty ty_env id_env
258

259
zonkEnvIds :: ZonkEnv -> [Id]
dreixel's avatar
dreixel committed
260
zonkEnvIds (ZonkEnv _ _ id_env) = varEnvElts id_env
261 262

zonkIdOcc :: ZonkEnv -> TcId -> Id
263
-- Ids defined in this module should be in the envt;
264 265
-- ignore others.  (Actually, data constructors are also
-- not LocalVars, even when locally defined, but that is fine.)
266 267
-- (Also foreign-imported things aren't currently in the ZonkEnv;
--  that's ok because they don't need zonking.)
268 269
--
-- Actually, Template Haskell works in 'chunks' of declarations, and
270
-- an earlier chunk won't be in the 'env' that the zonking phase
271
-- carries around.  Instead it'll be in the tcg_gbl_env, already fully
272
-- zonked.  There's no point in looking it up there (except for error
273 274 275 276
-- 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
277
-- 'main' is done as a separate chunk.
278 279 280
zonkIdOcc (ZonkEnv _zonk_ty _ty_env id_env) id
  | isLocalVar id = lookupVarEnv id_env id `orElse`
                    id
281
  | otherwise     = id
282

Ian Lynagh's avatar
Ian Lynagh committed
283
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
284
zonkIdOccs env ids = map (zonkIdOcc env) ids
285

286
-- zonkIdBndr is used *after* typechecking to get the Id's type
287
-- to its final form.  The TyVarEnv give
288 289
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
zonkIdBndr env id
ian@well-typed.com's avatar
ian@well-typed.com committed
290
  = do ty' <- zonkTcTypeToType env (idType id)
291 292
       ensureNotRepresentationPolymorphic ty'
         (text "In the type of binder" <+> quotes (ppr id))
293
       return (setIdType id ty')
294 295

zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
296
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
297 298 299

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

301 302 303
zonkFieldOcc :: ZonkEnv -> FieldOcc TcId -> TcM (FieldOcc Id)
zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel

304
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
305
zonkEvBndrsX = mapAccumLM zonkEvBndrX
306 307 308 309 310

zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
-- Works for dictionaries and coercions
zonkEvBndrX env var
  = do { var' <- zonkEvBndr env var
311
       ; return (extendZonkEnv env [var'], var') }
312 313 314 315

zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
-- Works for dictionaries and coercions
-- Does not extend the ZonkEnv
316
zonkEvBndr env var
317
  = do { let var_ty = varType var
318
       ; ty <-
319 320
           {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
           zonkTcTypeToType env var_ty
dreixel's avatar
dreixel committed
321
       ; return (setVarType var ty) }
322

323 324 325 326 327 328
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
329 330

zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
331
zonkTyBndrsX = mapAccumLM zonkTyBndrX
dreixel's avatar
dreixel committed
332 333

zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar)
334 335
-- 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
336
zonkTyBndrX env tv
337 338
  = ASSERT( isImmutableTyVar tv )
    do { ki <- zonkTcTypeToType env (tyVarKind tv)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
339
               -- Internal names tidy up better, for iface files.
340 341
       ; let tv' = mkTyVar (tyVarName tv) ki
       ; return (extendTyZonkEnv1 env tv', tv') }
342

343 344 345 346 347 348 349 350 351
zonkTyBinders :: ZonkEnv -> [TcTyBinder] -> TcM (ZonkEnv, [TyBinder])
zonkTyBinders = mapAccumLM zonkTyBinder

zonkTyBinder :: ZonkEnv -> TcTyBinder -> TcM (ZonkEnv, TyBinder)
zonkTyBinder env (Anon ty) = (env, ) <$> (Anon <$> zonkTcTypeToType env ty)
zonkTyBinder env (Named tv vis)
  = do { (env', tv') <- zonkTyBndrX env tv
       ; return (env', Named tv' vis) }

352
zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
353 354
zonkTopExpr e = zonkExpr emptyZonkEnv e

355 356 357
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

358
zonkTopDecls :: Bag EvBind
Matthew Pickering's avatar
Matthew Pickering committed
359
             -> LHsBinds TcId
360
             -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
361
             -> TcM ([Id],
362
                     Bag EvBind,
cactus's avatar
cactus committed
363
                     LHsBinds Id,
364 365 366 367
                     [LForeignDecl Id],
                     [LTcSpecPrag],
                     [LRuleDecl    Id],
                     [LVectDecl    Id])
368
zonkTopDecls ev_binds binds rules vects imp_specs fords
369
  = do  { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
370
        ; (env2, binds') <- zonkRecMonoBinds env1 binds
371 372 373
                        -- Top level is implicitly recursive
        ; rules' <- zonkRules env2 rules
        ; vects' <- zonkVects env2 vects
374
        ; specs' <- zonkLTcSpecPrags env2 imp_specs
375 376
        ; fords' <- zonkForeignExports env2 fords
        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') }
377 378

---------------------------------------------
379 380 381 382
zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
zonkLocalBinds env EmptyLocalBinds
  = return (env, EmptyLocalBinds)

383 384 385
zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
  = panic "zonkLocalBinds" -- Not in typechecker output

386 387
zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs))
  = do  { (env1, new_binds) <- go env binds
388 389
        ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }
  where
390
    go env []
391
      = return (env, [])
392 393 394
    go env ((r,b):bs)
      = do { (env1, b')  <- zonkRecMonoBinds env b
           ; (env2, bs') <- go env1 bs
395
           ; return (env2, (r,b'):bs') }
396

ian@well-typed.com's avatar
ian@well-typed.com committed
397 398
zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do
    new_binds <- mapM (wrapLocM zonk_ip_bind) binds
399
    let
400
        env1 = extendIdZonkEnvRec env [ n | L _ (IPBind (Right n) _) <- new_binds]
ian@well-typed.com's avatar
ian@well-typed.com committed
401
    (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
402
    return (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
403
  where
404
    zonk_ip_bind (IPBind n e)
ian@well-typed.com's avatar
ian@well-typed.com committed
405 406 407
        = do n' <- mapIPNameTc (zonkIdBndr env) n
             e' <- zonkLExpr env e
             return (IPBind n' e')
408

409
---------------------------------------------
410 411
zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
zonkRecMonoBinds env binds
412
 = fixM (\ ~(_, new_binds) -> do
413
        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)
414
        ; binds' <- zonkMonoBinds env1 binds
415 416
        ; return (env1, binds') })

417
---------------------------------------------
418 419
zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
cactus's avatar
cactus committed
420

421 422
zonk_lbind :: ZonkEnv -> LHsBind TcId -> TcM (LHsBind Id)
zonk_lbind env = wrapLocM (zonk_bind env)
423

424 425
zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
426 427 428 429
  = 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 }) }
430

431
zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
432 433 434 435
  = do { new_var  <- zonkIdBndr env var
       ; new_expr <- zonkLExpr env expr
       ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }

436 437
zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
                            , fun_co_fn = co_fn })
438 439
  = do { new_var <- zonkIdBndr env var
       ; (env1, new_co_fn) <- zonkCoFn env co_fn
440
       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
441 442 443
       ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
                      , fun_co_fn = new_co_fn }) }

444 445 446 447
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                        , abs_ev_binds = ev_binds
                        , abs_exports = exports
                        , abs_binds = val_binds })
448
  = ASSERT( all isImmutableTyVar tyvars )
dreixel's avatar
dreixel committed
449 450
    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
451
       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
452
       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
453 454
         do { let env3 = extendIdZonkEnvRec env2
                           (collectHsBindsBinders new_val_binds)
455
            ; new_val_binds <- zonkMonoBinds env3 val_binds
456 457
            ; new_exports   <- mapM (zonkExport env3) exports
            ; return (new_val_binds, new_exports) }
dreixel's avatar
dreixel committed
458 459
       ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
                          , abs_ev_binds = new_ev_binds
460
                          , abs_exports = new_exports, abs_binds = new_val_bind }) }
sof's avatar
sof committed
461
  where
462
    zonkExport env (ABE{ abe_wrap = wrap
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
463
                       , abe_poly = poly_id
464
                       , abe_mono = mono_id, abe_prags = prags })
ian@well-typed.com's avatar
ian@well-typed.com committed
465 466 467
        = do new_poly_id <- zonkIdBndr env poly_id
             (_, new_wrap) <- zonkCoFn env wrap
             new_prags <- zonkSpecPrags env prags
468
             return (ABE{ abe_wrap = new_wrap
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
469
                        , abe_poly = new_poly_id
ian@well-typed.com's avatar
ian@well-typed.com committed
470 471
                        , abe_mono = zonkIdOcc env mono_id
                        , abe_prags = new_prags })
472

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
473 474 475 476 477 478 479 480 481
zonk_bind env outer_bind@(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    = lbind })
  | L bind_loc bind@(FunBind { fun_id      = L loc local
                             , fun_matches = ms
                             , fun_co_fn   = co_fn }) <- lbind
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
482 483 484 485
  = 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
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
486 487 488 489 490 491 492 493 494 495
           -- Inline zonk_bind (FunBind ...) because we wish to skip
           -- the check for representation-polymorphic binders. The
           -- local binder in the FunBind in an AbsBindsSig is never actually
           -- bound in Core -- indeed, that's the whole point of AbsBindsSig.
           -- just calling zonk_bind causes #11405.
       ; new_local           <- updateVarTypeM (zonkTcTypeToType env2) local
       ; (env3, new_co_fn)   <- zonkCoFn env2 co_fn
       ; new_ms              <- zonkMatchGroup env3 zonkLExpr ms
           -- If there is a representation polymorphism problem, it will
           -- be caught here:
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
496 497
       ; new_poly_id         <- zonkIdBndr env2 poly
       ; new_prags           <- zonkSpecPrags env2 prags
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
498 499 500
       ; let new_val_bind = L bind_loc (bind { fun_id      = L loc new_local
                                             , fun_matches = new_ms
                                             , fun_co_fn   = new_co_fn })
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
501 502 503 504 505 506 507
       ; 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  }) }

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
508 509 510
  | otherwise
  = pprPanic "zonk_bind" (ppr outer_bind)

511 512 513 514
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
515 516
  = do { id' <- zonkIdBndr env id
       ; details' <- zonkPatSynDetails env details
517
       ; (env1, lpat') <- zonkPat env lpat
cactus's avatar
cactus committed
518
       ; (_env2, dir') <- zonkPatSynDir env1 dir
519 520 521 522 523
       ; return $ PatSynBind $
                  bind { psb_id = L loc id'
                       , psb_args = details'
                       , psb_def = lpat'
                       , psb_dir = dir' } }
cactus's avatar
cactus committed
524 525 526 527 528 529 530 531 532

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)
533 534 535
zonkPatSynDir env (ExplicitBidirectional mg) = do
    mg' <- zonkMatchGroup env zonkLExpr mg
    return (env, ExplicitBidirectional mg')
cactus's avatar
cactus committed
536

537 538
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
539
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
540
                                       ; return (SpecPrags ps') }
541 542 543 544

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
545
  where
546
    zonk_prag (L loc (SpecPrag id co_fn inl))
547 548
        = do { (_, co_fn') <- zonkCoFn env co_fn
             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
549

Austin Seipp's avatar
Austin Seipp committed
550 551 552
{-
************************************************************************
*                                                                      *
553
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
554 555 556
*                                                                      *
************************************************************************
-}
557

558
zonkMatchGroup :: ZonkEnv
559 560
               -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
               -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id)))
561 562
zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys
                             , mg_res_ty = res_ty, mg_origin = origin })
563 564 565
  = do  { ms' <- mapM (zonkMatch env zBody) ms
        ; arg_tys' <- zonkTcTypeToTypes env arg_tys
        ; res_ty'  <- zonkTcTypeToType env res_ty
566 567
        ; return (MG { mg_alts = L l ms', mg_arg_tys = arg_tys'
                     , mg_res_ty = res_ty', mg_origin = origin }) }
568

569
zonkMatch :: ZonkEnv
570 571
          -> (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
572
zonkMatch env zBody (L loc (Match mf pats _ grhss))
573 574
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
Alan Zimmerman's avatar
Alan Zimmerman committed
575
        ; return (L loc (Match mf new_pats Nothing new_grhss)) }
576

577
-------------------------------------------------------------------------
578
zonkGRHSs :: ZonkEnv
579 580
          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
          -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))
581

582
zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
583
    (new_env, new_binds) <- zonkLocalBinds env binds
584
    let
585
        zonk_grhs (GRHS guarded rhs)
ian@well-typed.com's avatar
ian@well-typed.com committed
586 587 588 589
          = 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
590
    return (GRHSs new_grhss (L l new_binds))
591

Austin Seipp's avatar
Austin Seipp committed
592 593 594
{-
************************************************************************
*                                                                      *
595
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
596 597 598
*                                                                      *
************************************************************************
-}
599

600 601 602
zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
603

604
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
605
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
606

607 608
zonkExpr env (HsVar (L l id))
  = return (HsVar (L l (zonkIdOcc env id)))
609

610
zonkExpr _ (HsIPVar id)
611
  = return (HsIPVar id)
612

Adam Gundry's avatar
Adam Gundry committed
613 614 615
zonkExpr _ (HsOverLabel l)
  = return (HsOverLabel l)

616
zonkExpr env (HsLit (HsRat f ty))
ian@well-typed.com's avatar
ian@well-typed.com committed
617 618
  = do new_ty <- zonkTcTypeToType env ty
       return (HsLit (HsRat f new_ty))
sof's avatar
sof committed
619

Ian Lynagh's avatar
Ian Lynagh committed
620
zonkExpr _ (HsLit lit)
621
  = return (HsLit lit)
622 623

zonkExpr env (HsOverLit lit)
624 625
  = do  { lit' <- zonkOverLit env lit
        ; return (HsOverLit lit') }
626

627
zonkExpr env (HsLam matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
628 629
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLam new_matches)
630

Simon Peyton Jones's avatar
Simon Peyton Jones committed
631 632 633
zonkExpr env (HsLamCase matches)
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLamCase new_matches)
634

635
zonkExpr env (HsApp e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
636 637 638
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (HsApp new_e1 new_e2)
639

640 641 642 643 644
zonkExpr env (HsAppTypeOut e t)
  = do new_e <- zonkLExpr env e
       return (HsAppTypeOut new_e t)
       -- NB: the type is an HsType; can't zonk that!

gmainland's avatar
gmainland committed
645 646 647
zonkExpr _ e@(HsRnBracketOut _ _)
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

648
zonkExpr env (HsTcBracketOut body bs)
ian@well-typed.com's avatar
ian@well-typed.com committed
649
  = do bs' <- mapM zonk_b bs
650
       return (HsTcBracketOut body bs')
651
  where
652 653
    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
                                      return (PendingTcSplice n e')
gmainland's avatar
gmainland committed
654

655 656
zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE s)
657 658

zonkExpr env (OpApp e1 op fixity e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
659 660 661 662
  = 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)
663

664
zonkExpr env (NegApp expr op)
665 666
  = do (env', new_op) <- zonkSyntaxExpr env op
       new_expr <- zonkLExpr env' expr
ian@well-typed.com's avatar
ian@well-typed.com committed
667
       return (NegApp new_expr new_op)
668

669
zonkExpr env (HsPar e)
ian@well-typed.com's avatar
ian@well-typed.com committed
670 671
  = do new_e <- zonkLExpr env e
       return (HsPar new_e)
672 673

zonkExpr env (SectionL expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
674 675 676
  = do new_expr <- zonkLExpr env expr
       new_op   <- zonkLExpr env op
       return (SectionL new_expr new_op)
677 678

zonkExpr env (SectionR op expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
679 680 681
  = do new_op   <- zonkLExpr env op
       new_expr <- zonkLExpr env expr
       return (SectionR new_op new_expr)
682

683 684 685 686
zonkExpr env (ExplicitTuple tup_args boxed)
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
       ; return (ExplicitTuple new_tup_args boxed) }
  where
687 688 689 690
    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')) }
691

692
zonkExpr env (HsCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
693 694 695
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLExpr ms
       return (HsCase new_expr new_ms)
696

697 698 699 700 701 702 703 704 705 706 707 708
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)
709

710 711 712
zonkExpr env (HsMultiIf ty alts)
  = do { alts' <- mapM (wrapLocM zonk_alt) alts
       ; ty'   <- zonkTcTypeToType env ty
713
       ; return $ HsMultiIf ty' alts' }
714
  where zonk_alt (GRHS guard expr)
715
          = do { (env', guard') <- zonkStmts env zonkLExpr guard
716
               ; expr'          <- zonkLExpr env' expr
717
               ; return $ GRHS guard' expr' }
718

719
zonkExpr env (HsLet (L l binds) expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
720 721
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_expr <- zonkLExpr new_env expr
722
       return (HsLet (L l new_binds) new_expr)
723

724
zonkExpr env (HsDo do_or_lc (L l stmts) ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
725 726
  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
       new_ty <- zonkTcTypeToType env ty
727
       return (HsDo do_or_lc (L l new_stmts) new_ty)
728

729
zonkExpr env (ExplicitList ty wit exprs)
730 731 732
  = 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
733
       return (ExplicitList new_ty new_wit new_exprs)
734 735
   where zonkWit env Nothing    = return (env, Nothing)
         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
736 737

zonkExpr env (ExplicitPArr ty exprs)
ian@well-typed.com's avatar
ian@well-typed.com committed
738 739 740
  = do new_ty <- zonkTcTypeToType env ty
       new_exprs <- zonkLExprs env exprs
       return (ExplicitPArr new_ty new_exprs)
741

742
zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds })
743 744
  = do  { new_con_expr <- zonkExpr env con_expr
        ; new_rbinds   <- zonkRecFields env rbinds
745 746
        ; return (expr { rcon_con_expr = new_con_expr
                       , rcon_flds = new_rbinds }) }
747

748 749 750
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 })
751 752 753
  = do  { new_expr    <- zonkLExpr env expr
        ; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
        ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
754
        ; new_rbinds  <- zonkRecUpdFields env rbinds
Matthew Pickering's avatar
Matthew Pickering committed
755
        ; (_, new_recwrap) <- zonkCoFn env req_wrap
756 757 758
        ; 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 }) }
759

760
zonkExpr env (ExprWithTySigOut e ty)
761 762 763
  = do { e' <- zonkLExpr env e
       ; return (ExprWithTySigOut e' ty) }

764
zonkExpr env (ArithSeq expr wit info)
765 766 767
  = 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
768
       return (ArithSeq new_expr new_wit new_info)
769 770
   where zonkWit env Nothing    = return (env, Nothing)
         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
771

772
zonkExpr env (PArrSeq expr info)
ian@well-typed.com's avatar
ian@well-typed.com committed
773 774 775
  = do new_expr <- zonkExpr env expr
       new_info <- zonkArithSeq env info
       return (PArrSeq new_expr new_info)
776

Alan Zimmerman's avatar
Alan Zimmerman committed
777
zonkExpr env (HsSCC src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
778
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
779
       return (HsSCC src lbl new_expr)
780

781
zonkExpr env (HsTickPragma src info srcInfo expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
782
  = do new_expr <- zonkLExpr env expr
783
       return (HsTickPragma src info srcInfo new_expr)
andy@galois.com's avatar
andy@galois.com committed
784

785
-- hdaume: core annotations
Alan Zimmerman's avatar
Alan Zimmerman committed
786
zonkExpr env (HsCoreAnn src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
787
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
788
       return (HsCoreAnn src lbl new_expr)
789

790
-- arrow notation extensions
791
zonkExpr env (HsProc pat body)
792 793 794
  = do  { (env1, new_pat) <- zonkPat env pat
        ; new_body <- zonkCmdTop env1 body
        ; return (HsProc new_pat new_body) }
795

796
-- StaticPointers extension
797 798
zonkExpr env (HsStatic fvs expr)
  = HsStatic fvs <$> zonkLExpr env expr
799

800
zonkExpr env (HsWrap co_fn expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
801 802 803
  = do (env1, new_co_fn) <- zonkCoFn env co_fn
       new_expr <- zonkExpr env1 expr
       return (HsWrap new_co_fn new_expr)
804

805
zonkExpr _ e@(HsUnboundVar {}) = return e
806

Ian Lynagh's avatar
Ian Lynagh committed
807
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
808

809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842
-------------------------------------------------------------------------
{-
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' }) }

843 844 845 846 847 848 849
-------------------------------------------------------------------------

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
850 851 852 853
zonkCmd env (HsCmdWrap w cmd)
  = do { (env1, w') <- zonkCoFn env w
       ; cmd' <- zonkCmd env1 cmd
       ; return (HsCmdWrap w' cmd') }
854
zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
ian@well-typed.com's avatar
ian@well-typed.com committed
855 856 857 858
  = 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)
859 860

zonkCmd env (HsCmdArrForm op fixity args)
ian@well-typed.com's avatar
ian@well-typed.com committed
861 862 863
  = do new_op <- zonkLExpr env op
       new_args <- mapM (zonkCmdTop env) args
       return (HsCmdArrForm new_op fixity new_args)
864 865

zonkCmd env (HsCmdApp c e)
ian@well-typed.com's avatar
ian@well-typed.com committed
866 867 868
  = do new_c <- zonkLCmd env c
       new_e <- zonkLExpr env e
       return (HsCmdApp new_c new_e)
869 870

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

874
zonkCmd env (HsCmdPar c)
ian@well-typed.com's avatar
ian@well-typed.com committed
875 876
  = do new_c <- zonkLCmd env c
       return (HsCmdPar new_c)
877 878

zonkCmd env (HsCmdCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
879 880 881
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLCmd ms
       return (HsCmdCase new_expr new_ms)
882 883

zonkCmd env (HsCmdIf eCond ePred cThen cElse)
884 885 886 887
  = do { (env1, new_eCond) <- zonkWit env eCond
       ; new_ePred <- zonkLExpr env1 ePred
       ; new_cThen <- zonkLCmd env1 cThen
       ; new_cElse <- zonkLCmd env1 cElse
888
       ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
889 890 891
  where
    zonkWit env Nothing  = return (env, Nothing)
    zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w
892

893
zonkCmd env (HsCmdLet (L l binds) cmd)
ian@well-typed.com's avatar
ian@well-typed.com committed
894 895
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_cmd <- zonkLCmd new_env cmd
896
       return (HsCmdLet (L l new_binds) new_cmd)
897

898
zonkCmd env (HsCmdDo (L l stmts) ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
899 900
  = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
       new_ty <- zonkTcTypeToType env ty
901
       return (HsCmdDo (L l new_stmts) new_ty)
902 903 904 905 906





907 908 909
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd

Ian Lynagh's avatar
Ian Lynagh committed
910
zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
911
zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
ian@well-typed.com's avatar
ian@well-typed.com committed
912 913 914 915 916
  = 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)
917

918
-------------------------------------------------------------------------
919
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)