TcHsSyn.hs 76.9 KB
Newer Older
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.
10
-}
11

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

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

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

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

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

47
#include "HsVersions.h"
48

49 50
import GhcPrelude

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

84 85
import {-# SOURCE #-} TcSplice (runTopSplice)

86 87
import Control.Monad
import Data.List  ( partition )
88
import Control.Arrow ( second )
89

90 91 92
{-
************************************************************************
*                                                                      *
93
       Extracting the type from HsSyn
94 95
*                                                                      *
************************************************************************
96

97 98
-}

99
hsLPatType :: OutPat GhcTc -> Type
100
hsLPatType lpat = hsPatType (unLoc lpat)
101

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

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

140
-- Overloaded literals. Here mainly because it uses isIntTy etc
141

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

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

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

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

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

173 174 175
{-
************************************************************************
*                                                                      *
176
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
177 178
*                                                                      *
************************************************************************
179

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

 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 b) convert unbound TcTyVar to Void
185
 c) convert each TcId to an Id by zonking its type
186

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

190 191 192
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
193

194
It's all pretty boring stuff, because HsSyn is such a large type, and
195
the environment manipulation is tiresome.
196
-}
197

198
-- Confused by zonking? See Note [What is zonking?] in TcMType.
199 200

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

231 232 233
* ze_meta_tv_env: see Note [Sharing when zonking to Type]


234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271
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.
-}
272

273 274 275 276 277
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
278

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

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

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

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

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

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

326 327
setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv
setZonkType ze flexi = ze { ze_flexi = flexi }
328

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

335
zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id
336
zonkLIdOcc env = onHasSrcSpan (zonkIdOcc env)
337

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

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

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

       return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty'))
371 372

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

zonkTopBndrs :: [TcId] -> TcM [Id]
376
zonkTopBndrs ids = initZonkEnv zonkIdBndrs ids
377

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

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

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

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

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

411 412 413 414 415 416 417 418 419
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

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

423
zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
424
zonkTyBndrsX = mapAccumLM zonkTyBndrX
dreixel's avatar
dreixel committed
425

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

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

Ningning Xie's avatar
Ningning Xie committed
440 441
zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis]
                             -> TcM (ZonkEnv, [VarBndr TyVar vis])
442
zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX
443

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

451
zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc)
452
zonkTopExpr e = initZonkEnv zonkExpr e
453

454
zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)
455
zonkTopLExpr e = initZonkEnv zonkLExpr e
456

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

625 626 627
zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind"
zonk_bind _ (XHsBindsLR _)                 = panic "zonk_bind"

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

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

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

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

659 660 661
{-
************************************************************************
*                                                                      *
662
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
663 664 665
*                                                                      *
************************************************************************
-}
666

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

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

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

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

713 714 715
{-
************************************************************************
*                                                                      *
716
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
717 718 719
*                                                                      *
************************************************************************
-}
720

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

725
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
726
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
727

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

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

734 735
zonkExpr _ (HsIPVar x id)
  = return (HsIPVar x id)
736

737
zonkExpr _ e@HsOverLabel{} = return e
Adam Gundry's avatar
Adam Gundry committed
738

739
zonkExpr env (HsLit x (HsRat e f ty))
740
  = do new_ty <- zonkTcTypeToTypeX env ty
741
       return (HsLit x (HsRat e f new_ty))
742

743 744
zonkExpr _ (HsLit x lit)
  = return (HsLit x lit)
745

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

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

754
zonkExpr env (HsLamCase x matches)
755
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
756
       return (HsLamCase x new_matches)
757

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

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

768
zonkExpr _ e@(HsRnBracketOut _ _ _)
769 770
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

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

778 779 780
zonkExpr env (HsSpliceE _ (HsSplicedT s)) =
  runTopSplice s >>= zonkExpr env

781 782
zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE x s)
783

784
zonkExpr env (OpApp fixity e1 op e2)
ian@well-typed.com's avatar
ian@well-typed.com committed
785 786 787
  = do new_e1 <- zonkLExpr env e1
       new_op <- zonkLExpr env op
       new_e2 <- zonkLExpr env e2
788
       return (OpApp fixity new_e1 new_op new_e2)
789

790
zonkExpr env (NegApp x expr op)
791 792
  = do (env', new_op) <- zonkSyntaxExpr env op
       new_expr <- zonkLExpr env' expr
793
       return (NegApp x new_expr new_op)
794

795
zonkExpr env (HsPar x e)
ian@well-typed.com's avatar
ian@well-typed.com committed
796
  = do new_e <- zonkLExpr env e
797
       return (HsPar x new_e)
798

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

804
zonkExpr env (SectionR x op expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
805 806
  = do new_op   <- zonkLExpr env op
       new_expr <- zonkLExpr env expr
807
       return (SectionR x new_op new_expr)
808

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

821

822
zonkExpr env (ExplicitSum args alt arity expr)
823
  = do new_args <- mapM (zonkTcTypeToTypeX env) args
824
       new_expr <- zonkLExpr env expr
825
       return (ExplicitSum new_args alt arity new_expr)
826

827
zonkExpr env (HsCase x expr ms)
ian@well-typed.com's avatar
ian@well-typed.com committed
828 829
  = do new_expr <- zonkLExpr env expr
       new_ms <- zonkMatchGroup env zonkLExpr ms
830
       return (HsCase x new_expr new_ms)
831

832
zonkExpr env (HsIf x Nothing e1 e2 e3)
833 834 835
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
       new_e3 <- zonkLExpr env e3
836
       return (HsIf x Nothing new_e1 new_e2 new_e3)
837

838
zonkExpr env (HsIf x (Just fun) e1 e2 e3)
839 840 841 842
  = do (env1, new_fun) <- zonkSyntaxExpr env fun
       new_e1 <- zonkLExpr env1 e1
       new_e2 <- zonkLExpr env1 e2
       new_e3 <- zonkLExpr env1 e3
843
       return (HsIf x (Just new_fun) new_e1 new_e2 new_e3)
844

845 846
zonkExpr env (HsMultiIf ty alts)
  = do { alts' <- mapM (wrapLocM zonk_alt) alts
847
       ; ty'   <- zonkTcTypeToTypeX env ty
848
       ; return $ HsMultiIf ty' alts' }
849
  where zonk_alt (GRHS x guard expr)
850
          = do { (env', guard') <- zonkStmts env zonkLExpr guard
851
               ; expr'          <- zonkLExpr env' expr
852 853
               ; return $ GRHS x guard' expr' }
        zonk_alt (XGRHS _) = panic "zonkExpr.HsMultiIf"
854

855
zonkExpr env (HsLet x (dL->L l binds) expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
856 857
  = do (new_env, new_binds) <- zonkLocalBinds env binds
       new_expr <- zonkLExpr new_env expr
858
       return (HsLet x (cL l new_binds) new_expr)
859

860
zonkExpr env (HsDo ty do_or_lc (dL->L l stmts))
ian@well-typed.com's avatar
ian@well-typed.com committed
861
  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
862
       new_ty <- zonkTcTypeToTypeX env ty
863
       return (HsDo new_ty do_or_lc (cL l new_stmts))
864

865
zonkExpr env (ExplicitList ty wit exprs)
866
  = do (env1, new_wit) <- zonkWit env wit
867
       new_ty <- zonkTcTypeToTypeX env1 ty
868
       new_exprs <- zonkLExprs env1 exprs
ian@well-typed.com's avatar
ian@well-typed.com committed
869
       return (ExplicitList new_ty new_wit new_exprs)
870 871
   where zonkWit env Nothing    = return (env, Nothing)
         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
872

873 874
zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds })
  = do  { new_con_expr <- zonkExpr env (rcon_con_expr ext)
875
        ; new_rbinds   <- zonkRecFields env rbinds
876
        ; return (expr { rcon_ext  = ext { rcon_con_expr = new_con_expr }
877
                       , rcon_flds = new_rbinds }) }
878

879 880 881 882 883
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 }})
884
  = do  { new_expr    <- zonkLExpr env expr
885 886
        ; new_in_tys  <- mapM (zonkTcTypeToTypeX env) in_tys
        ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys
887
        ; new_rbinds  <- zonkRecUpdFields env rbinds
888
        ; (_, new_recwrap) <- zonkCoFn env req_wrap
889
        ; return (RecordUpd { rupd_expr = new_expr, rupd_flds =  new_rbinds
890 891 892 893
                            , rupd_ext = RecordUpdTc
                                { rupd_cons = cons, rupd_in_tys = new_in_tys
                                , rupd_out_tys = new_out_tys
                                , rupd_wrap = new_recwrap }}) }
894

895
zonkExpr env (ExprWithTySig _ e ty)
896
  = do { e' <- zonkLExpr env e
897
       ; return (ExprWithTySig noExt e' ty) }
898

899
zonkExpr env (ArithSeq expr wit info)
900 901 902
  = do (env1, new_wit) <- zonkWit env wit
       new_expr <- zonkExpr env expr
       new_info <- zonkArithSeq env1 info
ian@well-typed.com's avatar
ian@well-typed.com committed
903
       return (ArithSeq new_expr new_wit new_info)
904 905
   where zonkWit env Nothing    = return (env, Nothing)
         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
906

907
zonkExpr env (HsSCC x src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
908
  = do new_expr <- zonkLExpr env expr
909
       return (HsSCC x src lbl new_expr)
910

911
zonkExpr env (HsTickPragma x src info srcInfo expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
912
  = do new_expr <- zonkLExpr env expr
913
       return (HsTickPragma x src info srcInfo new_expr)
914

915
-- hdaume: core annotations
916
zonkExpr env (HsCoreAnn x src lbl expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
917
  = do new_expr <- zonkLExpr env expr
918
       return (HsCoreAnn x src lbl new_expr)
919

920
-- arrow notation extensions
921
zonkExpr env (HsProc x pat body)
922 923
  = do  { (env1, new_pat) <- zonkPat env pat
        ; new_body <- zonkCmdTop env1 body
924
        ; return (HsProc x new_pat new_body) }
925

926
-- StaticPointers extension
927 928
zonkExpr env (HsStatic fvs expr)
  = HsStatic fvs <$> zonkLExpr env expr
929

930
zonkExpr env (HsWrap x co_fn expr)
ian@well-typed.com's avatar
ian@well-typed.com committed
931 932
  = do (env1, new_co_fn) <- zonkCoFn env co_fn
       new_expr <- zonkExpr env1 expr
933
       return (HsWrap x new_co_fn new_expr)
934

935
zonkExpr _ e@(HsUnboundVar {}) = return e
936

Ian Lynagh's avatar
Ian Lynagh committed
937
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
938

939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960
-------------------------------------------------------------------------
{-
Note [Skolems in zonkSyntaxExpr]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider rebindable syntax with something like

  (>>=) :: (forall x. blah) -> (forall y. blah') -> blah''

The x and y become skolems that are in scope when type-checking the
arguments to the bind. This means that we must extend the ZonkEnv with
these skolems when zonking the arguments to the bind. But the skolems
are different between the two arguments, and so we should theoretically
carry around different environments to use for the different arguments.

However, this becomes a logistical nightmare, especially in dealing with
the more exotic Stmt forms. So, we simplify by making the critical
assumption that the uniques of the skolems are different. (This assumption
is justified by the use of newUnique in TcMType.instSkolTyCoVarX.)
Now, we can safely just extend one environment.
-}

-- See Note [Skolems in zonkSyntaxExpr]
961 962
zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTcId
               -> TcM (ZonkEnv, SyntaxExpr GhcTc)
963 964 965 966 967 968 969 970 971 972
zonkSyntaxExpr env (SyntaxExpr { syn_expr      = expr
                               , syn_arg_wraps = arg_wraps
                               , syn_res_wrap  = res_wrap })
  = do { (env0, res_wrap')  <- zonkCoFn env res_wrap
       ; expr'              <- zonkExpr env0 expr
       ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps
       ; return (env1, SyntaxExpr { syn_expr      = expr'
                                  , syn_arg_wraps = arg_wraps'
                                  , syn_res_wrap  = res_wrap' }) }

973 974
-------------------------------------------------------------------------

975 976
zonkLCmd  :: ZonkEnv -> LHsCmd GhcTcId   -> TcM (LHsCmd GhcTc)
zonkCmd   :: ZonkEnv -> HsCmd GhcTcId    -> TcM (HsCmd GhcTc)
977 978 979

zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd

980
zonkCmd env (HsCmdWrap x w cmd)
981 982
  = do { (env1, w') <- zonkCoFn env w
       ; cmd' <- zonkCmd env1 cmd
983 984
       ; return (HsCmdWrap x w' cmd') }
zonkCmd env (HsCmdArrApp ty e1 e2 ho rl)
ian@well-typed.com's avatar
ian@well-typed.com committed
985 986
  = do new_e1 <- zonkLExpr env e1
       new_e2 <- zonkLExpr env e2
987
       new_ty <- zonkTcTypeToTypeX env ty