TcHsSyn.hs 76.3 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
{-# LANGUAGE ViewPatterns #-}
16

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

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

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

30 31 32
        -- * Zonking
        -- | For a description of "zonking", see Note [What is zonking?]
        -- in TcMType
33
        zonkTopDecls, zonkTopExpr, zonkTopLExpr,
34 35 36 37 38 39 40
        zonkTopBndrs,
        ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv,
        zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX,
        zonkTyBndrs, zonkTyBndrsX,
        zonkTcTypeToType,  zonkTcTypeToTypeX,
        zonkTcTypesToTypes, zonkTcTypesToTypesX,
        zonkTyVarOcc,
41 42
        zonkCoToCo,
        zonkEvBinds, zonkTcEvBinds,
43
        zonkTcMethInfoToMethInfoX
44 45
  ) where

46
#include "HsVersions.h"
47

48 49
import GhcPrelude

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

83 84
import Control.Monad
import Data.List  ( partition )
85
import Control.Arrow ( second )
86

Austin Seipp's avatar
Austin Seipp committed
87 88 89
{-
************************************************************************
*                                                                      *
90
       Extracting the type from HsSyn
Austin Seipp's avatar
Austin Seipp committed
91 92
*                                                                      *
************************************************************************
93

Austin Seipp's avatar
Austin Seipp committed
94 95
-}

96
hsLPatType :: OutPat GhcTc -> Type
97
hsLPatType lpat = hsPatType (unLoc lpat)
98

99
hsPatType :: Pat GhcTc -> Type
100 101
hsPatType (ParPat _ pat)                = hsLPatType pat
hsPatType (WildPat ty)                  = ty
102
hsPatType (VarPat _ lvar)               = idType (unLoc lvar)
103 104 105 106 107
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
108 109
hsPatType (ListPat (ListPatTc ty Nothing) _)      = mkListTy ty
hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty
110 111
hsPatType (TuplePat tys _ bx)           = mkTupleTy bx tys
hsPatType (SumPat tys _ _ _ )           = mkSumTy tys
112 113 114
hsPatType (ConPatOut { pat_con = lcon
                     , pat_arg_tys = tys })
                                        = conLikeResTy (unLoc lcon) tys
115
hsPatType (SigPat ty _ _)               = ty
116 117 118 119 120 121
hsPatType (NPat ty _ _ _)               = ty
hsPatType (NPlusKPat ty _ _ _ _ _)      = ty
hsPatType (CoPat _ _ _ ty)              = ty
hsPatType p                             = pprPanic "hsPatType" (ppr p)

hsLitType :: HsLit (GhcPass p) -> TcType
122 123 124 125
hsLitType (HsChar _ _)       = charTy
hsLitType (HsCharPrim _ _)   = charPrimTy
hsLitType (HsString _ _)     = stringTy
hsLitType (HsStringPrim _ _) = addrPrimTy
126
hsLitType (HsInt _ _)        = intTy
127 128 129 130 131
hsLitType (HsIntPrim _ _)    = intPrimTy
hsLitType (HsWordPrim _ _)   = wordPrimTy
hsLitType (HsInt64Prim _ _)  = int64PrimTy
hsLitType (HsWord64Prim _ _) = word64PrimTy
hsLitType (HsInteger _ _ ty) = ty
132 133 134
hsLitType (HsRat _ _ ty)     = ty
hsLitType (HsFloatPrim _ _)  = floatPrimTy
hsLitType (HsDoublePrim _ _) = doublePrimTy
135
hsLitType (XLit p)           = pprPanic "hsLitType" (ppr p)
136

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

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

151
shortCutLit _ (HsFractional f) ty
152 153
  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim noExt f))
  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExt f))
154 155
  | otherwise     = Nothing

156
shortCutLit _ (HsIsString src s) ty
157
  | isStringTy ty = Just (HsLit noExt (HsString src s))
158 159
  | otherwise     = Nothing

160
mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc
161
mkLit con lit = HsApp noExt (nlHsDataCon con) (nlHsLit lit)
162 163 164 165 166 167 168

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

Austin Seipp's avatar
Austin Seipp committed
170 171 172
{-
************************************************************************
*                                                                      *
173
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
Austin Seipp's avatar
Austin Seipp committed
174 175
*                                                                      *
************************************************************************
176

177 178
The rest of the zonking is done *after* typechecking.
The main zonking pass runs over the bindings
179 180 181

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

184 185
The type variables are converted by binding mutable tyvars to immutable ones
and then zonking as normal.
186

187 188 189
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
190

191
It's all pretty boring stuff, because HsSyn is such a large type, and
192
the environment manipulation is tiresome.
Austin Seipp's avatar
Austin Seipp committed
193
-}
194

195
-- Confused by zonking? See Note [What is zonking?] in TcMType.
196 197

-- | See Note [The ZonkEnv]
198
-- Confused by zonking? See Note [What is zonking?] in TcMType.
199 200 201
data ZonkEnv  -- See Note [The ZonkEnv]
  = ZonkEnv { ze_flexi  :: ZonkFlexi
            , ze_tv_env :: TyCoVarEnv TyCoVar
202 203
            , ze_id_env :: IdEnv      Id
            , ze_meta_tv_env :: TcRef (TyVarEnv Type) }
204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227
{- Note [The ZonkEnv]
~~~~~~~~~~~~~~~~~~~~~
* ze_flexi :: ZonkFlexi says what to do with a
  unification variable that is still un-unified.
  See Note [Un-unified unification variables]

* ze_tv_env :: TyCoVarEnv TyCoVar promotes sharing. At a binding site
  of 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.

* ze_id_env : IdEnv Id promotes sharing among Ids, by making all
  occurrences of the Id point to a single zonked copy, built at the
  binding site.

  Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec.
  In a mutually recusive group
     rec { f = ...g...; g = ...f... }
  we want the occurrence of g to point to the one zonked Id for g,
  and the same for f.

  Because it is knot-tied, we must be careful to consult it lazily.
  Specifically, zonkIdOcc is not monadic.

228 229 230
* ze_meta_tv_env: see Note [Sharing when zonking to Type]


231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268
Notes:
  * We must be careful never to put coercion variables (which are Ids,
    after all) in the knot-tied ze_id_env, because coercions can
    appear in types, and we sometimes inspect a zonked type in this
    module.  [Question: where, precisely?]

  * In zonkTyVarOcc we consult ze_tv_env in a monadic context,
    a second reason that ze_tv_env can't be monadic.

  * An obvious suggestion would be to have one VarEnv Var to
    replace both ze_id_env and ze_tv_env, but that doesn't work
    because of the knot-tying stuff mentioned above.

Note [Un-unified unification variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
What should we do if we find a Flexi unification variable?
There are three possibilities:

* DefaultFlexi: this is the common case, in situations like
     length @alpha ([] @alpha)
  It really doesn't matter what type we choose for alpha.  But
  we must choose a type!  We can't leae mutable unification
  variables floating around: after typecheck is complete, every
  type variable occurrence must have a bindign site.

  So we default it to 'Any' of the right kind.

  All this works for both type and kind variables (indeed
  the two are the same thign).

* SkolemiseFlexi: is a special case for the LHS of RULES.
  See Note [Zonking the LHS of a RULE]

* RuntimeUnkFlexi: is a special case for the GHCi debugger.
  It's a way to have a variable that is not a mutuable
  unification variable, but doesn't have a binding site
  either.
-}
269

270 271 272 273 274
data ZonkFlexi   -- See Note [Un-unified unification variables]
  = DefaultFlexi    -- Default unbound unificaiton variables to Any
  | SkolemiseFlexi  -- Skolemise unbound unification variables
                    -- See Note [Zonking the LHS of a RULE]
  | RuntimeUnkFlexi -- Used in the GHCi debugger
275

276 277
instance Outputable ZonkEnv where
  ppr (ZonkEnv { ze_id_env =  var_env}) = pprUFM var_env (vcat . map ppr)
278

279
-- The EvBinds have to already be zonked, but that's usually the case.
280
emptyZonkEnv :: TcM ZonkEnv
281
emptyZonkEnv = mkEmptyZonkEnv DefaultFlexi
282

283 284 285 286 287 288 289 290 291 292 293
mkEmptyZonkEnv :: ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv flexi
  = do { mtv_env_ref <- newTcRef emptyVarEnv
       ; return (ZonkEnv { ze_flexi = flexi
                         , ze_tv_env = emptyVarEnv
                         , ze_id_env = emptyVarEnv
                         , ze_meta_tv_env = mtv_env_ref }) }

initZonkEnv :: (ZonkEnv -> a -> TcM b) -> a -> TcM b
initZonkEnv do_it x = do { ze <- mkEmptyZonkEnv DefaultFlexi
                         ; do_it ze x }
294

295 296
-- | Extend the knot-tied environment.
extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv
297
extendIdZonkEnvRec ze@(ZonkEnv { ze_id_env = id_env }) ids
298 299
    -- 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.
300
  = ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] }
301 302 303 304 305 306 307 308
  -- 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
309 310 311 312 313
extendZonkEnv ze@(ZonkEnv { ze_tv_env = tyco_env, ze_id_env = id_env }) vars
  = ze { ze_tv_env = extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars]
       , ze_id_env = extendVarEnvList id_env   [(id,id) | id <- ids] }
  where
    (tycovars, ids) = partition isTyCoVar vars
314

dreixel's avatar
dreixel committed
315
extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
316 317
extendIdZonkEnv1 ze@(ZonkEnv { ze_id_env = id_env }) id
  = ze { ze_id_env = extendVarEnv id_env id id }
318

dreixel's avatar
dreixel committed
319
extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
320 321
extendTyZonkEnv1 ze@(ZonkEnv { ze_tv_env = ty_env }) tv
  = ze { ze_tv_env = extendVarEnv ty_env tv tv }
dreixel's avatar
dreixel committed
322

323 324
setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv
setZonkType ze flexi = ze { ze_flexi = flexi }
325

niteria's avatar
niteria committed
326
zonkEnvIds :: ZonkEnv -> TypeEnv
327 328
zonkEnvIds (ZonkEnv { ze_id_env = id_env})
  = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env]
niteria's avatar
niteria committed
329 330
  -- It's OK to use nonDetEltsUFM here because we forget the ordering
  -- immediately by creating a TypeEnv
331

332
zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id
333
zonkLIdOcc env = onHasSrcSpan (zonkIdOcc env)
334

335
zonkIdOcc :: ZonkEnv -> TcId -> Id
336
-- Ids defined in this module should be in the envt;
337 338
-- ignore others.  (Actually, data constructors are also
-- not LocalVars, even when locally defined, but that is fine.)
339 340
-- (Also foreign-imported things aren't currently in the ZonkEnv;
--  that's ok because they don't need zonking.)
341 342
--
-- Actually, Template Haskell works in 'chunks' of declarations, and
343
-- an earlier chunk won't be in the 'env' that the zonking phase
344
-- carries around.  Instead it'll be in the tcg_gbl_env, already fully
345
-- zonked.  There's no point in looking it up there (except for error
346 347 348 349
-- 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
350
-- 'main' is done as a separate chunk.
351
zonkIdOcc (ZonkEnv { ze_id_env = id_env}) id
352 353
  | isLocalVar id = lookupVarEnv id_env id `orElse`
                    id
354
  | otherwise     = id
355

Ian Lynagh's avatar
Ian Lynagh committed
356
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
357
zonkIdOccs env ids = map (zonkIdOcc env) ids
358

359
-- zonkIdBndr is used *after* typechecking to get the Id's type
360
-- to its final form.  The TyVarEnv give
361
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
362
zonkIdBndr env v
363
  = do ty' <- zonkTcTypeToTypeX env (idType v)
364 365 366 367
       ensureNotLevPoly ty'
         (text "In the type of binder" <+> quotes (ppr v))

       return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty'))
368 369

zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
370
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
371 372

zonkTopBndrs :: [TcId] -> TcM [Id]
373
zonkTopBndrs ids = initZonkEnv zonkIdBndrs ids
374

375
zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc)
376 377 378
zonkFieldOcc env (FieldOcc sel lbl)
  = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel
zonkFieldOcc _ (XFieldOcc _) = panic "zonkFieldOcc"
379

380
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
381
zonkEvBndrsX = mapAccumLM zonkEvBndrX
382 383 384 385 386

zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
-- Works for dictionaries and coercions
zonkEvBndrX env var
  = do { var' <- zonkEvBndr env var
387
       ; return (extendZonkEnv env [var'], var') }
388 389 390 391

zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
-- Works for dictionaries and coercions
-- Does not extend the ZonkEnv
392
zonkEvBndr env var
393
  = do { let var_ty = varType var
394
       ; ty <-
395
           {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
396
           zonkTcTypeToTypeX env var_ty
dreixel's avatar
dreixel committed
397
       ; return (setVarType var ty) }
398

399
{-
400 401 402 403 404 405
zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm
zonkEvVarOcc env v
  | isCoVar v
  = EvCoercion <$> zonkCoVarOcc env v
  | otherwise
  = return (EvId $ zonkIdOcc env v)
406
-}
dreixel's avatar
dreixel committed
407

408 409 410 411 412 413 414 415 416
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

417 418 419
zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrs = initZonkEnv zonkTyBndrsX

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
423
zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
424 425
-- 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
426
zonkTyBndrX env tv
Tobias Dammers's avatar
Tobias Dammers committed
427
  = ASSERT2( isImmutableTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) )
428
    do { ki <- zonkTcTypeToTypeX env (tyVarKind tv)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
429
               -- Internal names tidy up better, for iface files.
430 431
       ; let tv' = mkTyVar (tyVarName tv) ki
       ; return (extendTyZonkEnv1 env tv', tv') }
432

Ningning Xie's avatar
Ningning Xie committed
433 434
zonkTyVarBinders ::  [VarBndr TcTyVar vis]
                 -> TcM (ZonkEnv, [VarBndr TyVar vis])
435 436
zonkTyVarBinders = initZonkEnv zonkTyVarBindersX

Ningning Xie's avatar
Ningning Xie committed
437 438
zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis]
                             -> TcM (ZonkEnv, [VarBndr TyVar vis])
Simon Peyton Jones's avatar
Simon Peyton Jones committed
439
zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX
440

Ningning Xie's avatar
Ningning Xie committed
441 442
zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis
                            -> TcM (ZonkEnv, VarBndr TyVar vis)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
443
-- Takes a TcTyVar and guarantees to return a TyVar
Ningning Xie's avatar
Ningning Xie committed
444
zonkTyVarBinderX env (Bndr tv vis)
445
  = do { (env', tv') <- zonkTyBndrX env tv
Ningning Xie's avatar
Ningning Xie committed
446
       ; return (env', Bndr tv' vis) }
447

448
zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc)
449
zonkTopExpr e = initZonkEnv zonkExpr e
450

451
zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)
452
zonkTopLExpr e = initZonkEnv zonkLExpr e
453

454
zonkTopDecls :: Bag EvBind
455
             -> LHsBinds GhcTcId
456
             -> [LRuleDecl GhcTcId] -> [LTcSpecPrag]
457
             -> [LForeignDecl GhcTcId]
niteria's avatar
niteria committed
458
             -> TcM (TypeEnv,
459
                     Bag EvBind,
460 461
                     LHsBinds GhcTc,
                     [LForeignDecl GhcTc],
462
                     [LTcSpecPrag],
463 464
                     [LRuleDecl    GhcTc])
zonkTopDecls ev_binds binds rules imp_specs fords
465 466
  = do  { (env1, ev_binds') <- initZonkEnv zonkEvBinds ev_binds
        ; (env2, binds')    <- zonkRecMonoBinds env1 binds
467 468
                        -- Top level is implicitly recursive
        ; rules' <- zonkRules env2 rules
469
        ; specs' <- zonkLTcSpecPrags env2 imp_specs
470
        ; fords' <- zonkForeignExports env2 fords
471
        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }
472 473

---------------------------------------------
474 475
zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId
               -> TcM (ZonkEnv, HsLocalBinds GhcTc)
476 477
zonkLocalBinds env (EmptyLocalBinds x)
  = return (env, (EmptyLocalBinds x))
478

479
zonkLocalBinds _ (HsValBinds _ (ValBinds {}))
480 481
  = panic "zonkLocalBinds" -- Not in typechecker output

482
zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs)))
483
  = do  { (env1, new_binds) <- go env binds
484
        ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) }
485
  where
486
    go env []
487
      = return (env, [])
488 489 490
    go env ((r,b):bs)
      = do { (env1, b')  <- zonkRecMonoBinds env b
           ; (env2, bs') <- go env1 bs
491
           ; return (env2, (r,b'):bs') }
492

493
zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
494
    new_binds <- mapM (wrapLocM zonk_ip_bind) binds
495
    let
496 497
        env1 = extendIdZonkEnvRec env
                 [ n | (dL->L _ (IPBind _ (Right n) _)) <- new_binds]
ian@well-typed.com's avatar
ian@well-typed.com committed
498
    (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
499
    return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds))
500
  where
501
    zonk_ip_bind (IPBind x n e)
ian@well-typed.com's avatar
ian@well-typed.com committed
502 503
        = do n' <- mapIPNameTc (zonkIdBndr env) n
             e' <- zonkLExpr env e
504
             return (IPBind x n' e')
505
    zonk_ip_bind (XIPBind _) = panic "zonkLocalBinds : XCIPBind"
506 507 508 509 510

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

512
---------------------------------------------
513
zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc)
514
zonkRecMonoBinds env binds
515
 = fixM (\ ~(_, new_binds) -> do
516
        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)
517
        ; binds' <- zonkMonoBinds env1 binds
518 519
        ; return (env1, binds') })

520
---------------------------------------------
521
zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc)
522
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
cactus's avatar
cactus committed
523

524
zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc)
525
zonk_lbind env = wrapLocM (zonk_bind env)
526

527
zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc)
528 529
zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss
                            , pat_ext = NPatBindTc fvs ty})
530 531
  = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
        ; new_grhss <- zonkGRHSs env zonkLExpr grhss
532
        ; new_ty    <- zonkTcTypeToTypeX env ty
533 534
        ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss
                       , pat_ext = NPatBindTc fvs new_ty }) }
535

536 537
zonk_bind env (VarBind { var_ext = x
                       , var_id = var, var_rhs = expr, var_inline = inl })
538 539
  = do { new_var  <- zonkIdBndr env var
       ; new_expr <- zonkLExpr env expr
540 541 542 543
       ; return (VarBind { var_ext = x
                         , var_id = new_var
                         , var_rhs = new_expr
                         , var_inline = inl }) }
544

545 546
zonk_bind env bind@(FunBind { fun_id = (dL->L loc var)
                            , fun_matches = ms
547
                            , fun_co_fn = co_fn })
548 549
  = do { new_var <- zonkIdBndr env var
       ; (env1, new_co_fn) <- zonkCoFn env co_fn
550
       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
551 552
       ; return (bind { fun_id = cL loc new_var
                      , fun_matches = new_ms
553 554
                      , fun_co_fn = new_co_fn }) }

555 556 557
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                        , abs_ev_binds = ev_binds
                        , abs_exports = exports
558 559
                        , abs_binds = val_binds
                        , abs_sig = has_sig })
560
  = ASSERT( all isImmutableTyVar tyvars )
dreixel's avatar
dreixel committed
561 562
    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
563
       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
564
       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
565 566 567 568
         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
569
            ; return (new_val_binds, new_exports) }
570 571
       ; return (AbsBinds { abs_ext = noExt
                          , abs_tvs = new_tyvars, abs_ev_vars = new_evs
dreixel's avatar
dreixel committed
572
                          , abs_ev_binds = new_ev_binds
573 574
                          , abs_exports = new_exports, abs_binds = new_val_bind
                          , abs_sig = has_sig }) }
sof's avatar
sof committed
575
  where
576 577
    zonk_val_bind env lbind
      | has_sig
578 579 580
      , (dL->L loc bind@(FunBind { fun_id      = (dL->L mloc mono_id)
                                 , fun_matches = ms
                                 , fun_co_fn   = co_fn })) <- lbind
581
      = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id
582 583 584 585
                            -- 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
586 587
           ; return $ cL loc $
             bind { fun_id      = cL mloc new_mono_id
588 589 590 591 592
                  , fun_matches = new_ms
                  , fun_co_fn   = new_co_fn } }
      | otherwise
      = zonk_lbind env lbind   -- The normal case

593 594
    zonk_export env (ABE{ abe_ext = x
                        , abe_wrap = wrap
595 596 597
                        , abe_poly = poly_id
                        , abe_mono = mono_id
                        , abe_prags = prags })
ian@well-typed.com's avatar
ian@well-typed.com committed
598 599 600
        = do new_poly_id <- zonkIdBndr env poly_id
             (_, new_wrap) <- zonkCoFn env wrap
             new_prags <- zonkSpecPrags env prags
601 602
             return (ABE{ abe_ext = x
                        , abe_wrap = new_wrap
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
603
                        , abe_poly = new_poly_id
ian@well-typed.com's avatar
ian@well-typed.com committed
604 605
                        , abe_mono = zonkIdOcc env mono_id
                        , abe_prags = new_prags })
606
    zonk_export _ (XABExport _) = panic "zonk_bind: XABExport"
607

608
zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id)
609 610 611
                                      , psb_args = details
                                      , psb_def = lpat
                                      , psb_dir = dir }))
cactus's avatar
cactus committed
612
  = do { id' <- zonkIdBndr env id
613
       ; (env1, lpat') <- zonkPat env lpat
614
       ; let details' = zonkPatSynDetails env1 details
cactus's avatar
cactus committed
615
       ; (_env2, dir') <- zonkPatSynDir env1 dir
616
       ; return $ PatSynBind x $
617
                  bind { psb_id = cL loc id'
618 619 620
                       , psb_args = details'
                       , psb_def = lpat'
                       , psb_dir = dir' } }
cactus's avatar
cactus committed
621

622 623 624
zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind"
zonk_bind _ (XHsBindsLR _)                 = panic "zonk_bind"

cactus's avatar
cactus committed
625 626
zonkPatSynDetails :: ZonkEnv
                  -> HsPatSynDetails (Located TcId)
627 628 629 630 631 632 633
                  -> 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
634

635 636
zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId
              -> TcM (ZonkEnv, HsPatSynDir GhcTc)
637
zonkPatSynDir env Unidirectional        = return (env, Unidirectional)
cactus's avatar
cactus committed
638
zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
639 640 641
zonkPatSynDir env (ExplicitBidirectional mg) = do
    mg' <- zonkMatchGroup env zonkLExpr mg
    return (env, ExplicitBidirectional mg')
cactus's avatar
cactus committed
642

643 644
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
645
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
646
                                       ; return (SpecPrags ps') }
647 648 649 650

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
651
  where
652
    zonk_prag (dL->L loc (SpecPrag id co_fn inl))
653
        = do { (_, co_fn') <- zonkCoFn env co_fn
654
             ; return (cL loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
655

Austin Seipp's avatar
Austin Seipp committed
656 657 658
{-
************************************************************************
*                                                                      *
659
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
660 661 662
*                                                                      *
************************************************************************
-}
663

664
zonkMatchGroup :: ZonkEnv
665 666 667
            -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
            -> MatchGroup GhcTcId (Located (body GhcTcId))
            -> TcM (MatchGroup GhcTc (Located (body GhcTc)))
668
zonkMatchGroup env zBody (MG { mg_alts = (dL->L l ms)
669 670
                             , mg_ext = MatchGroupTc arg_tys res_ty
                             , mg_origin = origin })
671
  = do  { ms' <- mapM (zonkMatch env zBody) ms
672 673
        ; arg_tys' <- zonkTcTypesToTypesX env arg_tys
        ; res_ty'  <- zonkTcTypeToTypeX env res_ty
674
        ; return (MG { mg_alts = cL l ms'
675 676 677
                     , mg_ext = MatchGroupTc arg_tys' res_ty'
                     , mg_origin = origin }) }
zonkMatchGroup _ _ (XMatchGroup {}) = panic "zonkMatchGroup"
678

679
zonkMatch :: ZonkEnv
680 681 682
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> LMatch GhcTcId (Located (body GhcTcId))
          -> TcM (LMatch GhcTc (Located (body GhcTc)))
683 684
zonkMatch env zBody (dL->L loc match@(Match { m_pats = pats
                                            , m_grhss = grhss }))
685 686
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
687 688 689 690
        ; return (cL loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
zonkMatch _ _ (dL->L  _ (XMatch _)) = panic "zonkMatch"
zonkMatch _ _ _ = panic "zonkMatch: Impossible Match"
                             -- due to #15884
691

692
-------------------------------------------------------------------------
693
zonkGRHSs :: ZonkEnv
694 695 696
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> GRHSs GhcTcId (Located (body GhcTcId))
          -> TcM (GRHSs GhcTc (Located (body GhcTc)))
697

698
zonkGRHSs env zBody (GRHSs x grhss (dL->L l binds)) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
699
    (new_env, new_binds) <- zonkLocalBinds env binds
700
    let
701
        zonk_grhs (GRHS xx guarded rhs)
ian@well-typed.com's avatar
ian@well-typed.com committed
702 703
          = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
               new_rhs <- zBody env2 rhs
704 705
               return (GRHS xx new_guarded new_rhs)
        zonk_grhs (XGRHS _) = panic "zonkGRHSs"
ian@well-typed.com's avatar
ian@well-typed.com committed
706
    new_grhss <- mapM (wrapLocM zonk_grhs) grhss
707
    return (GRHSs x new_grhss (cL l new_binds))
708
zonkGRHSs _ _ (XGRHSs _) = panic "zonkGRHSs"
709

Austin Seipp's avatar
Austin Seipp committed
710 711 712
{-
************************************************************************
*                                                                      *
713
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
714 715 716
*                                                                      *
************************************************************************
-}
717

718 719 720
zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc]
zonkLExpr  :: ZonkEnv -> LHsExpr GhcTcId   -> TcM (LHsExpr GhcTc)
zonkExpr   :: ZonkEnv -> HsExpr GhcTcId    -> TcM (HsExpr GhcTc)
721

722
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
723
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
724

725
zonkExpr env (HsVar x (dL->L l id))
Ben Gamari's avatar
Ben Gamari committed
726
  = ASSERT2( isNothing (isDataConId_maybe id), ppr id )
727
    return (HsVar x (cL l (zonkIdOcc env id)))
728 729

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

731 732
zonkExpr _ (HsIPVar x id)
  = return (HsIPVar x id)
733

734
zonkExpr _ e@HsOverLabel{} = return e
Adam Gundry's avatar
Adam Gundry committed
735

736
zonkExpr env (HsLit x (HsRat e f ty))
737
  = do new_ty <- zonkTcTypeToTypeX env ty
738
       return (HsLit x (HsRat e f new_ty))
sof's avatar
sof committed
739

740 741
zonkExpr _ (HsLit x lit)
  = return (HsLit x lit)
742

743
zonkExpr env (HsOverLit x lit)
744
  = do  { lit' <- zonkOverLit env lit
745
        ; return (HsOverLit x lit') }
746

747
zonkExpr env (HsLam x matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
748
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
749
       return (HsLam x new_matches)
750

751
zonkExpr env (HsLamCase x matches)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
752
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
753
       return (HsLamCase x new_matches)
754

755
zonkExpr env (HsApp x e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
756 757
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
758
       return (HsApp x new_e1 new_e2)
759

760
zonkExpr env (HsAppType x e t)
761
  = do new_e <- zonkLExpr env e
762
       return (HsAppType x new_e t)
763 764
       -- NB: the type is an HsType; can't zonk that!

765
zonkExpr _ e@(HsRnBracketOut _ _ _)
gmainland's avatar
gmainland committed
766 767
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

768
zonkExpr env (HsTcBracketOut x body bs)
ian@well-typed.com's avatar
ian@well-typed.com committed
769
  = do bs' <- mapM zonk_b bs
770
       return (HsTcBracketOut x body bs')
771
  where
772 773
    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
                                      return (PendingTcSplice n e')
gmainland's avatar
gmainland committed
774

775 776
zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE x s)
777

778
zonkExpr env (OpApp fixity e1 op e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
779 780 781
  = do new_e1 <- zonkLExpr env e1
       new_op <- zonkLExpr env op
       new_e2 <- zonkLExpr env e2
782
       return (OpApp fixity new_e1 new_op new_e2)
783

784
zonkExpr env (NegApp x expr op)
785 786
  = do (env', new_op) <- zonkSyntaxExpr env op
       new_expr <- zonkLExpr env' expr
787
       return (NegApp x new_expr new_op)
788

789
zonkExpr env (HsPar x e)
ian@well-typed.com's avatar
ian@well-typed.com committed
790
  = do new_e <- zonkLExpr env e
791
       return (HsPar x new_e)
792

793
zonkExpr env (SectionL x expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
794 795
  = do new_expr <- zonkLExpr env expr
       new_op   <- zonkLExpr env op
796
       return (SectionL x new_expr new_op)
797

798
zonkExpr env (SectionR x op expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
799 800
  = do new_op   <- zonkLExpr env op
       new_expr <- zonkLExpr env expr
801
       return (SectionR x new_op new_expr)
802

803
zonkExpr env (ExplicitTuple x tup_args boxed)
804
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
805
       ; return (ExplicitTuple x new_tup_args boxed) }
806
  where
807 808 809 810 811 812 813 814
    zonk_tup_arg (dL->L l (Present x e)) = do { e' <- zonkLExpr env e
                                              ; return (cL l (Present x e')) }
    zonk_tup_arg (dL->L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t
                                            ; return (cL l (Missing t')) }
    zonk_tup_arg (dL->L _ (XTupArg{})) = panic "zonkExpr.XTupArg"
    zonk_tup_arg _ = panic "zonk_tup_arg: Impossible Match"
                             -- due to #15884

815

816
zonkExpr env (ExplicitSum args alt arity expr)
817
  = do new_args <- mapM (zonkTcTypeToTypeX env) args
818
       new_expr <- zonkLExpr env expr
819
       return (ExplicitSum new_args alt arity new_expr)
820

821
zonkExpr env (HsCase x expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
822 823
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLExpr ms
824
       return (HsCase x new_expr new_ms)
825

826
zonkExpr env (HsIf x Nothing e1 e2 e3)
827 828 829
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       new_e3 <- zonkLExpr env e3
830
       return (HsIf x Nothing new_e1 new_e2 new_e3)
831

832
zonkExpr env (HsIf x (Just fun) e1 e2 e3)
833 834 835 836
  = do (env1, new_fun) <- zonkSyntaxExpr env fun
       new_e1 <- zonkLExpr env1 e1
       new_e2 <- zonkLExpr env1 e2
       new_e3 <- zonkLExpr env1 e3
837
       return (HsIf x (Just new_fun) new_e1 new_e2 new_e3)
838

839 840
zonkExpr env (HsMultiIf ty alts)
  = do { alts' <- mapM (wrapLocM zonk_alt) alts
841
       ; ty'   <- zonkTcTypeToTypeX env ty
842
       ; return $ HsMultiIf ty' alts' }