TcHsSyn.hs 69.8 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 102 103 104 105 106
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
hsPatType (ListPat _ _  ty Nothing)     = mkListTy ty
hsPatType (ListPat _ _ _ (Just (ty,_))) = ty
hsPatType (PArrPat ty _)                = mkPArrTy ty
hsPatType (TuplePat tys _ bx)           = mkTupleTy bx tys
hsPatType (SumPat tys _ _ _ )           = mkSumTy tys
107
hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys })
108 109 110 111 112 113 114 115
                                        = 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
116 117 118 119
hsLitType (HsChar _ _)       = charTy
hsLitType (HsCharPrim _ _)   = charPrimTy
hsLitType (HsString _ _)     = stringTy
hsLitType (HsStringPrim _ _) = addrPrimTy
120
hsLitType (HsInt _ _)        = intTy
121 122 123 124 125
hsLitType (HsIntPrim _ _)    = intPrimTy
hsLitType (HsWordPrim _ _)   = wordPrimTy
hsLitType (HsInt64Prim _ _)  = int64PrimTy
hsLitType (HsWord64Prim _ _) = word64PrimTy
hsLitType (HsInteger _ _ ty) = ty
126 127 128
hsLitType (HsRat _ _ ty)     = ty
hsLitType (HsFloatPrim _ _)  = floatPrimTy
hsLitType (HsDoublePrim _ _) = doublePrimTy
129
hsLitType (XLit p)           = pprPanic "hsLitType" (ppr p)
130

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

niteria's avatar
niteria committed
268 269 270 271 272
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
273

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

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

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

301
-- zonkIdBndr is used *after* typechecking to get the Id's type
302
-- to its final form.  The TyVarEnv give
303
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
304 305 306 307 308 309
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'))
310 311

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

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

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

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

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

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

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

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

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

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

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

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

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

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

---------------------------------------------
402 403
zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId
               -> TcM (ZonkEnv, HsLocalBinds GhcTc)
404 405 406
zonkLocalBinds env EmptyLocalBinds
  = return (env, EmptyLocalBinds)

407
zonkLocalBinds _ (HsValBinds (ValBinds {}))
408 409
  = panic "zonkLocalBinds" -- Not in typechecker output

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

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

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

441
---------------------------------------------
442
zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc)
443
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
cactus's avatar
cactus committed
444

445
zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc)
446
zonk_lbind env = wrapLocM (zonk_bind env)
447

448
zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc)
449
zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
450 451 452 453
  = 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 }) }
454

455
zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
456 457 458 459
  = do { new_var  <- zonkIdBndr env var
       ; new_expr <- zonkLExpr env expr
       ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }

460 461
zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
                            , fun_co_fn = co_fn })
462 463
  = do { new_var <- zonkIdBndr env var
       ; (env1, new_co_fn) <- zonkCoFn env co_fn
464
       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
465 466 467
       ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
                      , fun_co_fn = new_co_fn }) }

468 469 470
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                        , abs_ev_binds = ev_binds
                        , abs_exports = exports
471 472
                        , abs_binds = val_binds
                        , abs_sig = has_sig })
473
  = ASSERT( all isImmutableTyVar tyvars )
dreixel's avatar
dreixel committed
474 475
    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
476
       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
477
       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
478 479 480 481
         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
482
            ; return (new_val_binds, new_exports) }
dreixel's avatar
dreixel committed
483 484
       ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
                          , abs_ev_binds = new_ev_binds
485 486
                          , abs_exports = new_exports, abs_binds = new_val_bind
                          , abs_sig = has_sig }) }
sof's avatar
sof committed
487
  where
488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508
    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

    zonk_export env (ABE{ abe_wrap = wrap
                        , abe_poly = poly_id
                        , abe_mono = mono_id
                        , abe_prags = prags })
ian@well-typed.com's avatar
ian@well-typed.com committed
509 510 511
        = do new_poly_id <- zonkIdBndr env poly_id
             (_, new_wrap) <- zonkCoFn env wrap
             new_prags <- zonkSpecPrags env prags
512
             return (ABE{ abe_wrap = new_wrap
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
513
                        , abe_poly = new_poly_id
ian@well-typed.com's avatar
ian@well-typed.com committed
514 515
                        , abe_mono = zonkIdOcc env mono_id
                        , abe_prags = new_prags })
516

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

zonkPatSynDetails :: ZonkEnv
                  -> HsPatSynDetails (Located TcId)
533 534 535 536 537 538 539
                  -> 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
540

541 542
zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId
              -> TcM (ZonkEnv, HsPatSynDir GhcTc)
543
zonkPatSynDir env Unidirectional        = return (env, Unidirectional)
cactus's avatar
cactus committed
544
zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
545 546 547
zonkPatSynDir env (ExplicitBidirectional mg) = do
    mg' <- zonkMatchGroup env zonkLExpr mg
    return (env, ExplicitBidirectional mg')
cactus's avatar
cactus committed
548

549 550
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
551
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
552
                                       ; return (SpecPrags ps') }
553 554 555 556

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
557
  where
558
    zonk_prag (L loc (SpecPrag id co_fn inl))
559 560
        = do { (_, co_fn') <- zonkCoFn env co_fn
             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
561

Austin Seipp's avatar
Austin Seipp committed
562 563 564
{-
************************************************************************
*                                                                      *
565
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
566 567 568
*                                                                      *
************************************************************************
-}
569

570
zonkMatchGroup :: ZonkEnv
571 572 573
            -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
            -> MatchGroup GhcTcId (Located (body GhcTcId))
            -> TcM (MatchGroup GhcTc (Located (body GhcTc)))
574 575
zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys
                             , mg_res_ty = res_ty, mg_origin = origin })
576 577 578
  = do  { ms' <- mapM (zonkMatch env zBody) ms
        ; arg_tys' <- zonkTcTypeToTypes env arg_tys
        ; res_ty'  <- zonkTcTypeToType env res_ty
579 580
        ; return (MG { mg_alts = L l ms', mg_arg_tys = arg_tys'
                     , mg_res_ty = res_ty', mg_origin = origin }) }
581

582
zonkMatch :: ZonkEnv
583 584 585
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> LMatch GhcTcId (Located (body GhcTcId))
          -> TcM (LMatch GhcTc (Located (body GhcTc)))
586
zonkMatch env zBody (L loc match@(Match { m_pats = pats, m_grhss = grhss }))
587 588
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
589
        ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
590

591
-------------------------------------------------------------------------
592
zonkGRHSs :: ZonkEnv
593 594 595
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> GRHSs GhcTcId (Located (body GhcTcId))
          -> TcM (GRHSs GhcTc (Located (body GhcTc)))
596

597
zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
598
    (new_env, new_binds) <- zonkLocalBinds env binds
599
    let
600
        zonk_grhs (GRHS guarded rhs)
ian@well-typed.com's avatar
ian@well-typed.com committed
601 602 603 604
          = 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
605
    return (GRHSs new_grhss (L l new_binds))
606

Austin Seipp's avatar
Austin Seipp committed
607 608 609
{-
************************************************************************
*                                                                      *
610
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
611 612 613
*                                                                      *
************************************************************************
-}
614

615 616 617
zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc]
zonkLExpr  :: ZonkEnv -> LHsExpr GhcTcId   -> TcM (LHsExpr GhcTc)
zonkExpr   :: ZonkEnv -> HsExpr GhcTcId    -> TcM (HsExpr GhcTc)
618

619
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
620
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
621

622
zonkExpr env (HsVar x (L l id))
Ben Gamari's avatar
Ben Gamari committed
623
  = ASSERT2( isNothing (isDataConId_maybe id), ppr id )
624
    return (HsVar x (L l (zonkIdOcc env id)))
625 626

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

628 629
zonkExpr _ (HsIPVar x id)
  = return (HsIPVar x id)
630

631
zonkExpr _ e@HsOverLabel{} = return e
Adam Gundry's avatar
Adam Gundry committed
632

633
zonkExpr env (HsLit x (HsRat e f ty))
ian@well-typed.com's avatar
ian@well-typed.com committed
634
  = do new_ty <- zonkTcTypeToType env ty
635
       return (HsLit x (HsRat e f new_ty))
sof's avatar
sof committed
636

637 638
zonkExpr _ (HsLit x lit)
  = return (HsLit x lit)
639

640
zonkExpr env (HsOverLit x lit)
641
  = do  { lit' <- zonkOverLit env lit
642
        ; return (HsOverLit x lit') }
643

644
zonkExpr env (HsLam x matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
645
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
646
       return (HsLam x new_matches)
647

648
zonkExpr env (HsLamCase x matches)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
649
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
650
       return (HsLamCase x new_matches)
651

652
zonkExpr env (HsApp x e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
653 654
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
655
       return (HsApp x new_e1 new_e2)
656

657
zonkExpr env (HsAppType t e)
658
  = do new_e <- zonkLExpr env e
659
       return (HsAppType t new_e)
660 661
       -- NB: the type is an HsType; can't zonk that!

662
zonkExpr _ e@(HsRnBracketOut _ _ _)
gmainland's avatar
gmainland committed
663 664
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

665
zonkExpr env (HsTcBracketOut x body bs)
ian@well-typed.com's avatar
ian@well-typed.com committed
666
  = do bs' <- mapM zonk_b bs
667
       return (HsTcBracketOut x body bs')
668
  where
669 670
    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
                                      return (PendingTcSplice n e')
gmainland's avatar
gmainland committed
671

672 673
zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE x s)
674

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

681
zonkExpr env (NegApp x expr op)
682 683
  = do (env', new_op) <- zonkSyntaxExpr env op
       new_expr <- zonkLExpr env' expr
684
       return (NegApp x new_expr new_op)
685

686
zonkExpr env (HsPar x e)
ian@well-typed.com's avatar
ian@well-typed.com committed
687
  = do new_e <- zonkLExpr env e
688
       return (HsPar x new_e)
689

690
zonkExpr env (SectionL x expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
691 692
  = do new_expr <- zonkLExpr env expr
       new_op   <- zonkLExpr env op
693
       return (SectionL x new_expr new_op)
694

695
zonkExpr env (SectionR x op expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
696 697
  = do new_op   <- zonkLExpr env op
       new_expr <- zonkLExpr env expr
698
       return (SectionR x new_op new_expr)
699

700
zonkExpr env (ExplicitTuple x tup_args boxed)
701
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
702
       ; return (ExplicitTuple x new_tup_args boxed) }
703
  where
704 705
    zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e
                                          ; return (L l (Present x e')) }
706 707
    zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t
                                        ; return (L l (Missing t')) }
708
    zonk_tup_arg (L _ (XTupArg{})) = panic "zonkExpr.XTupArg"
709

710
zonkExpr env (ExplicitSum args alt arity expr)
711 712
  = do new_args <- mapM (zonkTcTypeToType env) args
       new_expr <- zonkLExpr env expr
713
       return (ExplicitSum new_args alt arity new_expr)
714

715
zonkExpr env (HsCase x expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
716 717
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLExpr ms
718
       return (HsCase x new_expr new_ms)
719

720
zonkExpr env (HsIf x Nothing e1 e2 e3)
721 722 723
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       new_e3 <- zonkLExpr env e3
724
       return (HsIf x Nothing new_e1 new_e2 new_e3)
725

726
zonkExpr env (HsIf x (Just fun) e1 e2 e3)
727 728 729 730
  = do (env1, new_fun) <- zonkSyntaxExpr env fun
       new_e1 <- zonkLExpr env1 e1
       new_e2 <- zonkLExpr env1 e2
       new_e3 <- zonkLExpr env1 e3
731
       return (HsIf x (Just new_fun) new_e1 new_e2 new_e3)
732

733 734 735
zonkExpr env (HsMultiIf ty alts)
  = do { alts' <- mapM (wrapLocM zonk_alt) alts
       ; ty'   <- zonkTcTypeToType env ty
736
       ; return $ HsMultiIf ty' alts' }
737
  where zonk_alt (GRHS guard expr)
738
          = do { (env', guard') <- zonkStmts env zonkLExpr guard
739
               ; expr'          <- zonkLExpr env' expr
740
               ; return $ GRHS guard' expr' }
741

742
zonkExpr env (HsLet x (L l binds) expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
743 744
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_expr <- zonkLExpr new_env expr
745
       return (HsLet x (L l new_binds) new_expr)
746

747
zonkExpr env (HsDo ty do_or_lc (L l stmts))
ian@well-typed.com's avatar
ian@well-typed.com committed
748 749
  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
       new_ty <- zonkTcTypeToType env ty
750
       return (HsDo new_ty do_or_lc (L l new_stmts))
751

752
zonkExpr env (ExplicitList ty wit exprs)
753 754 755
  = 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
756
       return (ExplicitList new_ty new_wit new_exprs)
757 758
   where zonkWit env Nothing    = return (env, Nothing)
         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
759 760

zonkExpr env (ExplicitPArr ty exprs)
ian@well-typed.com's avatar
ian@well-typed.com committed
761 762 763
  = do new_ty <- zonkTcTypeToType env ty
       new_exprs <- zonkLExprs env exprs
       return (ExplicitPArr new_ty new_exprs)
764

765 766
zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds })
  = do  { new_con_expr <- zonkExpr env (rcon_con_expr ext)
767
        ; new_rbinds   <- zonkRecFields env rbinds
768
        ; return (expr { rcon_ext  = ext { rcon_con_expr = new_con_expr }
769
                       , rcon_flds = new_rbinds }) }
770

771 772 773 774 775
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 }})
776 777 778
  = do  { new_expr    <- zonkLExpr env expr
        ; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
        ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
779
        ; new_rbinds  <- zonkRecUpdFields env rbinds
Matthew Pickering's avatar
Matthew Pickering committed
780
        ; (_, new_recwrap) <- zonkCoFn env req_wrap
781
        ; return (RecordUpd { rupd_expr = new_expr, rupd_flds =  new_rbinds
782 783 784 785
                            , rupd_ext = RecordUpdTc
                                { rupd_cons = cons, rupd_in_tys = new_in_tys
                                , rupd_out_tys = new_out_tys
                                , rupd_wrap = new_recwrap }}) }
786

787
zonkExpr env (ExprWithTySig ty e)
788
  = do { e' <- zonkLExpr env e
789
       ; return (ExprWithTySig ty e') }
790

791
zonkExpr env (ArithSeq expr wit info)
792 793 794
  = 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
795
       return (ArithSeq new_expr new_wit new_info)
796 797
   where zonkWit env Nothing    = return (env, Nothing)
         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
798

799
zonkExpr env (PArrSeq expr info)
ian@well-typed.com's avatar
ian@well-typed.com committed
800 801 802
  = do new_expr <- zonkExpr env expr
       new_info <- zonkArithSeq env info
       return (PArrSeq new_expr new_info)
803

804
zonkExpr env (HsSCC x src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
805
  = do new_expr <- zonkLExpr env expr
806
       return (HsSCC x src lbl new_expr)
807

808
zonkExpr env (HsTickPragma x src info srcInfo expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
809
  = do new_expr <- zonkLExpr env expr
810
       return (HsTickPragma x src info srcInfo new_expr)
andy@galois.com's avatar
andy@galois.com committed
811

812
-- hdaume: core annotations
813
zonkExpr env (HsCoreAnn x src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
814
  = do new_expr <- zonkLExpr env expr
815
       return (HsCoreAnn x src lbl new_expr)
816

817
-- arrow notation extensions
818
zonkExpr env (HsProc x pat body)
819 820
  = do  { (env1, new_pat) <- zonkPat env pat
        ; new_body <- zonkCmdTop env1 body
821
        ; return (HsProc x new_pat new_body) }