TcHsSyn.hs 71.4 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 38 39
        zonkCoToCo,
        zonkEvBinds, zonkTcEvBinds,
        zonkTcMethInfoToMethInfo
40 41
  ) where

42
#include "HsVersions.h"
43

44 45
import GhcPrelude

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

80 81
import Control.Monad
import Data.List  ( partition )
82
import Control.Arrow ( second )
83

Austin Seipp's avatar
Austin Seipp committed
84 85 86
{-
************************************************************************
*                                                                      *
87
       Extracting the type from HsSyn
Austin Seipp's avatar
Austin Seipp committed
88 89
*                                                                      *
************************************************************************
90

Austin Seipp's avatar
Austin Seipp committed
91 92
-}

93
hsLPatType :: OutPat GhcTc -> Type
94 95
hsLPatType (L _ pat) = hsPatType pat

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

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

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

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

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

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

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

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

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

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

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

183 184 185
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
186

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

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

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


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

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

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

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

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

setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
267 268
setZonkType (ZonkEnv _ ty_env id_env) zonk_ty
  = ZonkEnv zonk_ty ty_env id_env
269

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

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

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

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

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

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

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

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

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

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

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

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

352 353 354 355 356 357 358 359 360
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
361
zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
362
zonkTyBndrsX = mapAccumLM zonkTyBndrX
dreixel's avatar
dreixel committed
363

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

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

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

385
zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc)
386 387
zonkTopExpr e = zonkExpr emptyZonkEnv e

388
zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)
389 390
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

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

---------------------------------------------
411 412
zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId
               -> TcM (ZonkEnv, HsLocalBinds GhcTc)
413 414
zonkLocalBinds env (EmptyLocalBinds x)
  = return (env, (EmptyLocalBinds x))
415

416
zonkLocalBinds _ (HsValBinds _ (ValBinds {}))
417 418
  = panic "zonkLocalBinds" -- Not in typechecker output

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

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

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

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

457
---------------------------------------------
458
zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc)
459
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
cactus's avatar
cactus committed
460

461
zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc)
462
zonk_lbind env = wrapLocM (zonk_bind env)
463

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

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

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

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

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

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

557 558 559
zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind"
zonk_bind _ (XHsBindsLR _)                 = panic "zonk_bind"

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

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

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

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

Austin Seipp's avatar
Austin Seipp committed
591 592 593
{-
************************************************************************
*                                                                      *
594
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
595 596 597
*                                                                      *
************************************************************************
-}
598

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

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

624
-------------------------------------------------------------------------
625
zonkGRHSs :: ZonkEnv
626 627 628
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> GRHSs GhcTcId (Located (body GhcTcId))
          -> TcM (GRHSs GhcTc (Located (body GhcTc)))
629

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

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

650 651 652
zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc]
zonkLExpr  :: ZonkEnv -> LHsExpr GhcTcId   -> TcM (LHsExpr GhcTc)
zonkExpr   :: ZonkEnv -> HsExpr GhcTcId    -> TcM (HsExpr GhcTc)
653

654
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
655
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
656

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

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

663 664
zonkExpr _ (HsIPVar x id)
  = return (HsIPVar x id)
665

666
zonkExpr _ e@HsOverLabel{} = return e
Adam Gundry's avatar
Adam Gundry committed
667

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

672 673
zonkExpr _ (HsLit x lit)
  = return (HsLit x lit)
674

675
zonkExpr env (HsOverLit x lit)
676
  = do  { lit' <- zonkOverLit env lit
677
        ; return (HsOverLit x lit') }
678

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

683
zonkExpr env (HsLamCase x matches)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
684
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
685
       return (HsLamCase x new_matches)
686

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

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

697
zonkExpr _ e@(HsRnBracketOut _ _ _)
gmainland's avatar
gmainland committed
698 699
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

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

707 708
zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE x s)
709

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

716
zonkExpr env (NegApp x expr op)
717 718
  = do (env', new_op) <- zonkSyntaxExpr env op
       new_expr <- zonkLExpr env' expr
719
       return (NegApp x new_expr new_op)
720

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

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

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

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

745
zonkExpr env (ExplicitSum args alt arity expr)
746 747
  = do new_args <- mapM (zonkTcTypeToType env) args
       new_expr <- zonkLExpr env expr
748
       return (ExplicitSum new_args alt arity new_expr)
749

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

755
zonkExpr env (HsIf x Nothing e1 e2 e3)
756 757 758
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       new_e3 <- zonkLExpr env e3
759
       return (HsIf x Nothing new_e1 new_e2 new_e3)
760

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

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

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

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

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

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

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

818
zonkExpr env (ExprWithTySig ty e)
819
  = do { e' <- zonkLExpr env e
820
       ; return (ExprWithTySig ty e') }
821

822
zonkExpr env (ArithSeq expr wit info)
823 824 825
  = do (env1, new_wit) <- zonkWit env wit
       new_expr <- zonkExpr env expr
       new_info <- zonkArithSeq env1 info