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

5 6

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

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

12
{-# LANGUAGE CPP, TupleSections #-}
13 14
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
15

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

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

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

29 30 31
        -- * Zonking
        -- | For a description of "zonking", see Note [What is zonking?]
        -- in TcMType
32
        zonkTopDecls, zonkTopExpr, zonkTopLExpr,
33
        zonkTopBndrs, zonkTyBndrsX,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
34
        zonkTyVarBindersX, zonkTyVarBinderX,
35
        ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv,
36
        zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
37 38 39
        zonkCoToCo,
        zonkEvBinds, zonkTcEvBinds,
        zonkTcMethInfoToMethInfo
40 41
  ) where

42
#include "HsVersions.h"
43

44 45
import GhcPrelude

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

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

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

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

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

96
hsPatType :: Pat GhcTc -> Type
97 98 99 100 101 102 103 104
hsPatType (ParPat _ pat)                = hsLPatType pat
hsPatType (WildPat ty)                  = ty
hsPatType (VarPat _ (L _ var))          = idType var
hsPatType (BangPat _ pat)               = hsLPatType pat
hsPatType (LazyPat _ pat)               = hsLPatType pat
hsPatType (LitPat _ lit)                = hsLitType lit
hsPatType (AsPat _ var _)               = idType (unLoc var)
hsPatType (ViewPat ty _ _)              = ty
105 106
hsPatType (ListPat (ListPatTc ty Nothing) _)      = mkListTy ty
hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty
107 108
hsPatType (TuplePat tys _ bx)           = mkTupleTy bx tys
hsPatType (SumPat tys _ _ _ )           = mkSumTy tys
109
hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys })
110 111 112 113 114 115 116 117
                                        = conLikeResTy con tys
hsPatType (SigPat ty _)                 = ty
hsPatType (NPat ty _ _ _)               = ty
hsPatType (NPlusKPat ty _ _ _ _ _)      = ty
hsPatType (CoPat _ _ _ ty)              = ty
hsPatType p                             = pprPanic "hsPatType" (ppr p)

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

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

135
shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId)
136
shortCutLit dflags (HsIntegral int@(IL src neg i)) ty
137
  | isIntTy ty  && inIntRange  dflags i = Just (HsLit noExt (HsInt noExt int))
138
  | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i))
139
  | isIntegerTy ty = Just (HsLit noExt (HsInteger src i ty))
140
  | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty
141 142 143 144 145
        -- The 'otherwise' case is important
        -- Consider (3 :: Float).  Syntactically it looks like an IntLit,
        -- so we'll call shortCutIntLit, but of course it's a float
        -- This can make a big difference for programs with a lot of
        -- literals, compiled without -O
146

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

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

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

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

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

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

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

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

183 184 185
The Ids are converted by binding them in the normal Tc envt; that
way we maintain sharing; eg an Id is zonked at its binding site and they
all occurrences of that Id point to the common zonked copy
sof's avatar
sof committed
186

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

191
-- Confused by zonking? See Note [What is zonking?] in TcMType.
192 193

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

{- 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.

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.
-}
262

263 264 265 266 267
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
268

269 270
instance Outputable ZonkEnv where
  ppr (ZonkEnv { ze_id_env =  var_env}) = pprUFM var_env (vcat . map ppr)
271

272
-- The EvBinds have to already be zonked, but that's usually the case.
Ian Lynagh's avatar
Ian Lynagh committed
273
emptyZonkEnv :: ZonkEnv
274
emptyZonkEnv = mkEmptyZonkEnv DefaultFlexi
275

276 277 278 279
mkEmptyZonkEnv :: ZonkFlexi -> ZonkEnv
mkEmptyZonkEnv flexi = ZonkEnv { ze_flexi = flexi
                               , ze_tv_env = emptyVarEnv
                               , ze_id_env = emptyVarEnv }
280

281 282
-- | Extend the knot-tied environment.
extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv
283
extendIdZonkEnvRec ze@(ZonkEnv { ze_id_env = id_env }) ids
284 285
    -- 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.
286
  = ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] }
287 288 289 290 291 292 293 294
  -- 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
295 296 297 298 299
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
300

dreixel's avatar
dreixel committed
301
extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
302 303
extendIdZonkEnv1 ze@(ZonkEnv { ze_id_env = id_env }) id
  = ze { ze_id_env = extendVarEnv id_env id id }
304

dreixel's avatar
dreixel committed
305
extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
306 307
extendTyZonkEnv1 ze@(ZonkEnv { ze_tv_env = ty_env }) tv
  = ze { ze_tv_env = extendVarEnv ty_env tv tv }
dreixel's avatar
dreixel committed
308

309 310
setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv
setZonkType ze flexi = ze { ze_flexi = flexi }
311

niteria's avatar
niteria committed
312
zonkEnvIds :: ZonkEnv -> TypeEnv
313 314
zonkEnvIds (ZonkEnv { ze_id_env = id_env})
  = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env]
niteria's avatar
niteria committed
315 316
  -- It's OK to use nonDetEltsUFM here because we forget the ordering
  -- immediately by creating a TypeEnv
317

318 319 320
zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id
zonkLIdOcc env (L loc id) = L loc (zonkIdOcc env id)

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

Ian Lynagh's avatar
Ian Lynagh committed
342
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
343
zonkIdOccs env ids = map (zonkIdOcc env) ids
344

345
-- zonkIdBndr is used *after* typechecking to get the Id's type
346
-- to its final form.  The TyVarEnv give
347
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
348 349 350 351 352 353
zonkIdBndr env v
  = do ty' <- zonkTcTypeToType env (idType v)
       ensureNotLevPoly ty'
         (text "In the type of binder" <+> quotes (ppr v))

       return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty'))
354 355

zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
356
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
357 358 359

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

361
zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc)
362 363 364
zonkFieldOcc env (FieldOcc sel lbl)
  = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel
zonkFieldOcc _ (XFieldOcc _) = panic "zonkFieldOcc"
365

366
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
367
zonkEvBndrsX = mapAccumLM zonkEvBndrX
368 369 370 371 372

zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
-- Works for dictionaries and coercions
zonkEvBndrX env var
  = do { var' <- zonkEvBndr env var
373
       ; return (extendZonkEnv env [var'], var') }
374 375 376 377

zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
-- Works for dictionaries and coercions
-- Does not extend the ZonkEnv
378
zonkEvBndr env var
379
  = do { let var_ty = varType var
380
       ; ty <-
381 382
           {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
           zonkTcTypeToType env var_ty
dreixel's avatar
dreixel committed
383
       ; return (setVarType var ty) }
384

385
{-
386 387 388 389 390 391
zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm
zonkEvVarOcc env v
  | isCoVar v
  = EvCoercion <$> zonkCoVarOcc env v
  | otherwise
  = return (EvId $ zonkIdOcc env v)
392
-}
dreixel's avatar
dreixel committed
393

394 395 396 397 398 399 400 401 402
zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var)
zonkCoreBndrX env v
  | isId v = do { v' <- zonkIdBndr env v
                ; return (extendIdZonkEnv1 env v', v') }
  | otherwise = zonkTyBndrX env v

zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var])
zonkCoreBndrsX = mapAccumLM zonkCoreBndrX

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
406
zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
407 408
-- 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
409
zonkTyBndrX env tv
410 411
  = ASSERT( isImmutableTyVar tv )
    do { ki <- zonkTcTypeToType env (tyVarKind tv)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
412
               -- Internal names tidy up better, for iface files.
413 414
       ; let tv' = mkTyVar (tyVarName tv) ki
       ; return (extendTyZonkEnv1 env tv', tv') }
415

Simon Peyton Jones's avatar
Simon Peyton Jones committed
416 417 418
zonkTyVarBindersX :: ZonkEnv -> [TyVarBndr TcTyVar vis]
                             -> TcM (ZonkEnv, [TyVarBndr TyVar vis])
zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX
419

Simon Peyton Jones's avatar
Simon Peyton Jones committed
420 421 422 423
zonkTyVarBinderX :: ZonkEnv -> TyVarBndr TcTyVar vis
                            -> TcM (ZonkEnv, TyVarBndr TyVar vis)
-- Takes a TcTyVar and guarantees to return a TyVar
zonkTyVarBinderX env (TvBndr tv vis)
424
  = do { (env', tv') <- zonkTyBndrX env tv
425
       ; return (env', TvBndr tv' vis) }
426

427
zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc)
428 429
zonkTopExpr e = zonkExpr emptyZonkEnv e

430
zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)
431 432
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

433
zonkTopDecls :: Bag EvBind
434
             -> LHsBinds GhcTcId
435
             -> [LRuleDecl GhcTcId] -> [LTcSpecPrag]
436
             -> [LForeignDecl GhcTcId]
niteria's avatar
niteria committed
437
             -> TcM (TypeEnv,
438
                     Bag EvBind,
439 440
                     LHsBinds GhcTc,
                     [LForeignDecl GhcTc],
441
                     [LTcSpecPrag],
442 443
                     [LRuleDecl    GhcTc])
zonkTopDecls ev_binds binds rules imp_specs fords
444
  = do  { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
445
        ; (env2, binds') <- zonkRecMonoBinds env1 binds
446 447
                        -- Top level is implicitly recursive
        ; rules' <- zonkRules env2 rules
448
        ; specs' <- zonkLTcSpecPrags env2 imp_specs
449
        ; fords' <- zonkForeignExports env2 fords
450
        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }
451 452

---------------------------------------------
453 454
zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId
               -> TcM (ZonkEnv, HsLocalBinds GhcTc)
455 456
zonkLocalBinds env (EmptyLocalBinds x)
  = return (env, (EmptyLocalBinds x))
457

458
zonkLocalBinds _ (HsValBinds _ (ValBinds {}))
459 460
  = panic "zonkLocalBinds" -- Not in typechecker output

461
zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs)))
462
  = do  { (env1, new_binds) <- go env binds
463
        ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) }
464
  where
465
    go env []
466
      = return (env, [])
467 468 469
    go env ((r,b):bs)
      = do { (env1, b')  <- zonkRecMonoBinds env b
           ; (env2, bs') <- go env1 bs
470
           ; return (env2, (r,b'):bs') }
471

472
zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
473
    new_binds <- mapM (wrapLocM zonk_ip_bind) binds
474
    let
475 476
        env1 = extendIdZonkEnvRec env [ n
                                      | L _ (IPBind _ (Right n) _) <- new_binds]
ian@well-typed.com's avatar
ian@well-typed.com committed
477
    (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
478
    return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds))
479
  where
480
    zonk_ip_bind (IPBind x n e)
ian@well-typed.com's avatar
ian@well-typed.com committed
481 482
        = do n' <- mapIPNameTc (zonkIdBndr env) n
             e' <- zonkLExpr env e
483
             return (IPBind x n' e')
484
    zonk_ip_bind (XIPBind _) = panic "zonkLocalBinds : XCIPBind"
485 486 487 488 489

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

491
---------------------------------------------
492
zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc)
493
zonkRecMonoBinds env binds
494
 = fixM (\ ~(_, new_binds) -> do
495
        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)
496
        ; binds' <- zonkMonoBinds env1 binds
497 498
        ; return (env1, binds') })

499
---------------------------------------------
500
zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc)
501
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
cactus's avatar
cactus committed
502

503
zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc)
504
zonk_lbind env = wrapLocM (zonk_bind env)
505

506
zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc)
507 508
zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss
                            , pat_ext = NPatBindTc fvs ty})
509 510 511
  = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
        ; new_grhss <- zonkGRHSs env zonkLExpr grhss
        ; new_ty    <- zonkTcTypeToType env ty
512 513
        ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss
                       , pat_ext = NPatBindTc fvs new_ty }) }
514

515 516
zonk_bind env (VarBind { var_ext = x
                       , var_id = var, var_rhs = expr, var_inline = inl })
517 518
  = do { new_var  <- zonkIdBndr env var
       ; new_expr <- zonkLExpr env expr
519 520 521 522
       ; return (VarBind { var_ext = x
                         , var_id = new_var
                         , var_rhs = new_expr
                         , var_inline = inl }) }
523

524 525
zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
                            , fun_co_fn = co_fn })
526 527
  = do { new_var <- zonkIdBndr env var
       ; (env1, new_co_fn) <- zonkCoFn env co_fn
528
       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
529 530 531
       ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
                      , fun_co_fn = new_co_fn }) }

532 533 534
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                        , abs_ev_binds = ev_binds
                        , abs_exports = exports
535 536
                        , abs_binds = val_binds
                        , abs_sig = has_sig })
537
  = ASSERT( all isImmutableTyVar tyvars )
dreixel's avatar
dreixel committed
538 539
    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
540
       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
541
       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
542 543 544 545
         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
546
            ; return (new_val_binds, new_exports) }
547 548
       ; return (AbsBinds { abs_ext = noExt
                          , abs_tvs = new_tyvars, abs_ev_vars = new_evs
dreixel's avatar
dreixel committed
549
                          , abs_ev_binds = new_ev_binds
550 551
                          , abs_exports = new_exports, abs_binds = new_val_bind
                          , abs_sig = has_sig }) }
sof's avatar
sof committed
552
  where
553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569
    zonk_val_bind env lbind
      | has_sig
      , L loc bind@(FunBind { fun_id      = L mloc mono_id
                            , fun_matches = ms
                            , fun_co_fn   = co_fn }) <- lbind
      = do { new_mono_id <- updateVarTypeM (zonkTcTypeToType env) mono_id
                            -- Specifically /not/ zonkIdBndr; we do not
                            -- want to complain about a levity-polymorphic binder
           ; (env', new_co_fn) <- zonkCoFn env co_fn
           ; new_ms            <- zonkMatchGroup env' zonkLExpr ms
           ; return $ L loc $
             bind { fun_id      = L mloc new_mono_id
                  , fun_matches = new_ms
                  , fun_co_fn   = new_co_fn } }
      | otherwise
      = zonk_lbind env lbind   -- The normal case

570 571
    zonk_export env (ABE{ abe_ext = x
                        , abe_wrap = wrap
572 573 574
                        , abe_poly = poly_id
                        , abe_mono = mono_id
                        , abe_prags = prags })
ian@well-typed.com's avatar
ian@well-typed.com committed
575 576 577
        = do new_poly_id <- zonkIdBndr env poly_id
             (_, new_wrap) <- zonkCoFn env wrap
             new_prags <- zonkSpecPrags env prags
578 579
             return (ABE{ abe_ext = x
                        , abe_wrap = new_wrap
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
580
                        , abe_poly = new_poly_id
ian@well-typed.com's avatar
ian@well-typed.com committed
581 582
                        , abe_mono = zonkIdOcc env mono_id
                        , abe_prags = new_prags })
583
    zonk_export _ (XABExport _) = panic "zonk_bind: XABExport"
584

585 586 587 588
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
589
  = do { id' <- zonkIdBndr env id
590
       ; (env1, lpat') <- zonkPat env lpat
591
       ; let details' = zonkPatSynDetails env1 details
cactus's avatar
cactus committed
592
       ; (_env2, dir') <- zonkPatSynDir env1 dir
593
       ; return $ PatSynBind x $
594 595 596 597
                  bind { psb_id = L loc id'
                       , psb_args = details'
                       , psb_def = lpat'
                       , psb_dir = dir' } }
cactus's avatar
cactus committed
598

599 600 601
zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind"
zonk_bind _ (XHsBindsLR _)                 = panic "zonk_bind"

cactus's avatar
cactus committed
602 603
zonkPatSynDetails :: ZonkEnv
                  -> HsPatSynDetails (Located TcId)
604 605 606 607 608 609 610
                  -> 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
611

612 613
zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId
              -> TcM (ZonkEnv, HsPatSynDir GhcTc)
614
zonkPatSynDir env Unidirectional        = return (env, Unidirectional)
cactus's avatar
cactus committed
615
zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
616 617 618
zonkPatSynDir env (ExplicitBidirectional mg) = do
    mg' <- zonkMatchGroup env zonkLExpr mg
    return (env, ExplicitBidirectional mg')
cactus's avatar
cactus committed
619

620 621
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
622
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
623
                                       ; return (SpecPrags ps') }
624 625 626 627

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
628
  where
629
    zonk_prag (L loc (SpecPrag id co_fn inl))
630 631
        = do { (_, co_fn') <- zonkCoFn env co_fn
             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
632

Austin Seipp's avatar
Austin Seipp committed
633 634 635
{-
************************************************************************
*                                                                      *
636
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
637 638 639
*                                                                      *
************************************************************************
-}
640

641
zonkMatchGroup :: ZonkEnv
642 643 644
            -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
            -> MatchGroup GhcTcId (Located (body GhcTcId))
            -> TcM (MatchGroup GhcTc (Located (body GhcTc)))
645 646 647
zonkMatchGroup env zBody (MG { mg_alts = L l ms
                             , mg_ext = MatchGroupTc arg_tys res_ty
                             , mg_origin = origin })
648 649 650
  = do  { ms' <- mapM (zonkMatch env zBody) ms
        ; arg_tys' <- zonkTcTypeToTypes env arg_tys
        ; res_ty'  <- zonkTcTypeToType env res_ty
651 652 653 654
        ; return (MG { mg_alts = L l ms'
                     , mg_ext = MatchGroupTc arg_tys' res_ty'
                     , mg_origin = origin }) }
zonkMatchGroup _ _ (XMatchGroup {}) = panic "zonkMatchGroup"
655

656
zonkMatch :: ZonkEnv
657 658 659
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> LMatch GhcTcId (Located (body GhcTcId))
          -> TcM (LMatch GhcTc (Located (body GhcTc)))
660
zonkMatch env zBody (L loc match@(Match { m_pats = pats, m_grhss = grhss }))
661 662
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
663
        ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
664
zonkMatch _ _ (L  _ (XMatch _)) = panic "zonkMatch"
665

666
-------------------------------------------------------------------------
667
zonkGRHSs :: ZonkEnv
668 669 670
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> GRHSs GhcTcId (Located (body GhcTcId))
          -> TcM (GRHSs GhcTc (Located (body GhcTc)))
671

672
zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
673
    (new_env, new_binds) <- zonkLocalBinds env binds
674
    let
675
        zonk_grhs (GRHS xx guarded rhs)
ian@well-typed.com's avatar
ian@well-typed.com committed
676 677
          = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
               new_rhs <- zBody env2 rhs
678 679
               return (GRHS xx new_guarded new_rhs)
        zonk_grhs (XGRHS _) = panic "zonkGRHSs"
ian@well-typed.com's avatar
ian@well-typed.com committed
680
    new_grhss <- mapM (wrapLocM zonk_grhs) grhss
681 682
    return (GRHSs x new_grhss (L l new_binds))
zonkGRHSs _ _ (XGRHSs _) = panic "zonkGRHSs"
683

Austin Seipp's avatar
Austin Seipp committed
684 685 686
{-
************************************************************************
*                                                                      *
687
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
688 689 690
*                                                                      *
************************************************************************
-}
691

692 693 694
zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc]
zonkLExpr  :: ZonkEnv -> LHsExpr GhcTcId   -> TcM (LHsExpr GhcTc)
zonkExpr   :: ZonkEnv -> HsExpr GhcTcId    -> TcM (HsExpr GhcTc)
695

696
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
697
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
698

699
zonkExpr env (HsVar x (L l id))
Ben Gamari's avatar
Ben Gamari committed
700
  = ASSERT2( isNothing (isDataConId_maybe id), ppr id )
701
    return (HsVar x (L l (zonkIdOcc env id)))
702 703

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

705 706
zonkExpr _ (HsIPVar x id)
  = return (HsIPVar x id)
707

708
zonkExpr _ e@HsOverLabel{} = return e
Adam Gundry's avatar
Adam Gundry committed
709

710
zonkExpr env (HsLit x (HsRat e f ty))
ian@well-typed.com's avatar
ian@well-typed.com committed
711
  = do new_ty <- zonkTcTypeToType env ty
712
       return (HsLit x (HsRat e f new_ty))
sof's avatar
sof committed
713

714 715
zonkExpr _ (HsLit x lit)
  = return (HsLit x lit)
716

717
zonkExpr env (HsOverLit x lit)
718
  = do  { lit' <- zonkOverLit env lit
719
        ; return (HsOverLit x lit') }
720

721
zonkExpr env (HsLam x matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
722
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
723
       return (HsLam x new_matches)
724

725
zonkExpr env (HsLamCase x matches)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
726
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
727
       return (HsLamCase x new_matches)
728

729
zonkExpr env (HsApp x e1 e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
730 731
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
732
       return (HsApp x new_e1 new_e2)
733

734
zonkExpr env (HsAppType t e)
735
  = do new_e <- zonkLExpr env e
736
       return (HsAppType t new_e)
737 738
       -- NB: the type is an HsType; can't zonk that!

739
zonkExpr _ e@(HsRnBracketOut _ _ _)
gmainland's avatar
gmainland committed
740 741
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

742
zonkExpr env (HsTcBracketOut x body bs)
ian@well-typed.com's avatar
ian@well-typed.com committed
743
  = do bs' <- mapM zonk_b bs
744
       return (HsTcBracketOut x body bs')
745
  where
746 747
    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
                                      return (PendingTcSplice n e')
gmainland's avatar
gmainland committed
748

749 750
zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE x s)
751

752
zonkExpr env (OpApp fixity e1 op e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
753 754 755
  = do new_e1 <- zonkLExpr env e1
       new_op <- zonkLExpr env op
       new_e2 <- zonkLExpr env e2
756
       return (OpApp fixity new_e1 new_op new_e2)
757

758
zonkExpr env (NegApp x expr op)
759 760
  = do (env', new_op) <- zonkSyntaxExpr env op
       new_expr <- zonkLExpr env' expr
761
       return (NegApp x new_expr new_op)
762

763
zonkExpr env (HsPar x e)
ian@well-typed.com's avatar
ian@well-typed.com committed
764
  = do new_e <- zonkLExpr env e
765
       return (HsPar x new_e)
766

767
zonkExpr env (SectionL x expr op)
ian@well-typed.com's avatar
ian@well-typed.com committed
768 769
  = do new_expr <- zonkLExpr env expr
       new_op   <- zonkLExpr env op
770
       return (SectionL x new_expr new_op)
771

772
zonkExpr env (SectionR x op expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
773 774
  = do new_op   <- zonkLExpr env op
       new_expr <- zonkLExpr env expr
775
       return (SectionR x new_op new_expr)
776

777
zonkExpr env (ExplicitTuple x tup_args boxed)
778
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
779
       ; return (ExplicitTuple x new_tup_args boxed) }
780
  where
781 782
    zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e
                                          ; return (L l (Present x e')) }
783 784
    zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t
                                        ; return (L l (Missing t')) }
785
    zonk_tup_arg (L _ (XTupArg{})) = panic "zonkExpr.XTupArg"
786

787
zonkExpr env (ExplicitSum args alt arity expr)
788 789
  = do new_args <- mapM (zonkTcTypeToType env) args
       new_expr <- zonkLExpr env expr
790
       return (ExplicitSum new_args alt arity new_expr)
791

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

797
zonkExpr env (HsIf x Nothing e1 e2 e3)
798 799 800
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       new_e3 <- zonkLExpr env e3
801
       return (HsIf x Nothing new_e1 new_e2 new_e3)
802

803
zonkExpr env (HsIf x (Just fun) e1 e2 e3)
804 805 806 807
  = do (env1, new_fun) <- zonkSyntaxExpr env fun
       new_e1 <- zonkLExpr env1 e1
       new_e2 <- zonkLExpr env1 e2
       new_e3 <- zonkLExpr env1 e3
808
       return (HsIf x (Just new_fun) new_e1 new_e2 new_e3)
809

810 811 812
zonkExpr env (HsMultiIf ty alts)
  = do { alts' <- mapM (wrapLocM zonk_alt) alts
       ; ty'   <- zonkTcTypeToType env ty
813
       ; return $ HsMultiIf ty' alts' }
814
  where zonk_alt (GRHS x guard expr)
815
          = do { (env', guard') <- zonkStmts env zonkLExpr guard
816
               ; expr'          <- zonkLExpr env' expr
817 818
               ; return $ GRHS x guard' expr' }
        zonk_alt (XGRHS _) = panic "zonkExpr.HsMultiIf"
819

820
zonkExpr env (HsLet x (L l binds) expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
821 822
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_expr <- zonkLExpr new_env expr
823
       return (HsLet x (L l new_binds) new_expr)
824

825
zonkExpr env (HsDo ty do_or_lc (L l stmts))
ian@well-typed.com's avatar
ian@well-typed.com committed
826 827
  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
       new_ty <- zonkTcTypeToType env ty
828
       return (HsDo new_ty do_or_lc (L l new_stmts))
829

830
zonkExpr env (ExplicitList ty wit exprs)
831 832 833
  = do (env1, new_wit) <- zonkWit env wit
       new_ty <- zonkTcTypeToType env1 ty
       new_exprs <- zonkLExprs env1 exprs
ian@well-typed.com's avatar
ian@well-typed.com committed
834
       return (ExplicitList new_ty new_wit new_exprs)
835 836
   where zonkWit env Nothing    = return (env, Nothing)
         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
837

838 839
zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds })
  = do  { new_con_expr <- zonkExpr env (rcon_con_expr ext)
840
        ; new_rbinds   <- zonkRecFields env rbinds
841
        ; return (expr { rcon_ext  = ext { rcon_con_expr = new_con_expr }
842
                       , rcon_flds = new_rbinds }) }
843

844 845 846 847 848
zonkExpr env (RecordUpd { rupd_flds = rbinds
                        , rupd_expr = expr
                        , rupd_ext = RecordUpdTc
                            { rupd_cons = cons, rupd_in_tys = in_tys
                            , rupd_out_tys = out_tys, rupd_wrap = req_wrap }})
849 850 851
  = do  { new_expr    <- zonkLExpr env expr
        ; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
        ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
852
        ; new_rbinds  <- zonkRecUpdFields env rbinds
Matthew Pickering's avatar
Matthew Pickering committed
853
        ; (_, new_recwrap) <- zonkCoFn env req_wrap
854
        ; return (RecordUpd { rupd_expr = new_expr, rupd_flds =  new_rbinds
855 856 857 858
                            , rupd_ext = RecordUpdTc
                                { rupd_cons = cons, rupd_in_tys = new_in_tys
                                , rupd_out_tys = new_out_tys
                                , rupd_wrap = new_recwrap }}) }