TcHsSyn.hs 75.6 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
dreixel's avatar
dreixel committed
62
import Type
63
import Coercion
64
import ConLike
65
import DataCon
niteria's avatar
niteria committed
66
import HscTypes
67
import Name
niteria's avatar
niteria committed
68
import NameEnv
69
import Var
70
import VarEnv
71
import DynFlags
72
import Literal
73 74 75
import BasicTypes
import Maybes
import SrcLoc
sof's avatar
sof committed
76
import Bag
sof's avatar
sof committed
77
import Outputable
78
import Util
79
import UniqFM
80
import CoreSyn
81

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

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

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

95
hsLPatType :: OutPat GhcTc -> Type
96 97
hsLPatType (L _ pat) = hsPatType pat

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


229 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
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.
-}
267

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

844
zonkExpr env (HsDo ty do_or_lc (L l stmts))
ian@well-typed.com's avatar
ian@well-typed.com committed
845
  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts