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

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 34 35 36 37 38 39
        zonkTopBndrs,
        ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv,
        zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX,
        zonkTyBndrs, zonkTyBndrsX,
        zonkTcTypeToType,  zonkTcTypeToTypeX,
        zonkTcTypesToTypes, zonkTcTypesToTypesX,
        zonkTyVarOcc,
40 41
        zonkCoToCo,
        zonkEvBinds, zonkTcEvBinds,
42
        zonkTcMethInfoToMethInfoX
43 44
  ) where

45
#include "HsVersions.h"
46

47 48
import GhcPrelude

49
import HsSyn
50
import Id
51
import IdInfo
52
import TcRnMonad
53
import PrelNames
54
import BuildTyCl ( TcMethInfo, MethInfo )
55
import TcType
56
import TcMType
57
import TcEnv   ( tcLookupGlobalOnly )
58
import TcEvidence
59
import TysPrim
60
import TyCon
61
import TysWiredIn
Simon Peyton Jones's avatar
Simon Peyton Jones committed
62
import TyCoRep( CoercionHole(..) )
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 98
hsLPatType (L _ pat) = hsPatType pat

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


230 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
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.
-}
268

269 270 271 272 273
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
274

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

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

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

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

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

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

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

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

331 332 333
zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id
zonkLIdOcc env (L loc id) = L loc (zonkIdOcc env id)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

432 433 434 435
zonkTyVarBinders ::  [TyVarBndr TcTyVar vis]
                 -> TcM (ZonkEnv, [TyVarBndr TyVar vis])
zonkTyVarBinders = initZonkEnv zonkTyVarBindersX

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

552 553 554
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                        , abs_ev_binds = ev_binds
                        , abs_exports = exports
555 556
                        , abs_binds = val_binds
                        , abs_sig = has_sig })
557
  = ASSERT( all isImmutableTyVar tyvars )
dreixel's avatar
dreixel committed
558 559
    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
560
       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
561
       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
562 563 564 565
         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
566
            ; return (new_val_binds, new_exports) }
567 568
       ; return (AbsBinds { abs_ext = noExt
                          , abs_tvs = new_tyvars, abs_ev_vars = new_evs
dreixel's avatar
dreixel committed
569
                          , abs_ev_binds = new_ev_binds
570 571
                          , abs_exports = new_exports, abs_binds = new_val_bind
                          , abs_sig = has_sig }) }
sof's avatar
sof committed
572
  where
573 574 575 576 577
    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
578
      = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id
579 580 581 582 583 584 585 586 587 588 589
                            -- 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

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

605 606 607 608
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
609
  = do { id' <- zonkIdBndr env id
610
       ; (env1, lpat') <- zonkPat env lpat
611
       ; let details' = zonkPatSynDetails env1 details
cactus's avatar
cactus committed
612
       ; (_env2, dir') <- zonkPatSynDir env1 dir
613
       ; return $ PatSynBind x $
614 615 616 617
                  bind { psb_id = L loc id'
                       , psb_args = details'
                       , psb_def = lpat'
                       , psb_dir = dir' } }
cactus's avatar
cactus committed
618

619 620 621
zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind"
zonk_bind _ (XHsBindsLR _)                 = panic "zonk_bind"

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

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

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

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

Austin Seipp's avatar
Austin Seipp committed
653 654 655
{-
************************************************************************
*                                                                      *
656
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
657 658 659
*                                                                      *
************************************************************************
-}
660

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

676
zonkMatch :: ZonkEnv
677 678 679
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> LMatch GhcTcId (Located (body GhcTcId))
          -> TcM (LMatch GhcTc (Located (body GhcTc)))
680
zonkMatch env zBody (L loc match@(Match { m_pats = pats, m_grhss = grhss }))
681 682
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
683
        ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
684
zonkMatch _ _ (L  _ (XMatch _)) = panic "zonkMatch"
685

686
-------------------------------------------------------------------------
687
zonkGRHSs :: ZonkEnv
688 689 690
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> GRHSs GhcTcId (Located (body GhcTcId))
          -> TcM (GRHSs GhcTc (Located (body GhcTc)))
691

692
zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
693
    (new_env, new_binds) <- zonkLocalBinds env binds
694
    let
695
        zonk_grhs (GRHS xx guarded rhs)
ian@well-typed.com's avatar
ian@well-typed.com committed
696 697
          = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
               new_rhs <- zBody env2 rhs
698 699
               return (GRHS xx new_guarded new_rhs)
        zonk_grhs (XGRHS _) = panic "zonkGRHSs"
ian@well-typed.com's avatar
ian@well-typed.com committed
700
    new_grhss <- mapM (wrapLocM zonk_grhs) grhss
701 702
    return (GRHSs x new_grhss (L l new_binds))
zonkGRHSs _ _ (XGRHSs _) = panic "zonkGRHSs"
703

Austin Seipp's avatar
Austin Seipp committed
704 705 706
{-
************************************************************************
*                                                                      *
707
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
708 709 710
*                                                                      *
************************************************************************
-}
711

712 713 714
zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc]
zonkLExpr  :: ZonkEnv -> LHsExpr GhcTcId   -> TcM (LHsExpr GhcTc)
zonkExpr   :: ZonkEnv -> HsExpr GhcTcId    -> TcM (HsExpr GhcTc)
715

716
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
717
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
718

719
zonkExpr env (HsVar x (L l id))
Ben Gamari's avatar
Ben Gamari committed
720
  = ASSERT2( isNothing (isDataConId_maybe id), ppr id )
721
    return (HsVar x (L l (zonkIdOcc env id)))
722 723

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

725 726
zonkExpr _ (HsIPVar x id)
  = return (HsIPVar x id)
727

728
zonkExpr _ e@HsOverLabel{} = return e
Adam Gundry's avatar
Adam Gundry committed
729

730
zonkExpr env (HsLit x (HsRat e f ty))
731
  = do new_ty <- zonkTcTypeToTypeX env ty
732
       return (HsLit x (HsRat e f new_ty))
sof's avatar
sof committed
733

734 735
zonkExpr _ (HsLit x lit)
  = return (HsLit x lit)
736

737
zonkExpr env (HsOverLit x lit)
738
  = do  { lit' <- zonkOverLit env lit
739
        ; return (HsOverLit x lit') }
740

741
zonkExpr env (HsLam x matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
742
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
743
       return (HsLam x new_matches)
744

745
zonkExpr env (HsLamCase x matches)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
746
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
747
       return (HsLamCase x new_matches)
748

749
zonkExpr env (HsApp x e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
750 751
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
752
       return (HsApp x new_e1 new_e2)
753

754
zonkExpr env (HsAppType t e)
755
  = do new_e <- zonkLExpr env e
756
       return (HsAppType t new_e)
757 758
       -- NB: the type is an HsType; can't zonk that!

759
zonkExpr _ e@(HsRnBracketOut _ _ _)
gmainland's avatar
gmainland committed
760 761
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

762
zonkExpr env (HsTcBracketOut x body bs)
ian@well-typed.com's avatar
ian@well-typed.com committed
763
  = do bs' <- mapM zonk_b bs
764
       return (HsTcBracketOut x body bs')
765
  where
766 767
    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
                                      return (PendingTcSplice n e')
gmainland's avatar
gmainland committed
768

769 770
zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE x s)
771

772
zonkExpr env (OpApp fixity e1 op e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
773 774 775
  = do new_e1 <- zonkLExpr env e1
       new_op <- zonkLExpr env op
       new_e2 <- zonkLExpr env e2
776
       return (OpApp fixity new_e1 new_op new_e2)
777

778
zonkExpr env (NegApp x expr op)
779 780
  = do (env', new_op) <- zonkSyntaxExpr env op
       new_expr <- zonkLExpr env' expr
781
       return (NegApp x new_expr new_op)
782

783
zonkExpr env (HsPar x e)
ian@well-typed.com's avatar
ian@well-typed.com committed
784
  = do new_e <- zonkLExpr env e
785
       return (HsPar x new_e)
786

787
zonkExpr env (SectionL x expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
788 789
  = do new_expr <- zonkLExpr env expr
       new_op   <- zonkLExpr env op
790
       return (SectionL x new_expr new_op)
791

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

797
zonkExpr env (ExplicitTuple x tup_args boxed)
798
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
799
       ; return (ExplicitTuple x new_tup_args boxed) }
800
  where
801 802
    zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e
                                          ; return (L l (Present x e')) }
803
    zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t
804
                                        ; return (L l (Missing t')) }
805
    zonk_tup_arg (L _ (XTupArg{})) = panic "zonkExpr.XTupArg"
806

807
zonkExpr env (ExplicitSum args alt arity expr)
808
  = do new_args <- mapM (zonkTcTypeToTypeX env) args
809
       new_expr <- zonkLExpr env expr
810
       return (ExplicitSum new_args alt arity new_expr)
811

812
zonkExpr env (HsCase x expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
813 814
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLExpr ms
815
       return (HsCase x new_expr new_ms)
816

817
zonkExpr env (HsIf x Nothing e1 e2 e3)
818 819 820
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       new_e3 <- zonkLExpr env e3
821
       return (HsIf x Nothing new_e1 new_e2 new_e3)
822

823
zonkExpr env (HsIf x (Just fun) e1 e2 e3)
824 825 826 827
  = do (env1, new_fun) <- zonkSyntaxExpr env fun
       new_e1 <- zonkLExpr env1 e1
       new_e2 <- zonkLExpr env1 e2
       new_e3 <- zonkLExpr env1 e3
828
       return (HsIf x (Just new_fun) new_e1 new_e2 new_e3)
829

830 831
zonkExpr env (HsMultiIf ty alts)
  = do { alts' <- mapM (wrapLocM zonk_alt) alts
832
       ; ty'   <- zonkTcTypeToTypeX env ty
833
       ; return $ HsMultiIf ty' alts' }
834
  where zonk_alt (GRHS x guard expr)
835
          = do { (env', guard') <- zonkStmts env zonkLExpr guard
836
               ; expr'          <- zonkLExpr env' expr
837 838
               ; return $ GRHS x guard' expr' }
        zonk_alt (XGRHS _) = panic "zonkExpr.HsMultiIf"
839

840
zonkExpr env (HsLet x (L l binds) expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
841 842
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_expr <- zonkLExpr new_env expr
843
       return (HsLet x (L l new_binds) new_expr)
844

845
zonkExpr env (HsDo ty do_or_lc (L l stmts))
ian@well-typed.com's avatar
ian@well-typed.com committed
846
  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
847
       new_ty <- zonkTcTypeToTypeX env ty
848
       return (HsDo new_ty do_or_lc (L l new_stmts))
849

850
zonkExpr env (ExplicitList ty wit exprs)