TcHsSyn.hs 72.2 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 33 34 35
        zonkCoToCo, zonkTcKindToKind,

        -- * Validity checking
        checkForRepresentationPolymorphism
36 37
  ) where

38
#include "HsVersions.h"
39

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

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

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

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

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

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

108

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

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

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

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

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

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

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

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

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

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

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

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

188 189 190 191 192 193 194 195 196 197 198
-- | 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.
199 200
--
-- Confused by zonking? See Note [What is zonking?] in TcMType.
201 202
data ZonkEnv
  = ZonkEnv
dreixel's avatar
dreixel committed
203
      UnboundTyVarZonker
204 205
      (TyCoVarEnv TyVar)
      (IdEnv      Var)         -- What variables are in scope
206 207 208 209 210 211 212
        -- 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
213 214 215
  ppr (ZonkEnv _ _ty_env var_env) = vcat (map ppr (varEnvElts var_env))


216
-- The EvBinds have to already be zonked, but that's usually the case.
Ian Lynagh's avatar
Ian Lynagh committed
217
emptyZonkEnv :: ZonkEnv
218 219 220 221
emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping

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

223 224 225 226 227
-- | 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
228
  = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
229 230 231 232 233 234 235 236 237 238 239 240
  -- 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
241

dreixel's avatar
dreixel committed
242
extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
243
extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id
dreixel's avatar
dreixel committed
244
  = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
245

dreixel's avatar
dreixel committed
246 247 248 249 250
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
251 252
setZonkType (ZonkEnv _ ty_env id_env) zonk_ty
  = ZonkEnv zonk_ty ty_env id_env
253

254
zonkEnvIds :: ZonkEnv -> [Id]
dreixel's avatar
dreixel committed
255
zonkEnvIds (ZonkEnv _ _ id_env) = varEnvElts id_env
256 257

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

Ian Lynagh's avatar
Ian Lynagh committed
278
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
279
zonkIdOccs env ids = map (zonkIdOcc env) ids
280

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

zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
291
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
292 293 294

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

296 297 298
zonkFieldOcc :: ZonkEnv -> FieldOcc TcId -> TcM (FieldOcc Id)
zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel

299
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
300
zonkEvBndrsX = mapAccumLM zonkEvBndrX
301 302 303 304 305

zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
-- Works for dictionaries and coercions
zonkEvBndrX env var
  = do { var' <- zonkEvBndr env var
306
       ; return (extendZonkEnv env [var'], var') }
307 308 309 310

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

318 319 320 321 322 323
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
324 325

zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
326
zonkTyBndrsX = mapAccumLM zonkTyBndrX
dreixel's avatar
dreixel committed
327 328

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

338 339 340 341 342 343 344 345 346
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) }

347
zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
348 349
zonkTopExpr e = zonkExpr emptyZonkEnv e

350 351 352
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

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

---------------------------------------------
374 375 376 377
zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
zonkLocalBinds env EmptyLocalBinds
  = return (env, EmptyLocalBinds)

378 379 380
zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
  = panic "zonkLocalBinds" -- Not in typechecker output

381 382
zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs))
  = do  { (env1, new_binds) <- go env binds
383 384
        ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }
  where
385
    go env []
386
      = return (env, [])
387 388 389
    go env ((r,b):bs)
      = do { (env1, b')  <- zonkRecMonoBinds env b
           ; (env2, bs') <- go env1 bs
390
           ; return (env2, (r,b'):bs') }
391

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

404
---------------------------------------------
405 406
zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
zonkRecMonoBinds env binds
407
 = fixM (\ ~(_, new_binds) -> do
408
        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)
409
        ; binds' <- zonkMonoBinds env1 binds
410 411
        ; return (env1, binds') })

412
---------------------------------------------
413 414
zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
cactus's avatar
cactus committed
415

416 417
zonk_lbind :: ZonkEnv -> LHsBind TcId -> TcM (LHsBind Id)
zonk_lbind env = wrapLocM (zonk_bind env)
418

419 420
zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
421 422 423 424
  = 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 }) }
425

426
zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
427 428 429 430
  = do { new_var  <- zonkIdBndr env var
       ; new_expr <- zonkLExpr env expr
       ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }

431 432
zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
                            , fun_co_fn = co_fn })
433 434
  = do { new_var <- zonkIdBndr env var
       ; (env1, new_co_fn) <- zonkCoFn env co_fn
435
       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
436 437 438
       ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
                      , fun_co_fn = new_co_fn }) }

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

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
468 469 470 471 472 473 474 475 476
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
477 478 479 480
  = 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
481 482 483 484 485 486 487 488 489 490
           -- 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
491 492
       ; new_poly_id         <- zonkIdBndr env2 poly
       ; new_prags           <- zonkSpecPrags env2 prags
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
493 494 495
       ; 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
496 497 498 499 500 501 502
       ; 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
503 504 505
  | otherwise
  = pprPanic "zonk_bind" (ppr outer_bind)

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

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)
528 529 530
zonkPatSynDir env (ExplicitBidirectional mg) = do
    mg' <- zonkMatchGroup env zonkLExpr mg
    return (env, ExplicitBidirectional mg')
cactus's avatar
cactus committed
531

532 533
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
534
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
535
                                       ; return (SpecPrags ps') }
536 537 538 539

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
540
  where
541
    zonk_prag (L loc (SpecPrag id co_fn inl))
542 543
        = do { (_, co_fn') <- zonkCoFn env co_fn
             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
544

Austin Seipp's avatar
Austin Seipp committed
545 546 547
{-
************************************************************************
*                                                                      *
548
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
549 550 551
*                                                                      *
************************************************************************
-}
552

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

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

572
-------------------------------------------------------------------------
573
zonkGRHSs :: ZonkEnv
574 575
          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
          -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))
576

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

Austin Seipp's avatar
Austin Seipp committed
587 588 589
{-
************************************************************************
*                                                                      *
590
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
591 592 593
*                                                                      *
************************************************************************
-}
594

595 596 597
zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
598

599
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
600
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
601

602 603
zonkExpr env (HsVar (L l id))
  = return (HsVar (L l (zonkIdOcc env id)))
604

605
zonkExpr _ (HsIPVar id)
606
  = return (HsIPVar id)
607

Adam Gundry's avatar
Adam Gundry committed
608 609 610
zonkExpr _ (HsOverLabel l)
  = return (HsOverLabel l)

611
zonkExpr env (HsLit (HsRat f ty))
ian@well-typed.com's avatar
ian@well-typed.com committed
612 613
  = do new_ty <- zonkTcTypeToType env ty
       return (HsLit (HsRat f new_ty))
sof's avatar
sof committed
614

Ian Lynagh's avatar
Ian Lynagh committed
615
zonkExpr _ (HsLit lit)
616
  = return (HsLit lit)
617 618

zonkExpr env (HsOverLit lit)
619 620
  = do  { lit' <- zonkOverLit env lit
        ; return (HsOverLit lit') }
621

622
zonkExpr env (HsLam matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
623 624
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
       return (HsLam new_matches)
625

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

631
zonkExpr env (HsApp e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
632 633 634
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       return (HsApp new_e1 new_e2)
635

636 637 638 639 640
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
641 642 643
zonkExpr _ e@(HsRnBracketOut _ _)
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

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

651 652
zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE s)
653 654

zonkExpr env (OpApp e1 op fixity e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
655 656 657 658
  = 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)
659

660
zonkExpr env (NegApp expr op)
661 662
  = do (env', new_op) <- zonkSyntaxExpr env op
       new_expr <- zonkLExpr env' expr
ian@well-typed.com's avatar
ian@well-typed.com committed
663
       return (NegApp new_expr new_op)
664

665
zonkExpr env (HsPar e)
ian@well-typed.com's avatar
ian@well-typed.com committed
666 667
  = do new_e <- zonkLExpr env e
       return (HsPar new_e)
668 669

zonkExpr env (SectionL expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
670 671 672
  = do new_expr <- zonkLExpr env expr
       new_op   <- zonkLExpr env op
       return (SectionL new_expr new_op)
673 674

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

679 680 681 682
zonkExpr env (ExplicitTuple tup_args boxed)
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
       ; return (ExplicitTuple new_tup_args boxed) }
  where
683 684 685 686
    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')) }
687

688
zonkExpr env (HsCase expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
689 690 691
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLExpr ms
       return (HsCase new_expr new_ms)
692

693 694 695 696 697 698 699 700 701 702 703 704
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)
705

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

715
zonkExpr env (HsLet (L l binds) expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
716 717
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_expr <- zonkLExpr new_env expr
718
       return (HsLet (L l new_binds) new_expr)
719

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

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

zonkExpr env (ExplicitPArr ty exprs)
ian@well-typed.com's avatar
ian@well-typed.com committed
734 735 736
  = do new_ty <- zonkTcTypeToType env ty
       new_exprs <- zonkLExprs env exprs
       return (ExplicitPArr new_ty new_exprs)
737

738
zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds })
739 740
  = do  { new_con_expr <- zonkExpr env con_expr
        ; new_rbinds   <- zonkRecFields env rbinds
741 742
        ; return (expr { rcon_con_expr = new_con_expr
                       , rcon_flds = new_rbinds }) }
743

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

756
zonkExpr env (ExprWithTySigOut e ty)
757 758 759
  = do { e' <- zonkLExpr env e
       ; return (ExprWithTySigOut e' ty) }

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

768
zonkExpr env (PArrSeq expr info)
ian@well-typed.com's avatar
ian@well-typed.com committed
769 770 771
  = do new_expr <- zonkExpr env expr
       new_info <- zonkArithSeq env info
       return (PArrSeq new_expr new_info)
772

Alan Zimmerman's avatar
Alan Zimmerman committed
773
zonkExpr env (HsSCC src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
774
  = do new_expr <- zonkLExpr env expr
Alan Zimmerman's avatar
Alan Zimmerman committed
775
       return (HsSCC src lbl new_expr)
776

777
zonkExpr env (HsTickPragma src info srcInfo expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
778
  = do new_expr <- zonkLExpr env expr
779
       return (HsTickPragma src info srcInfo new_expr)
andy@galois.com's avatar
andy@galois.com committed
780

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

786
-- arrow notation extensions
787
zonkExpr env (HsProc pat body)
788 789 790
  = do  { (env1, new_pat) <- zonkPat env pat
        ; new_body <- zonkCmdTop env1 body
        ; return (HsProc new_pat new_body) }
791

792 793 794 795
-- StaticPointers extension
zonkExpr env (HsStatic expr)
  = HsStatic <$> zonkLExpr env expr

796
zonkExpr env (HsWrap co_fn expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
797 798 799
  = do (env1, new_co_fn) <- zonkCoFn env co_fn
       new_expr <- zonkExpr env1 expr
       return (HsWrap new_co_fn new_expr)
800

801 802
zonkExpr _ (HsUnboundVar v)
  = return (HsUnboundVar v)
803

Ian Lynagh's avatar
Ian Lynagh committed
804
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
805

806 807 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
-------------------------------------------------------------------------
{-
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' }) }

840 841 842 843 844 845 846
-------------------------------------------------------------------------

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

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

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

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

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

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

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

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

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





904 905 906
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd

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

915
-------------------------------------------------------------------------
916
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
917
zonkCoFn env WpHole   = return (env, WpHole)
918
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
919 920
                                    ; (env2, c2') <- zonkCoFn env1 c2
                                    ; return (env2, WpCompose c1' c2') }
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
921 922 923 924
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') }
eir@cis.upenn.edu's avatar