TcHsSyn.hs 76.8 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1996-1998

5 6

TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker
7 8 9

This module is an extension of @HsSyn@ syntax, for use in the type
checker.
Austin Seipp's avatar
Austin Seipp committed
10
-}
11

12
{-# LANGUAGE CPP, TupleSections #-}
13 14
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
15
{-# 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 44
        zonkTcMethInfoToMethInfoX,
        lookupTyVarOcc
45 46
  ) where

47
#include "HsVersions.h"
48

49 50
import GhcPrelude

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | See Note [The ZonkEnv]
199
-- Confused by zonking? See Note [What is zonking?] in TcMType.
200 201 202
data ZonkEnv  -- See Note [The ZonkEnv]
  = ZonkEnv { ze_flexi  :: ZonkFlexi
            , ze_tv_env :: TyCoVarEnv TyCoVar
203 204
            , ze_id_env :: IdEnv      Id
            , ze_meta_tv_env :: TcRef (TyVarEnv Type) }
205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228
{- 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.

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


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 269
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.
-}
270

271 272 273 274 275
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
276

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

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

284 285 286 287 288 289 290 291 292 293 294
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 }
295

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

680
zonkMatch :: ZonkEnv
681 682 683
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> LMatch GhcTcId (Located (body GhcTcId))
          -> TcM (LMatch GhcTc (Located (body GhcTc)))
684 685
zonkMatch env zBody (dL->L loc match@(Match { m_pats = pats
                                            , m_grhss = grhss }))
686 687
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
688 689 690 691
        ; 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
692

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

804
zonkExpr env (ExplicitTuple x tup_args boxed)
805
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
806
       ; return (ExplicitTuple x new_tup_args boxed) }
807
  where
808 809 810 811 812 813 814 815
    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

816

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

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

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

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

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