TcHsSyn.hs 70.9 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

349 350 351 352 353 354 355 356 357
zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var)
zonkCoreBndrX env v
  | isId v = do { v' <- zonkIdBndr env v
                ; return (extendIdZonkEnv1 env v', v') }
  | otherwise = zonkTyBndrX env v

zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var])
zonkCoreBndrsX = mapAccumLM zonkCoreBndrX

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
361
zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
362 363
-- 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
364
zonkTyBndrX env tv
365 366
  = ASSERT( isImmutableTyVar tv )
    do { ki <- zonkTcTypeToType env (tyVarKind tv)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
367
               -- Internal names tidy up better, for iface files.
368 369
       ; let tv' = mkTyVar (tyVarName tv) ki
       ; return (extendTyZonkEnv1 env tv', tv') }
370

Simon Peyton Jones's avatar
Simon Peyton Jones committed
371 372 373
zonkTyVarBindersX :: ZonkEnv -> [TyVarBndr TcTyVar vis]
                             -> TcM (ZonkEnv, [TyVarBndr TyVar vis])
zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX
374

Simon Peyton Jones's avatar
Simon Peyton Jones committed
375 376 377 378
zonkTyVarBinderX :: ZonkEnv -> TyVarBndr TcTyVar vis
                            -> TcM (ZonkEnv, TyVarBndr TyVar vis)
-- Takes a TcTyVar and guarantees to return a TyVar
zonkTyVarBinderX env (TvBndr tv vis)
379
  = do { (env', tv') <- zonkTyBndrX env tv
380
       ; return (env', TvBndr tv' vis) }
381

382
zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc)
383 384
zonkTopExpr e = zonkExpr emptyZonkEnv e

385
zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)
386 387
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

388
zonkTopDecls :: Bag EvBind
389
             -> LHsBinds GhcTcId
390
             -> [LRuleDecl GhcTcId] -> [LTcSpecPrag]
391
             -> [LForeignDecl GhcTcId]
niteria's avatar
niteria committed
392
             -> TcM (TypeEnv,
393
                     Bag EvBind,
394 395
                     LHsBinds GhcTc,
                     [LForeignDecl GhcTc],
396
                     [LTcSpecPrag],
397 398
                     [LRuleDecl    GhcTc])
zonkTopDecls ev_binds binds rules imp_specs fords
399
  = do  { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
400
        ; (env2, binds') <- zonkRecMonoBinds env1 binds
401 402
                        -- Top level is implicitly recursive
        ; rules' <- zonkRules env2 rules
403
        ; specs' <- zonkLTcSpecPrags env2 imp_specs
404
        ; fords' <- zonkForeignExports env2 fords
405
        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }
406 407

---------------------------------------------
408 409
zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId
               -> TcM (ZonkEnv, HsLocalBinds GhcTc)
410 411
zonkLocalBinds env (EmptyLocalBinds x)
  = return (env, (EmptyLocalBinds x))
412

413
zonkLocalBinds _ (HsValBinds _ (ValBinds {}))
414 415
  = panic "zonkLocalBinds" -- Not in typechecker output

416
zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs)))
417
  = do  { (env1, new_binds) <- go env binds
418
        ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) }
419
  where
420
    go env []
421
      = return (env, [])
422 423 424
    go env ((r,b):bs)
      = do { (env1, b')  <- zonkRecMonoBinds env b
           ; (env2, bs') <- go env1 bs
425
           ; return (env2, (r,b'):bs') }
426

427
zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
428
    new_binds <- mapM (wrapLocM zonk_ip_bind) binds
429
    let
430 431
        env1 = extendIdZonkEnvRec env [ n
                                      | L _ (IPBind _ (Right n) _) <- new_binds]
ian@well-typed.com's avatar
ian@well-typed.com committed
432
    (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
433
    return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds))
434
  where
435
    zonk_ip_bind (IPBind x n e)
ian@well-typed.com's avatar
ian@well-typed.com committed
436 437
        = do n' <- mapIPNameTc (zonkIdBndr env) n
             e' <- zonkLExpr env e
438 439 440 441 442 443 444
             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
445

446
---------------------------------------------
447
zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc)
448
zonkRecMonoBinds env binds
449
 = fixM (\ ~(_, new_binds) -> do
450
        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)
451
        ; binds' <- zonkMonoBinds env1 binds
452 453
        ; return (env1, binds') })

454
---------------------------------------------
455
zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc)
456
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
cactus's avatar
cactus committed
457

458
zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc)
459
zonk_lbind env = wrapLocM (zonk_bind env)
460

461
zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc)
462 463
zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss
                            , pat_ext = NPatBindTc fvs ty})
464 465 466
  = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
        ; new_grhss <- zonkGRHSs env zonkLExpr grhss
        ; new_ty    <- zonkTcTypeToType env ty
467 468
        ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss
                       , pat_ext = NPatBindTc fvs new_ty }) }
469

470 471
zonk_bind env (VarBind { var_ext = x
                       , var_id = var, var_rhs = expr, var_inline = inl })
472 473
  = do { new_var  <- zonkIdBndr env var
       ; new_expr <- zonkLExpr env expr
474 475 476 477
       ; return (VarBind { var_ext = x
                         , var_id = new_var
                         , var_rhs = new_expr
                         , var_inline = inl }) }
478

479 480
zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
                            , fun_co_fn = co_fn })
481 482
  = do { new_var <- zonkIdBndr env var
       ; (env1, new_co_fn) <- zonkCoFn env co_fn
483
       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
484 485 486
       ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
                      , fun_co_fn = new_co_fn }) }

487 488 489
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                        , abs_ev_binds = ev_binds
                        , abs_exports = exports
490 491
                        , abs_binds = val_binds
                        , abs_sig = has_sig })
492
  = ASSERT( all isImmutableTyVar tyvars )
dreixel's avatar
dreixel committed
493 494
    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
495
       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
496
       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
497 498 499 500
         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
501
            ; return (new_val_binds, new_exports) }
502 503
       ; return (AbsBinds { abs_ext = noExt
                          , abs_tvs = new_tyvars, abs_ev_vars = new_evs
dreixel's avatar
dreixel committed
504
                          , abs_ev_binds = new_ev_binds
505 506
                          , abs_exports = new_exports, abs_binds = new_val_bind
                          , abs_sig = has_sig }) }
sof's avatar
sof committed
507
  where
508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524
    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

525 526
    zonk_export env (ABE{ abe_ext = x
                        , abe_wrap = wrap
527 528 529
                        , abe_poly = poly_id
                        , abe_mono = mono_id
                        , abe_prags = prags })
ian@well-typed.com's avatar
ian@well-typed.com committed
530 531 532
        = do new_poly_id <- zonkIdBndr env poly_id
             (_, new_wrap) <- zonkCoFn env wrap
             new_prags <- zonkSpecPrags env prags
533 534
             return (ABE{ abe_ext = x
                        , abe_wrap = new_wrap
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
535
                        , abe_poly = new_poly_id
ian@well-typed.com's avatar
ian@well-typed.com committed
536 537
                        , abe_mono = zonkIdOcc env mono_id
                        , abe_prags = new_prags })
538
    zonk_export _ (XABExport _) = panic "zonk_bind: XABExport"
539

540 541 542 543
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
544
  = do { id' <- zonkIdBndr env id
545
       ; (env1, lpat') <- zonkPat env lpat
546
       ; let details' = zonkPatSynDetails env1 details
cactus's avatar
cactus committed
547
       ; (_env2, dir') <- zonkPatSynDir env1 dir
548
       ; return $ PatSynBind x $
549 550 551 552
                  bind { psb_id = L loc id'
                       , psb_args = details'
                       , psb_def = lpat'
                       , psb_dir = dir' } }
cactus's avatar
cactus committed
553

554 555 556
zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind"
zonk_bind _ (XHsBindsLR _)                 = panic "zonk_bind"

cactus's avatar
cactus committed
557 558
zonkPatSynDetails :: ZonkEnv
                  -> HsPatSynDetails (Located TcId)
559 560 561 562 563 564 565
                  -> 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
566

567 568
zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId
              -> TcM (ZonkEnv, HsPatSynDir GhcTc)
569
zonkPatSynDir env Unidirectional        = return (env, Unidirectional)
cactus's avatar
cactus committed
570
zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
571 572 573
zonkPatSynDir env (ExplicitBidirectional mg) = do
    mg' <- zonkMatchGroup env zonkLExpr mg
    return (env, ExplicitBidirectional mg')
cactus's avatar
cactus committed
574

575 576
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
577
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
578
                                       ; return (SpecPrags ps') }
579 580 581 582

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
583
  where
584
    zonk_prag (L loc (SpecPrag id co_fn inl))
585 586
        = do { (_, co_fn') <- zonkCoFn env co_fn
             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
587

Austin Seipp's avatar
Austin Seipp committed
588 589 590
{-
************************************************************************
*                                                                      *
591
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
592 593 594
*                                                                      *
************************************************************************
-}
595

596
zonkMatchGroup :: ZonkEnv
597 598 599
            -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
            -> MatchGroup GhcTcId (Located (body GhcTcId))
            -> TcM (MatchGroup GhcTc (Located (body GhcTc)))
600 601 602
zonkMatchGroup env zBody (MG { mg_alts = L l ms
                             , mg_ext = MatchGroupTc arg_tys res_ty
                             , mg_origin = origin })
603 604 605
  = do  { ms' <- mapM (zonkMatch env zBody) ms
        ; arg_tys' <- zonkTcTypeToTypes env arg_tys
        ; res_ty'  <- zonkTcTypeToType env res_ty
606 607 608 609
        ; return (MG { mg_alts = L l ms'
                     , mg_ext = MatchGroupTc arg_tys' res_ty'
                     , mg_origin = origin }) }
zonkMatchGroup _ _ (XMatchGroup {}) = panic "zonkMatchGroup"
610

611
zonkMatch :: ZonkEnv
612 613 614
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> LMatch GhcTcId (Located (body GhcTcId))
          -> TcM (LMatch GhcTc (Located (body GhcTc)))
615
zonkMatch env zBody (L loc match@(Match { m_pats = pats, m_grhss = grhss }))
616 617
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
618
        ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
619
zonkMatch _ _ (L  _ (XMatch _)) = panic "zonkMatch"
620

621
-------------------------------------------------------------------------
622
zonkGRHSs :: ZonkEnv
623 624 625
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> GRHSs GhcTcId (Located (body GhcTcId))
          -> TcM (GRHSs GhcTc (Located (body GhcTc)))
626

627
zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
628
    (new_env, new_binds) <- zonkLocalBinds env binds
629
    let
630
        zonk_grhs (GRHS xx guarded rhs)
ian@well-typed.com's avatar
ian@well-typed.com committed
631 632
          = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
               new_rhs <- zBody env2 rhs
633 634
               return (GRHS xx new_guarded new_rhs)
        zonk_grhs (XGRHS _) = panic "zonkGRHSs"
ian@well-typed.com's avatar
ian@well-typed.com committed
635
    new_grhss <- mapM (wrapLocM zonk_grhs) grhss
636 637
    return (GRHSs x new_grhss (L l new_binds))
zonkGRHSs _ _ (XGRHSs _) = panic "zonkGRHSs"
638

Austin Seipp's avatar
Austin Seipp committed
639 640 641
{-
************************************************************************
*                                                                      *
642
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
643 644 645
*                                                                      *
************************************************************************
-}
646

647 648 649
zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc]
zonkLExpr  :: ZonkEnv -> LHsExpr GhcTcId   -> TcM (LHsExpr GhcTc)
zonkExpr   :: ZonkEnv -> HsExpr GhcTcId    -> TcM (HsExpr GhcTc)
650

651
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
652
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
653

654
zonkExpr env (HsVar x (L l id))
Ben Gamari's avatar
Ben Gamari committed
655
  = ASSERT2( isNothing (isDataConId_maybe id), ppr id )
656
    return (HsVar x (L l (zonkIdOcc env id)))
657 658

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

660 661
zonkExpr _ (HsIPVar x id)
  = return (HsIPVar x id)
662

663
zonkExpr _ e@HsOverLabel{} = return e
Adam Gundry's avatar
Adam Gundry committed
664

665
zonkExpr env (HsLit x (HsRat e f ty))
ian@well-typed.com's avatar
ian@well-typed.com committed
666
  = do new_ty <- zonkTcTypeToType env ty
667
       return (HsLit x (HsRat e f new_ty))
sof's avatar
sof committed
668

669 670
zonkExpr _ (HsLit x lit)
  = return (HsLit x lit)
671

672
zonkExpr env (HsOverLit x lit)
673
  = do  { lit' <- zonkOverLit env lit
674
        ; return (HsOverLit x lit') }
675

676
zonkExpr env (HsLam x matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
677
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
678
       return (HsLam x new_matches)
679

680
zonkExpr env (HsLamCase x matches)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
681
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
682
       return (HsLamCase x new_matches)
683

684
zonkExpr env (HsApp x e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
685 686
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
687
       return (HsApp x new_e1 new_e2)
688

689
zonkExpr env (HsAppType t e)
690
  = do new_e <- zonkLExpr env e
691
       return (HsAppType t new_e)
692 693
       -- NB: the type is an HsType; can't zonk that!

694
zonkExpr _ e@(HsRnBracketOut _ _ _)
gmainland's avatar
gmainland committed
695 696
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

697
zonkExpr env (HsTcBracketOut x body bs)
ian@well-typed.com's avatar
ian@well-typed.com committed
698
  = do bs' <- mapM zonk_b bs
699
       return (HsTcBracketOut x body bs')
700
  where
701 702
    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
                                      return (PendingTcSplice n e')
gmainland's avatar
gmainland committed
703

704 705
zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE x s)
706

707
zonkExpr env (OpApp fixity e1 op e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
708 709 710
  = do new_e1 <- zonkLExpr env e1
       new_op <- zonkLExpr env op
       new_e2 <- zonkLExpr env e2
711
       return (OpApp fixity new_e1 new_op new_e2)
712

713
zonkExpr env (NegApp x expr op)
714 715
  = do (env', new_op) <- zonkSyntaxExpr env op
       new_expr <- zonkLExpr env' expr
716
       return (NegApp x new_expr new_op)
717

718
zonkExpr env (HsPar x e)
ian@well-typed.com's avatar
ian@well-typed.com committed
719
  = do new_e <- zonkLExpr env e
720
       return (HsPar x new_e)
721

722
zonkExpr env (SectionL x expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
723 724
  = do new_expr <- zonkLExpr env expr
       new_op   <- zonkLExpr env op
725
       return (SectionL x new_expr new_op)
726

727
zonkExpr env (SectionR x op expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
728 729
  = do new_op   <- zonkLExpr env op
       new_expr <- zonkLExpr env expr
730
       return (SectionR x new_op new_expr)
731

732
zonkExpr env (ExplicitTuple x tup_args boxed)
733
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
734
       ; return (ExplicitTuple x new_tup_args boxed) }
735
  where
736 737
    zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e
                                          ; return (L l (Present x e')) }
738 739
    zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t
                                        ; return (L l (Missing t')) }
740
    zonk_tup_arg (L _ (XTupArg{})) = panic "zonkExpr.XTupArg"
741

742
zonkExpr env (ExplicitSum args alt arity expr)
743 744
  = do new_args <- mapM (zonkTcTypeToType env) args
       new_expr <- zonkLExpr env expr
745
       return (ExplicitSum new_args alt arity new_expr)
746

747
zonkExpr env (HsCase x expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
748 749
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLExpr ms
750
       return (HsCase x new_expr new_ms)
751

752
zonkExpr env (HsIf x Nothing e1 e2 e3)
753 754 755
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       new_e3 <- zonkLExpr env e3
756
       return (HsIf x Nothing new_e1 new_e2 new_e3)
757

758
zonkExpr env (HsIf x (Just fun) e1 e2 e3)
759 760 761 762
  = do (env1, new_fun) <- zonkSyntaxExpr env fun
       new_e1 <- zonkLExpr env1 e1
       new_e2 <- zonkLExpr env1 e2
       new_e3 <- zonkLExpr env1 e3
763
       return (HsIf x (Just new_fun) new_e1 new_e2 new_e3)
764

765 766 767
zonkExpr env (HsMultiIf ty alts)
  = do { alts' <- mapM (wrapLocM zonk_alt) alts
       ; ty'   <- zonkTcTypeToType env ty
768
       ; return $ HsMultiIf ty' alts' }
769
  where zonk_alt (GRHS x guard expr)
770
          = do { (env', guard') <- zonkStmts env zonkLExpr guard
771
               ; expr'          <- zonkLExpr env' expr
772 773
               ; return $ GRHS x guard' expr' }
        zonk_alt (XGRHS _) = panic "zonkExpr.HsMultiIf"
774

775
zonkExpr env (HsLet x (L l binds) expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
776 777
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_expr <- zonkLExpr new_env expr
778
       return (HsLet x (L l new_binds) new_expr)
779

780
zonkExpr env (HsDo ty do_or_lc (L l stmts))
ian@well-typed.com's avatar
ian@well-typed.com committed
781 782
  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
       new_ty <- zonkTcTypeToType env ty
783
       return (HsDo new_ty do_or_lc (L l new_stmts))
784

785
zonkExpr env (ExplicitList ty wit exprs)
786 787 788
  = 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
789
       return (ExplicitList new_ty new_wit new_exprs)
790 791
   where zonkWit env Nothing    = return (env, Nothing)
         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
792

793 794
zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds })
  = do  { new_con_expr <- zonkExpr env (rcon_con_expr ext)
795
        ; new_rbinds   <- zonkRecFields env rbinds
796
        ; return (expr { rcon_ext  = ext { rcon_con_expr = new_con_expr }
797
                       , rcon_flds = new_rbinds }) }
798

799 800 801 802 803
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 }})
804 805 806
  = do  { new_expr    <- zonkLExpr env expr
        ; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
        ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
807
        ; new_rbinds  <- zonkRecUpdFields env rbinds
Matthew Pickering's avatar
Matthew Pickering committed
808
        ; (_, new_recwrap) <- zonkCoFn env req_wrap
809
        ; return (RecordUpd { rupd_expr = new_expr, rupd_flds =  new_rbinds
810 811 812 813
                            , rupd_ext = RecordUpdTc
                                { rupd_cons = cons, rupd_in_tys = new_in_tys
                                , rupd_out_tys = new_out_tys
                                , rupd_wrap = new_recwrap }}) }
814

815
zonkExpr env (ExprWithTySig ty e)
816
  = do { e' <- zonkLExpr env e
817
       ; return (ExprWithTySig ty e') }
818

819
zonkExpr env (ArithSeq expr wit info)
820 821 822
  = 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
823
       return (ArithSeq new_expr new_wit new_info)
824 825
   where zonkWit env Nothing    = return (env, Nothing)
         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln