TcHsSyn.hs 70.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
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
15

16
module TcHsSyn (
17
        -- * Extracting types from HsSyn
18
        hsLitType, hsLPatType, hsPatType,
19 20 21

        -- * Other HsSyn functions
        mkHsDictLet, mkHsApp,
22
        mkHsAppTy, mkHsCaseAlt,
23
        shortCutLit, hsOverLitName,
24
        conLikeResTy,
25

26
        -- * re-exported from TcMonad
27 28
        TcId, TcIdSet,

29 30 31
        -- * Zonking
        -- | For a description of "zonking", see Note [What is zonking?]
        -- in TcMType
32
        zonkTopDecls, zonkTopExpr, zonkTopLExpr,
33
        zonkTopBndrs, zonkTyBndrsX,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
34
        zonkTyVarBindersX, zonkTyVarBinderX,
35
        emptyZonkEnv, mkEmptyZonkEnv,
36
        zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
37
        zonkCoToCo, zonkSigType,
38
        zonkEvBinds, zonkTcEvBinds
39 40
  ) where

41
#include "HsVersions.h"
42

43 44
import GhcPrelude

45
import HsSyn
46
import Id
47
import IdInfo
48
import TcRnMonad
49
import PrelNames
50
import TcType
51
import TcMType
52
import TcEvidence
53
import TysPrim
54
import TyCon   ( isUnboxedTupleTyCon )
55
import TysWiredIn
Simon Peyton Jones's avatar
Simon Peyton Jones committed
56
import TyCoRep( CoercionHole(..) )
dreixel's avatar
dreixel committed
57
import Type
58
import Coercion
59
import ConLike
60
import DataCon
niteria's avatar
niteria committed
61
import HscTypes
62
import Name
niteria's avatar
niteria committed
63
import NameEnv
64
import Var
65
import VarEnv
66
import DynFlags
67
import Literal
68 69 70
import BasicTypes
import Maybes
import SrcLoc
sof's avatar
sof committed
71
import Bag
sof's avatar
sof committed
72
import Outputable
73
import Util
74
import UniqFM
75
import CoreSyn
76

77 78
import Control.Monad
import Data.List  ( partition )
79
import Control.Arrow ( second )
80

Austin Seipp's avatar
Austin Seipp committed
81 82 83
{-
************************************************************************
*                                                                      *
84
       Extracting the type from HsSyn
Austin Seipp's avatar
Austin Seipp committed
85 86
*                                                                      *
************************************************************************
87

Austin Seipp's avatar
Austin Seipp committed
88 89
-}

90
hsLPatType :: OutPat GhcTc -> Type
91 92
hsLPatType (L _ pat) = hsPatType pat

93
hsPatType :: Pat GhcTc -> Type
94 95 96 97 98 99 100 101
hsPatType (ParPat _ pat)                = hsLPatType pat
hsPatType (WildPat ty)                  = ty
hsPatType (VarPat _ (L _ var))          = idType var
hsPatType (BangPat _ pat)               = hsLPatType pat
hsPatType (LazyPat _ pat)               = hsLPatType pat
hsPatType (LitPat _ lit)                = hsLitType lit
hsPatType (AsPat _ var _)               = idType (unLoc var)
hsPatType (ViewPat ty _ _)              = ty
102 103
hsPatType (ListPat (ListPatTc ty Nothing) _)      = mkListTy ty
hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty
104 105
hsPatType (TuplePat tys _ bx)           = mkTupleTy bx tys
hsPatType (SumPat tys _ _ _ )           = mkSumTy tys
106
hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys })
107 108 109 110 111 112 113 114
                                        = conLikeResTy con tys
hsPatType (SigPat ty _)                 = ty
hsPatType (NPat ty _ _ _)               = ty
hsPatType (NPlusKPat ty _ _ _ _ _)      = ty
hsPatType (CoPat _ _ _ ty)              = ty
hsPatType p                             = pprPanic "hsPatType" (ppr p)

hsLitType :: HsLit (GhcPass p) -> TcType
115 116 117 118
hsLitType (HsChar _ _)       = charTy
hsLitType (HsCharPrim _ _)   = charPrimTy
hsLitType (HsString _ _)     = stringTy
hsLitType (HsStringPrim _ _) = addrPrimTy
119
hsLitType (HsInt _ _)        = intTy
120 121 122 123 124
hsLitType (HsIntPrim _ _)    = intPrimTy
hsLitType (HsWordPrim _ _)   = wordPrimTy
hsLitType (HsInt64Prim _ _)  = int64PrimTy
hsLitType (HsWord64Prim _ _) = word64PrimTy
hsLitType (HsInteger _ _ ty) = ty
125 126 127
hsLitType (HsRat _ _ ty)     = ty
hsLitType (HsFloatPrim _ _)  = floatPrimTy
hsLitType (HsDoublePrim _ _) = doublePrimTy
128
hsLitType (XLit p)           = pprPanic "hsLitType" (ppr p)
129

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

132
shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId)
133
shortCutLit dflags (HsIntegral int@(IL src neg i)) ty
134
  | isIntTy ty  && inIntRange  dflags i = Just (HsLit noExt (HsInt noExt int))
135
  | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i))
136
  | isIntegerTy ty = Just (HsLit noExt (HsInteger src i ty))
137
  | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty
138 139 140 141 142
        -- 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
143

144
shortCutLit _ (HsFractional f) ty
145 146
  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim noExt f))
  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExt f))
147 148
  | otherwise     = Nothing

149
shortCutLit _ (HsIsString src s) ty
150
  | isStringTy ty = Just (HsLit noExt (HsString src s))
151 152
  | otherwise     = Nothing

153
mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc
154
mkLit con lit = HsApp noExt (nlHsDataCon con) (nlHsLit lit)
155 156 157 158 159 160 161

------------------------------
hsOverLitName :: OverLitVal -> Name
-- Get the canonical 'fromX' name for a particular OverLitVal
hsOverLitName (HsIntegral {})   = fromIntegerName
hsOverLitName (HsFractional {}) = fromRationalName
hsOverLitName (HsIsString {})   = fromStringName
162

Austin Seipp's avatar
Austin Seipp committed
163 164 165
{-
************************************************************************
*                                                                      *
166
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
Austin Seipp's avatar
Austin Seipp committed
167 168
*                                                                      *
************************************************************************
169

170 171
The rest of the zonking is done *after* typechecking.
The main zonking pass runs over the bindings
172 173 174

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

177 178
The type variables are converted by binding mutable tyvars to immutable ones
and then zonking as normal.
179

180 181 182
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
183

184
It's all pretty boring stuff, because HsSyn is such a large type, and
185
the environment manipulation is tiresome.
Austin Seipp's avatar
Austin Seipp committed
186
-}
187

188
-- Confused by zonking? See Note [What is zonking?] in TcMType.
189
type UnboundTyVarZonker = TcTyVar -> TcM Type
190
        -- How to zonk an unbound type variable
191 192 193
        -- The TcTyVar is
        --     (a) a MetaTv
        --     (b) Flexi and
Gabor Greif's avatar
Gabor Greif committed
194
        --     (c) its kind is already zonked
dreixel's avatar
dreixel committed
195 196
        -- Note [Zonking the LHS of a RULE]

197 198 199
-- | 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
200 201 202 203 204 205 206 207 208 209 210 211
-- 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.
212 213
--
-- Confused by zonking? See Note [What is zonking?] in TcMType.
214 215
data ZonkEnv
  = ZonkEnv
dreixel's avatar
dreixel committed
216
      UnboundTyVarZonker
217 218
      (TyCoVarEnv TyVar)
      (IdEnv      Var)         -- What variables are in scope
219 220 221 222 223 224 225
        -- 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
226
  ppr (ZonkEnv _ _ty_env var_env) = pprUFM var_env (vcat . map ppr)
227 228


229
-- The EvBinds have to already be zonked, but that's usually the case.
Ian Lynagh's avatar
Ian Lynagh committed
230
emptyZonkEnv :: ZonkEnv
231 232 233 234
emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping

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

236 237 238 239 240
-- | 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
241
  = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
242 243 244 245 246 247 248 249 250 251 252 253
  -- 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
254

dreixel's avatar
dreixel committed
255
extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
256
extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id
dreixel's avatar
dreixel committed
257
  = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
258

dreixel's avatar
dreixel committed
259
extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
260 261
extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) tv
  = ZonkEnv zonk_ty (extendVarEnv ty_env tv tv) id_env
dreixel's avatar
dreixel committed
262 263

setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
264 265
setZonkType (ZonkEnv _ ty_env id_env) zonk_ty
  = ZonkEnv zonk_ty ty_env id_env
266

niteria's avatar
niteria committed
267 268 269 270 271
zonkEnvIds :: ZonkEnv -> TypeEnv
zonkEnvIds (ZonkEnv _ _ id_env) =
  mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env]
  -- It's OK to use nonDetEltsUFM here because we forget the ordering
  -- immediately by creating a TypeEnv
272

273 274 275
zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id
zonkLIdOcc env (L loc id) = L loc (zonkIdOcc env id)

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

Ian Lynagh's avatar
Ian Lynagh committed
297
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
298
zonkIdOccs env ids = map (zonkIdOcc env) ids
299

300
-- zonkIdBndr is used *after* typechecking to get the Id's type
301
-- to its final form.  The TyVarEnv give
302
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
303 304 305 306 307 308
zonkIdBndr env v
  = do ty' <- zonkTcTypeToType env (idType v)
       ensureNotLevPoly ty'
         (text "In the type of binder" <+> quotes (ppr v))

       return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty'))
309 310

zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
311
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
312 313 314

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

316
zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc)
317 318 319
zonkFieldOcc env (FieldOcc sel lbl)
  = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel
zonkFieldOcc _ (XFieldOcc _) = panic "zonkFieldOcc"
320

321
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
322
zonkEvBndrsX = mapAccumLM zonkEvBndrX
323 324 325 326 327

zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
-- Works for dictionaries and coercions
zonkEvBndrX env var
  = do { var' <- zonkEvBndr env var
328
       ; return (extendZonkEnv env [var'], var') }
329 330 331 332

zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
-- Works for dictionaries and coercions
-- Does not extend the ZonkEnv
333
zonkEvBndr env var
334
  = do { let var_ty = varType var
335
       ; ty <-
336 337
           {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
           zonkTcTypeToType env var_ty
dreixel's avatar
dreixel committed
338
       ; return (setVarType var ty) }
339

340
{-
341 342 343 344 345 346
zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm
zonkEvVarOcc env v
  | isCoVar v
  = EvCoercion <$> zonkCoVarOcc env v
  | otherwise
  = return (EvId $ zonkIdOcc env v)
347
-}
dreixel's avatar
dreixel committed
348

Simon Peyton Jones's avatar
Simon Peyton Jones committed
349
zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
350
zonkTyBndrsX = mapAccumLM zonkTyBndrX
dreixel's avatar
dreixel committed
351

Simon Peyton Jones's avatar
Simon Peyton Jones committed
352
zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
353 354
-- 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
355
zonkTyBndrX env tv
356 357
  = ASSERT( isImmutableTyVar tv )
    do { ki <- zonkTcTypeToType env (tyVarKind tv)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
358
               -- Internal names tidy up better, for iface files.
359 360
       ; let tv' = mkTyVar (tyVarName tv) ki
       ; return (extendTyZonkEnv1 env tv', tv') }
361

Simon Peyton Jones's avatar
Simon Peyton Jones committed
362 363 364
zonkTyVarBindersX :: ZonkEnv -> [TyVarBndr TcTyVar vis]
                             -> TcM (ZonkEnv, [TyVarBndr TyVar vis])
zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX
365

Simon Peyton Jones's avatar
Simon Peyton Jones committed
366 367 368 369
zonkTyVarBinderX :: ZonkEnv -> TyVarBndr TcTyVar vis
                            -> TcM (ZonkEnv, TyVarBndr TyVar vis)
-- Takes a TcTyVar and guarantees to return a TyVar
zonkTyVarBinderX env (TvBndr tv vis)
370
  = do { (env', tv') <- zonkTyBndrX env tv
371
       ; return (env', TvBndr tv' vis) }
372

373
zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc)
374 375
zonkTopExpr e = zonkExpr emptyZonkEnv e

376
zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)
377 378
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

379
zonkTopDecls :: Bag EvBind
380
             -> LHsBinds GhcTcId
381
             -> [LRuleDecl GhcTcId] -> [LTcSpecPrag]
382
             -> [LForeignDecl GhcTcId]
niteria's avatar
niteria committed
383
             -> TcM (TypeEnv,
384
                     Bag EvBind,
385 386
                     LHsBinds GhcTc,
                     [LForeignDecl GhcTc],
387
                     [LTcSpecPrag],
388 389
                     [LRuleDecl    GhcTc])
zonkTopDecls ev_binds binds rules imp_specs fords
390
  = do  { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
391
        ; (env2, binds') <- zonkRecMonoBinds env1 binds
392 393
                        -- Top level is implicitly recursive
        ; rules' <- zonkRules env2 rules
394
        ; specs' <- zonkLTcSpecPrags env2 imp_specs
395
        ; fords' <- zonkForeignExports env2 fords
396
        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }
397 398

---------------------------------------------
399 400
zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId
               -> TcM (ZonkEnv, HsLocalBinds GhcTc)
401 402
zonkLocalBinds env (EmptyLocalBinds x)
  = return (env, (EmptyLocalBinds x))
403

404
zonkLocalBinds _ (HsValBinds _ (ValBinds {}))
405 406
  = panic "zonkLocalBinds" -- Not in typechecker output

407
zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs)))
408
  = do  { (env1, new_binds) <- go env binds
409
        ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) }
410
  where
411
    go env []
412
      = return (env, [])
413 414 415
    go env ((r,b):bs)
      = do { (env1, b')  <- zonkRecMonoBinds env b
           ; (env2, bs') <- go env1 bs
416
           ; return (env2, (r,b'):bs') }
417

418
zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
419
    new_binds <- mapM (wrapLocM zonk_ip_bind) binds
420
    let
421 422
        env1 = extendIdZonkEnvRec env [ n
                                      | L _ (IPBind _ (Right n) _) <- new_binds]
ian@well-typed.com's avatar
ian@well-typed.com committed
423
    (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
424
    return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds))
425
  where
426
    zonk_ip_bind (IPBind x n e)
ian@well-typed.com's avatar
ian@well-typed.com committed
427 428
        = do n' <- mapIPNameTc (zonkIdBndr env) n
             e' <- zonkLExpr env e
429 430 431 432 433 434 435
             return (IPBind x n' e')
    zonk_ip_bind (XCIPBind _) = panic "zonkLocalBinds : XCIPBind"

zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds _))
  = panic "zonkLocalBinds" -- Not in typechecker output
zonkLocalBinds _ (XHsLocalBindsLR _)
  = panic "zonkLocalBinds" -- Not in typechecker output
436

437
---------------------------------------------
438
zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc)
439
zonkRecMonoBinds env binds
440
 = fixM (\ ~(_, new_binds) -> do
441
        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)
442
        ; binds' <- zonkMonoBinds env1 binds
443 444
        ; return (env1, binds') })

445
---------------------------------------------
446
zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc)
447
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
cactus's avatar
cactus committed
448

449
zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc)
450
zonk_lbind env = wrapLocM (zonk_bind env)
451

452
zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc)
453 454
zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss
                            , pat_ext = NPatBindTc fvs ty})
455 456 457
  = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
        ; new_grhss <- zonkGRHSs env zonkLExpr grhss
        ; new_ty    <- zonkTcTypeToType env ty
458 459
        ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss
                       , pat_ext = NPatBindTc fvs new_ty }) }
460

461 462
zonk_bind env (VarBind { var_ext = x
                       , var_id = var, var_rhs = expr, var_inline = inl })
463 464
  = do { new_var  <- zonkIdBndr env var
       ; new_expr <- zonkLExpr env expr
465 466 467 468
       ; return (VarBind { var_ext = x
                         , var_id = new_var
                         , var_rhs = new_expr
                         , var_inline = inl }) }
469

470 471
zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
                            , fun_co_fn = co_fn })
472 473
  = do { new_var <- zonkIdBndr env var
       ; (env1, new_co_fn) <- zonkCoFn env co_fn
474
       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
475 476 477
       ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
                      , fun_co_fn = new_co_fn }) }

478 479 480
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                        , abs_ev_binds = ev_binds
                        , abs_exports = exports
481 482
                        , abs_binds = val_binds
                        , abs_sig = has_sig })
483
  = ASSERT( all isImmutableTyVar tyvars )
dreixel's avatar
dreixel committed
484 485
    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
486
       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
487
       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
488 489 490 491
         do { let env3 = extendIdZonkEnvRec env2 $
                         collectHsBindsBinders new_val_binds
            ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds
            ; new_exports   <- mapM (zonk_export env3) exports
492
            ; return (new_val_binds, new_exports) }
493 494
       ; return (AbsBinds { abs_ext = noExt
                          , abs_tvs = new_tyvars, abs_ev_vars = new_evs
dreixel's avatar
dreixel committed
495
                          , abs_ev_binds = new_ev_binds
496 497
                          , abs_exports = new_exports, abs_binds = new_val_bind
                          , abs_sig = has_sig }) }
sof's avatar
sof committed
498
  where
499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515
    zonk_val_bind env lbind
      | has_sig
      , L loc bind@(FunBind { fun_id      = L mloc mono_id
                            , fun_matches = ms
                            , fun_co_fn   = co_fn }) <- lbind
      = do { new_mono_id <- updateVarTypeM (zonkTcTypeToType env) mono_id
                            -- Specifically /not/ zonkIdBndr; we do not
                            -- want to complain about a levity-polymorphic binder
           ; (env', new_co_fn) <- zonkCoFn env co_fn
           ; new_ms            <- zonkMatchGroup env' zonkLExpr ms
           ; return $ L loc $
             bind { fun_id      = L mloc new_mono_id
                  , fun_matches = new_ms
                  , fun_co_fn   = new_co_fn } }
      | otherwise
      = zonk_lbind env lbind   -- The normal case

516 517
    zonk_export env (ABE{ abe_ext = x
                        , abe_wrap = wrap
518 519 520
                        , abe_poly = poly_id
                        , abe_mono = mono_id
                        , abe_prags = prags })
ian@well-typed.com's avatar
ian@well-typed.com committed
521 522 523
        = do new_poly_id <- zonkIdBndr env poly_id
             (_, new_wrap) <- zonkCoFn env wrap
             new_prags <- zonkSpecPrags env prags
524 525
             return (ABE{ abe_ext = x
                        , abe_wrap = new_wrap
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
526
                        , abe_poly = new_poly_id
ian@well-typed.com's avatar
ian@well-typed.com committed
527 528
                        , abe_mono = zonkIdOcc env mono_id
                        , abe_prags = new_prags })
529
    zonk_export _ (XABExport _) = panic "zonk_bind: XABExport"
530

531 532 533 534
zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id
                                      , psb_args = details
                                      , psb_def = lpat
                                      , psb_dir = dir }))
cactus's avatar
cactus committed
535
  = do { id' <- zonkIdBndr env id
536
       ; (env1, lpat') <- zonkPat env lpat
537
       ; let details' = zonkPatSynDetails env1 details
cactus's avatar
cactus committed
538
       ; (_env2, dir') <- zonkPatSynDir env1 dir
539
       ; return $ PatSynBind x $
540 541 542 543
                  bind { psb_id = L loc id'
                       , psb_args = details'
                       , psb_def = lpat'
                       , psb_dir = dir' } }
cactus's avatar
cactus committed
544

545 546 547
zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind"
zonk_bind _ (XHsBindsLR _)                 = panic "zonk_bind"

cactus's avatar
cactus committed
548 549
zonkPatSynDetails :: ZonkEnv
                  -> HsPatSynDetails (Located TcId)
550 551 552 553 554 555 556
                  -> HsPatSynDetails (Located Id)
zonkPatSynDetails env (PrefixCon as)
  = PrefixCon (map (zonkLIdOcc env) as)
zonkPatSynDetails env (InfixCon a1 a2)
  = InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2)
zonkPatSynDetails env (RecCon flds)
  = RecCon (map (fmap (zonkLIdOcc env)) flds)
cactus's avatar
cactus committed
557

558 559
zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId
              -> TcM (ZonkEnv, HsPatSynDir GhcTc)
560
zonkPatSynDir env Unidirectional        = return (env, Unidirectional)
cactus's avatar
cactus committed
561
zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
562 563 564
zonkPatSynDir env (ExplicitBidirectional mg) = do
    mg' <- zonkMatchGroup env zonkLExpr mg
    return (env, ExplicitBidirectional mg')
cactus's avatar
cactus committed
565

566 567
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
568
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
569
                                       ; return (SpecPrags ps') }
570 571 572 573

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
574
  where
575
    zonk_prag (L loc (SpecPrag id co_fn inl))
576 577
        = do { (_, co_fn') <- zonkCoFn env co_fn
             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
578

Austin Seipp's avatar
Austin Seipp committed
579 580 581
{-
************************************************************************
*                                                                      *
582
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
583 584 585
*                                                                      *
************************************************************************
-}
586

587
zonkMatchGroup :: ZonkEnv
588 589 590
            -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
            -> MatchGroup GhcTcId (Located (body GhcTcId))
            -> TcM (MatchGroup GhcTc (Located (body GhcTc)))
591 592 593
zonkMatchGroup env zBody (MG { mg_alts = L l ms
                             , mg_ext = MatchGroupTc arg_tys res_ty
                             , mg_origin = origin })
594 595 596
  = do  { ms' <- mapM (zonkMatch env zBody) ms
        ; arg_tys' <- zonkTcTypeToTypes env arg_tys
        ; res_ty'  <- zonkTcTypeToType env res_ty
597 598 599 600
        ; return (MG { mg_alts = L l ms'
                     , mg_ext = MatchGroupTc arg_tys' res_ty'
                     , mg_origin = origin }) }
zonkMatchGroup _ _ (XMatchGroup {}) = panic "zonkMatchGroup"
601

602
zonkMatch :: ZonkEnv
603 604 605
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> LMatch GhcTcId (Located (body GhcTcId))
          -> TcM (LMatch GhcTc (Located (body GhcTc)))
606
zonkMatch env zBody (L loc match@(Match { m_pats = pats, m_grhss = grhss }))
607 608
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
609
        ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
610
zonkMatch _ _ (L  _ (XMatch _)) = panic "zonkMatch"
611

612
-------------------------------------------------------------------------
613
zonkGRHSs :: ZonkEnv
614 615 616
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> GRHSs GhcTcId (Located (body GhcTcId))
          -> TcM (GRHSs GhcTc (Located (body GhcTc)))
617

618
zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
619
    (new_env, new_binds) <- zonkLocalBinds env binds
620
    let
621
        zonk_grhs (GRHS xx guarded rhs)
ian@well-typed.com's avatar
ian@well-typed.com committed
622 623
          = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
               new_rhs <- zBody env2 rhs
624 625
               return (GRHS xx new_guarded new_rhs)
        zonk_grhs (XGRHS _) = panic "zonkGRHSs"
ian@well-typed.com's avatar
ian@well-typed.com committed
626
    new_grhss <- mapM (wrapLocM zonk_grhs) grhss
627 628
    return (GRHSs x new_grhss (L l new_binds))
zonkGRHSs _ _ (XGRHSs _) = panic "zonkGRHSs"
629

Austin Seipp's avatar
Austin Seipp committed
630 631 632
{-
************************************************************************
*                                                                      *
633
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
634 635 636
*                                                                      *
************************************************************************
-}
637

638 639 640
zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc]
zonkLExpr  :: ZonkEnv -> LHsExpr GhcTcId   -> TcM (LHsExpr GhcTc)
zonkExpr   :: ZonkEnv -> HsExpr GhcTcId    -> TcM (HsExpr GhcTc)
641

642
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
643
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
644

645
zonkExpr env (HsVar x (L l id))
Ben Gamari's avatar
Ben Gamari committed
646
  = ASSERT2( isNothing (isDataConId_maybe id), ppr id )
647
    return (HsVar x (L l (zonkIdOcc env id)))
648 649

zonkExpr _ e@(HsConLikeOut {}) = return e
650

651 652
zonkExpr _ (HsIPVar x id)
  = return (HsIPVar x id)
653

654
zonkExpr _ e@HsOverLabel{} = return e
Adam Gundry's avatar
Adam Gundry committed
655

656
zonkExpr env (HsLit x (HsRat e f ty))
ian@well-typed.com's avatar
ian@well-typed.com committed
657
  = do new_ty <- zonkTcTypeToType env ty
658
       return (HsLit x (HsRat e f new_ty))
sof's avatar
sof committed
659

660 661
zonkExpr _ (HsLit x lit)
  = return (HsLit x lit)
662

663
zonkExpr env (HsOverLit x lit)
664
  = do  { lit' <- zonkOverLit env lit
665
        ; return (HsOverLit x lit') }
666

667
zonkExpr env (HsLam x matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
668
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
669
       return (HsLam x new_matches)
670

671
zonkExpr env (HsLamCase x matches)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
672
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
673
       return (HsLamCase x new_matches)
674

675
zonkExpr env (HsApp x e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
676 677
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
678
       return (HsApp x new_e1 new_e2)
679

680
zonkExpr env (HsAppType t e)
681
  = do new_e <- zonkLExpr env e
682
       return (HsAppType t new_e)
683 684
       -- NB: the type is an HsType; can't zonk that!

685
zonkExpr _ e@(HsRnBracketOut _ _ _)
gmainland's avatar
gmainland committed
686 687
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

688
zonkExpr env (HsTcBracketOut x body bs)
ian@well-typed.com's avatar
ian@well-typed.com committed
689
  = do bs' <- mapM zonk_b bs
690
       return (HsTcBracketOut x body bs')
691
  where
692 693
    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
                                      return (PendingTcSplice n e')
gmainland's avatar
gmainland committed
694

695 696
zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE x s)
697

698
zonkExpr env (OpApp fixity e1 op e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
699 700 701
  = do new_e1 <- zonkLExpr env e1
       new_op <- zonkLExpr env op
       new_e2 <- zonkLExpr env e2
702
       return (OpApp fixity new_e1 new_op new_e2)
703

704
zonkExpr env (NegApp x expr op)
705 706
  = do (env', new_op) <- zonkSyntaxExpr env op
       new_expr <- zonkLExpr env' expr
707
       return (NegApp x new_expr new_op)
708

709
zonkExpr env (HsPar x e)
ian@well-typed.com's avatar
ian@well-typed.com committed
710
  = do new_e <- zonkLExpr env e
711
       return (HsPar x new_e)
712

713
zonkExpr env (SectionL x expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
714 715
  = do new_expr <- zonkLExpr env expr
       new_op   <- zonkLExpr env op
716
       return (SectionL x new_expr new_op)
717

718
zonkExpr env (SectionR x op expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
719 720
  = do new_op   <- zonkLExpr env op
       new_expr <- zonkLExpr env expr
721
       return (SectionR x new_op new_expr)
722

723
zonkExpr env (ExplicitTuple x tup_args boxed)
724
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
725
       ; return (ExplicitTuple x new_tup_args boxed) }
726
  where
727 728
    zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e
                                          ; return (L l (Present x e')) }
729 730
    zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t
                                        ; return (L l (Missing t')) }
731
    zonk_tup_arg (L _ (XTupArg{})) = panic "zonkExpr.XTupArg"
732

733
zonkExpr env (ExplicitSum args alt arity expr)
734 735
  = do new_args <- mapM (zonkTcTypeToType env) args
       new_expr <- zonkLExpr env expr
736
       return (ExplicitSum new_args alt arity new_expr)
737

738
zonkExpr env (HsCase x expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
739 740
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLExpr ms
741
       return (HsCase x new_expr new_ms)
742

743
zonkExpr env (HsIf x Nothing e1 e2 e3)
744 745 746
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       new_e3 <- zonkLExpr env e3
747
       return (HsIf x Nothing new_e1 new_e2 new_e3)
748

749
zonkExpr env (HsIf x (Just fun) e1 e2 e3)
750 751 752 753
  = do (env1, new_fun) <- zonkSyntaxExpr env fun
       new_e1 <- zonkLExpr env1 e1
       new_e2 <- zonkLExpr env1 e2
       new_e3 <- zonkLExpr env1 e3
754
       return (HsIf x (Just new_fun) new_e1 new_e2 new_e3)
755

756 757 758
zonkExpr env (HsMultiIf ty alts)
  = do { alts' <- mapM (wrapLocM zonk_alt) alts
       ; ty'   <- zonkTcTypeToType env ty
759
       ; return $ HsMultiIf ty' alts' }
760
  where zonk_alt (GRHS x guard expr)
761
          = do { (env', guard') <- zonkStmts env zonkLExpr guard
762
               ; expr'          <- zonkLExpr env' expr
763 764
               ; return $ GRHS x guard' expr' }
        zonk_alt (XGRHS _) = panic "zonkExpr.HsMultiIf"
765

766
zonkExpr env (HsLet x (L l binds) expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
767 768
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_expr <- zonkLExpr new_env expr
769
       return (HsLet x (L l new_binds) new_expr)
770

771
zonkExpr env (HsDo ty do_or_lc (L l stmts))
ian@well-typed.com's avatar
ian@well-typed.com committed
772 773
  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
       new_ty <- zonkTcTypeToType env ty
774
       return (HsDo new_ty do_or_lc (L l new_stmts))
775

776
zonkExpr env (ExplicitList ty wit exprs)
777 778 779
  = 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
780
       return (ExplicitList new_ty new_wit new_exprs)
781 782
   where zonkWit env Nothing    = return (env, Nothing)
         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
783

784 785
zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds })
  = do  { new_con_expr <- zonkExpr env (rcon_con_expr ext)
786
        ; new_rbinds   <- zonkRecFields env rbinds
787
        ; return (expr { rcon_ext  = ext { rcon_con_expr = new_con_expr }
788
                       , rcon_flds = new_rbinds }) }
789

790 791 792 793 794
zonkExpr env (RecordUpd { rupd_flds = rbinds
                        , rupd_expr = expr
                        , rupd_ext = RecordUpdTc
                            { rupd_cons = cons, rupd_in_tys = in_tys
                            , rupd_out_tys = out_tys, rupd_wrap = req_wrap }})
795 796 797
  = do  { new_expr    <- zonkLExpr env expr
        ; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
        ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
798
        ; new_rbinds  <- zonkRecUpdFields env rbinds
Matthew Pickering's avatar
Matthew Pickering committed
799
        ; (_, new_recwrap) <- zonkCoFn env req_wrap
800
        ; return (RecordUpd { rupd_expr = new_expr, rupd_flds =  new_rbinds
801 802 803 804
                            , rupd_ext = RecordUpdTc
                                { rupd_cons = cons, rupd_in_tys = new_in_tys
                                , rupd_out_tys = new_out_tys
                                , rupd_wrap = new_recwrap }}) }
805

806
zonkExpr env (ExprWithTySig ty e)
807
  = do { e' <- zonkLExpr env e
808
       ; return (ExprWithTySig ty e') }
809

810
zonkExpr env (ArithSeq expr wit info)
811 812 813
  = 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
814
       return (ArithSeq new_expr new_wit new_info)
815 816
   where zonkWit env Nothing    = return (env, Nothing)
         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
817

818
zonkExpr env (HsSCC x src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
819
  = do new_expr <- zonkLExpr env expr