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

5 6

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

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

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

17 18
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

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

        -- * Other HsSyn functions
        mkHsDictLet, mkHsApp,
25
        mkHsAppTy, mkHsCaseAlt,
26
        shortCutLit, hsOverLitName,
27
        conLikeResTy,
28

29
        -- * re-exported from TcMonad
30 31
        TcId, TcIdSet,

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

49
#include "HsVersions.h"
50

51 52
import GhcPrelude

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

88 89
import {-# SOURCE #-} TcSplice (runTopSplice)

90 91
import Control.Monad
import Data.List  ( partition )
92
import Control.Arrow ( second )
93

Austin Seipp's avatar
Austin Seipp committed
94 95 96
{-
************************************************************************
*                                                                      *
97
       Extracting the type from HsSyn
Austin Seipp's avatar
Austin Seipp committed
98 99
*                                                                      *
************************************************************************
100

Austin Seipp's avatar
Austin Seipp committed
101 102
-}

103
hsLPatType :: LPat GhcTc -> Type
104
hsLPatType (L _ p) = hsPatType p
105

106
hsPatType :: Pat GhcTc -> Type
107
hsPatType (ParPat _ pat)                = hsLPatType pat
108
hsPatType (WildPat ty)                  = ty
109
hsPatType (VarPat _ lvar)               = idType (unLoc lvar)
110 111
hsPatType (BangPat _ pat)               = hsLPatType pat
hsPatType (LazyPat _ pat)               = hsLPatType pat
112 113 114
hsPatType (LitPat _ lit)                = hsLitType lit
hsPatType (AsPat _ var _)               = idType (unLoc var)
hsPatType (ViewPat ty _ _)              = ty
115 116
hsPatType (ListPat (ListPatTc ty Nothing) _)      = mkListTy ty
hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty
117 118
hsPatType (TuplePat tys _ bx)           = mkTupleTy1 bx tys
                  -- See Note [Don't flatten tuples from HsSyn] in MkCore
119
hsPatType (SumPat tys _ _ _ )           = mkSumTy tys
120 121 122
hsPatType (ConPatOut { pat_con = lcon
                     , pat_arg_tys = tys })
                                        = conLikeResTy (unLoc lcon) tys
123
hsPatType (SigPat ty _ _)               = ty
124 125 126
hsPatType (NPat ty _ _ _)               = ty
hsPatType (NPlusKPat ty _ _ _ _ _)      = ty
hsPatType (CoPat _ _ _ ty)              = ty
127
hsPatType (XPat n)                      = noExtCon n
128 129
hsPatType ConPatIn{}                    = panic "hsPatType: ConPatIn"
hsPatType SplicePat{}                   = panic "hsPatType: SplicePat"
130 131

hsLitType :: HsLit (GhcPass p) -> TcType
132 133 134 135
hsLitType (HsChar _ _)       = charTy
hsLitType (HsCharPrim _ _)   = charPrimTy
hsLitType (HsString _ _)     = stringTy
hsLitType (HsStringPrim _ _) = addrPrimTy
136
hsLitType (HsInt _ _)        = intTy
137 138 139 140 141
hsLitType (HsIntPrim _ _)    = intPrimTy
hsLitType (HsWordPrim _ _)   = wordPrimTy
hsLitType (HsInt64Prim _ _)  = int64PrimTy
hsLitType (HsWord64Prim _ _) = word64PrimTy
hsLitType (HsInteger _ _ ty) = ty
142 143 144
hsLitType (HsRat _ _ ty)     = ty
hsLitType (HsFloatPrim _ _)  = floatPrimTy
hsLitType (HsDoublePrim _ _) = doublePrimTy
145
hsLitType (XLit nec)         = noExtCon nec
146

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

149
shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId)
150
shortCutLit dflags (HsIntegral int@(IL src neg i)) ty
151
  | isIntTy ty  && inIntRange  dflags i = Just (HsLit noExtField (HsInt noExtField int))
152
  | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i))
153
  | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty))
154
  | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty
155 156 157 158 159
        -- 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
160

161
shortCutLit _ (HsFractional f) ty
162 163
  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim noExtField f))
  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f))
164 165
  | otherwise     = Nothing

166
shortCutLit _ (HsIsString src s) ty
167
  | isStringTy ty = Just (HsLit noExtField (HsString src s))
168 169
  | otherwise     = Nothing

170
mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc
171
mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit)
172 173 174 175 176 177 178

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

Austin Seipp's avatar
Austin Seipp committed
180 181 182
{-
************************************************************************
*                                                                      *
183
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
Austin Seipp's avatar
Austin Seipp committed
184 185
*                                                                      *
************************************************************************
186

187 188
The rest of the zonking is done *after* typechecking.
The main zonking pass runs over the bindings
189 190 191

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

194 195
The type variables are converted by binding mutable tyvars to immutable ones
and then zonking as normal.
196

197 198 199
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
200

201
It's all pretty boring stuff, because HsSyn is such a large type, and
202
the environment manipulation is tiresome.
Austin Seipp's avatar
Austin Seipp committed
203
-}
204

205
-- Confused by zonking? See Note [What is zonking?] in TcMType.
206 207

-- | See Note [The ZonkEnv]
208
-- Confused by zonking? See Note [What is zonking?] in TcMType.
209 210 211
data ZonkEnv  -- See Note [The ZonkEnv]
  = ZonkEnv { ze_flexi  :: ZonkFlexi
            , ze_tv_env :: TyCoVarEnv TyCoVar
212 213
            , ze_id_env :: IdEnv      Id
            , ze_meta_tv_env :: TcRef (TyVarEnv Type) }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
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.
231
  In a mutually recursive group
232 233 234 235 236 237 238
     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.

239 240 241
* ze_meta_tv_env: see Note [Sharing when zonking to Type]


242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262
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
263
  we must choose a type!  We can't leave mutable unification
264
  variables floating around: after typecheck is complete, every
265
  type variable occurrence must have a binding site.
266 267 268 269

  So we default it to 'Any' of the right kind.

  All this works for both type and kind variables (indeed
270
  the two are the same thing).
271 272 273 274 275 276 277 278 279

* 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.
-}
280

281
data ZonkFlexi   -- See Note [Un-unified unification variables]
282
  = DefaultFlexi    -- Default unbound unification variables to Any
283 284 285
  | SkolemiseFlexi  -- Skolemise unbound unification variables
                    -- See Note [Zonking the LHS of a RULE]
  | RuntimeUnkFlexi -- Used in the GHCi debugger
286

287
instance Outputable ZonkEnv where
288 289 290 291 292
  ppr (ZonkEnv { ze_tv_env = tv_env
               , ze_id_env = id_env })
    = text "ZE" <+> braces (vcat
         [ text "ze_tv_env =" <+> ppr tv_env
         , text "ze_id_env =" <+> ppr id_env ])
293

294
-- The EvBinds have to already be zonked, but that's usually the case.
295
emptyZonkEnv :: TcM ZonkEnv
296
emptyZonkEnv = mkEmptyZonkEnv DefaultFlexi
297

298 299 300 301 302 303 304 305
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 }) }

306 307 308
initZonkEnv :: (ZonkEnv -> TcM b) -> TcM b
initZonkEnv thing_inside = do { ze <- mkEmptyZonkEnv DefaultFlexi
                              ; thing_inside ze }
309

310 311
-- | Extend the knot-tied environment.
extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv
312
extendIdZonkEnvRec ze@(ZonkEnv { ze_id_env = id_env }) ids
313 314
    -- 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.
315
  = ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] }
316 317 318 319 320 321 322 323
  -- 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
324 325 326 327 328
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
329

330 331
extendIdZonkEnv :: ZonkEnv -> Var -> ZonkEnv
extendIdZonkEnv ze@(ZonkEnv { ze_id_env = id_env }) id
332
  = ze { ze_id_env = extendVarEnv id_env id id }
333

334 335
extendTyZonkEnv :: ZonkEnv -> TyVar -> ZonkEnv
extendTyZonkEnv ze@(ZonkEnv { ze_tv_env = ty_env }) tv
336
  = ze { ze_tv_env = extendVarEnv ty_env tv tv }
dreixel's avatar
dreixel committed
337

338 339
setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv
setZonkType ze flexi = ze { ze_flexi = flexi }
340

niteria's avatar
niteria committed
341
zonkEnvIds :: ZonkEnv -> TypeEnv
342 343
zonkEnvIds (ZonkEnv { ze_id_env = id_env})
  = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env]
niteria's avatar
niteria committed
344 345
  -- It's OK to use nonDetEltsUFM here because we forget the ordering
  -- immediately by creating a TypeEnv
346

347
zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id
348
zonkLIdOcc env = mapLoc (zonkIdOcc env)
349

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

Ian Lynagh's avatar
Ian Lynagh committed
371
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
372
zonkIdOccs env ids = map (zonkIdOcc env) ids
373

374
-- zonkIdBndr is used *after* typechecking to get the Id's type
375
-- to its final form.  The TyVarEnv give
376
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
377
zonkIdBndr env v
378
  = do ty' <- zonkTcTypeToTypeX env (idType v)
379 380 381 382
       ensureNotLevPoly ty'
         (text "In the type of binder" <+> quotes (ppr v))

       return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty'))
383 384

zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
385
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
386 387

zonkTopBndrs :: [TcId] -> TcM [Id]
388
zonkTopBndrs ids = initZonkEnv $ \ ze -> zonkIdBndrs ze ids
389

390
zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc)
391 392
zonkFieldOcc env (FieldOcc sel lbl)
  = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel
393
zonkFieldOcc _ (XFieldOcc nec) = noExtCon nec
394

395
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
396
zonkEvBndrsX = mapAccumLM zonkEvBndrX
397 398 399 400 401

zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
-- Works for dictionaries and coercions
zonkEvBndrX env var
  = do { var' <- zonkEvBndr env var
402
       ; return (extendZonkEnv env [var'], var') }
403 404 405 406

zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
-- Works for dictionaries and coercions
-- Does not extend the ZonkEnv
407
zonkEvBndr env var
408
  = do { let var_ty = varType var
409
       ; ty <-
410
           {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
411
           zonkTcTypeToTypeX env var_ty
dreixel's avatar
dreixel committed
412
       ; return (setVarType var ty) }
413

414
{-
415 416 417 418 419 420
zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm
zonkEvVarOcc env v
  | isCoVar v
  = EvCoercion <$> zonkCoVarOcc env v
  | otherwise
  = return (EvId $ zonkIdOcc env v)
421
-}
dreixel's avatar
dreixel committed
422

423 424 425
zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var)
zonkCoreBndrX env v
  | isId v = do { v' <- zonkIdBndr env v
426
                ; return (extendIdZonkEnv env v', v') }
427 428 429 430 431
  | otherwise = zonkTyBndrX env v

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

432
zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar])
433
zonkTyBndrs tvs = initZonkEnv $ \ze -> zonkTyBndrsX ze tvs
434

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
438
zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
439 440
-- This guarantees to return a TyVar (not a TcTyVar)
-- then we add it to the envt, so all occurrences are replaced
441 442 443 444
--
-- It does not clone: the new TyVar has the sane Name
-- as the old one.  This important when zonking the
-- TyVarBndrs of a TyCon, whose Names may scope.
dreixel's avatar
dreixel committed
445
zonkTyBndrX env tv
Tobias Dammers's avatar
Tobias Dammers committed
446
  = ASSERT2( isImmutableTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) )
447
    do { ki <- zonkTcTypeToTypeX env (tyVarKind tv)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
448
               -- Internal names tidy up better, for iface files.
449
       ; let tv' = mkTyVar (tyVarName tv) ki
450
       ; return (extendTyZonkEnv env tv', tv') }
451

Ningning Xie's avatar
Ningning Xie committed
452 453
zonkTyVarBinders ::  [VarBndr TcTyVar vis]
                 -> TcM (ZonkEnv, [VarBndr TyVar vis])
454
zonkTyVarBinders tvbs = initZonkEnv $ \ ze -> zonkTyVarBindersX ze tvbs
455

Ningning Xie's avatar
Ningning Xie committed
456 457
zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis]
                             -> TcM (ZonkEnv, [VarBndr TyVar vis])
Simon Peyton Jones's avatar
Simon Peyton Jones committed
458
zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX
459

Ningning Xie's avatar
Ningning Xie committed
460 461
zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis
                            -> TcM (ZonkEnv, VarBndr TyVar vis)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
462
-- Takes a TcTyVar and guarantees to return a TyVar
Ningning Xie's avatar
Ningning Xie committed
463
zonkTyVarBinderX env (Bndr tv vis)
464
  = do { (env', tv') <- zonkTyBndrX env tv
Ningning Xie's avatar
Ningning Xie committed
465
       ; return (env', Bndr tv' vis) }
466

467
zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc)
468
zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e
469

470
zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)
471
zonkTopLExpr e = initZonkEnv $ \ ze -> zonkLExpr ze e
472

473
zonkTopDecls :: Bag EvBind
474
             -> LHsBinds GhcTcId
475
             -> [LRuleDecl GhcTcId] -> [LTcSpecPrag]
476
             -> [LForeignDecl GhcTcId]
niteria's avatar
niteria committed
477
             -> TcM (TypeEnv,
478
                     Bag EvBind,
479 480
                     LHsBinds GhcTc,
                     [LForeignDecl GhcTc],
481
                     [LTcSpecPrag],
482 483
                     [LRuleDecl    GhcTc])
zonkTopDecls ev_binds binds rules imp_specs fords
484
  = do  { (env1, ev_binds') <- initZonkEnv $ \ ze -> zonkEvBinds ze ev_binds
485
        ; (env2, binds')    <- zonkRecMonoBinds env1 binds
486 487
                        -- Top level is implicitly recursive
        ; rules' <- zonkRules env2 rules
488
        ; specs' <- zonkLTcSpecPrags env2 imp_specs
489
        ; fords' <- zonkForeignExports env2 fords
490
        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }
491 492

---------------------------------------------
493 494
zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId
               -> TcM (ZonkEnv, HsLocalBinds GhcTc)
495 496
zonkLocalBinds env (EmptyLocalBinds x)
  = return (env, (EmptyLocalBinds x))
497

498
zonkLocalBinds _ (HsValBinds _ (ValBinds {}))
499 500
  = panic "zonkLocalBinds" -- Not in typechecker output

501
zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs)))
502
  = do  { (env1, new_binds) <- go env binds
503
        ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) }
504
  where
505
    go env []
506
      = return (env, [])
507 508 509
    go env ((r,b):bs)
      = do { (env1, b')  <- zonkRecMonoBinds env b
           ; (env2, bs') <- go env1 bs
510
           ; return (env2, (r,b'):bs') }
511

512
zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
513
    new_binds <- mapM (wrapLocM zonk_ip_bind) binds
514
    let
515
        env1 = extendIdZonkEnvRec env
516
                 [ n | (L _ (IPBind _ (Right n) _)) <- new_binds]
ian@well-typed.com's avatar
ian@well-typed.com committed
517
    (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
518
    return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds))
519
  where
520
    zonk_ip_bind (IPBind x n e)
ian@well-typed.com's avatar
ian@well-typed.com committed
521 522
        = do n' <- mapIPNameTc (zonkIdBndr env) n
             e' <- zonkLExpr env e
523
             return (IPBind x n' e')
524
    zonk_ip_bind (XIPBind nec) = noExtCon nec
525

526 527 528 529
zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds nec))
  = noExtCon nec
zonkLocalBinds _ (XHsLocalBindsLR nec)
  = noExtCon nec
530

531
---------------------------------------------
532
zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc)
533
zonkRecMonoBinds env binds
534
 = fixM (\ ~(_, new_binds) -> do
535
        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)
536
        ; binds' <- zonkMonoBinds env1 binds
537 538
        ; return (env1, binds') })

539
---------------------------------------------
540
zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc)
541
zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
cactus's avatar
cactus committed
542

543
zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc)
544
zonk_lbind env = wrapLocM (zonk_bind env)
545

546
zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc)
547 548
zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss
                            , pat_ext = NPatBindTc fvs ty})
549 550
  = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
        ; new_grhss <- zonkGRHSs env zonkLExpr grhss
551
        ; new_ty    <- zonkTcTypeToTypeX env ty
552 553
        ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss
                       , pat_ext = NPatBindTc fvs new_ty }) }
554

555 556
zonk_bind env (VarBind { var_ext = x
                       , var_id = var, var_rhs = expr, var_inline = inl })
557 558
  = do { new_var  <- zonkIdBndr env var
       ; new_expr <- zonkLExpr env expr
559 560 561 562
       ; return (VarBind { var_ext = x
                         , var_id = new_var
                         , var_rhs = new_expr
                         , var_inline = inl }) }
563

564
zonk_bind env bind@(FunBind { fun_id = L loc var
565
                            , fun_matches = ms
566
                            , fun_ext = co_fn })
567 568
  = do { new_var <- zonkIdBndr env var
       ; (env1, new_co_fn) <- zonkCoFn env co_fn
569
       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
570
       ; return (bind { fun_id = L loc new_var
571
                      , fun_matches = new_ms
572
                      , fun_ext = new_co_fn }) }
573

574 575 576
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                        , abs_ev_binds = ev_binds
                        , abs_exports = exports
577 578
                        , abs_binds = val_binds
                        , abs_sig = has_sig })
579
  = ASSERT( all isImmutableTyVar tyvars )
dreixel's avatar
dreixel committed
580 581
    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
582
       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
583
       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
584 585 586 587
         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
588
            ; return (new_val_binds, new_exports) }
589
       ; return (AbsBinds { abs_ext = noExtField
590
                          , abs_tvs = new_tyvars, abs_ev_vars = new_evs
dreixel's avatar
dreixel committed
591
                          , abs_ev_binds = new_ev_binds
592 593
                          , abs_exports = new_exports, abs_binds = new_val_bind
                          , abs_sig = has_sig }) }
sof's avatar
sof committed
594
  where
595 596
    zonk_val_bind env lbind
      | has_sig
597 598
      , (L loc bind@(FunBind { fun_id      = L mloc mono_id
                             , fun_matches = ms
599
                             , fun_ext     = co_fn })) <- lbind
600
      = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id
601 602 603 604
                            -- 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
605 606
           ; return $ L loc $
             bind { fun_id      = L mloc new_mono_id
607
                  , fun_matches = new_ms
608
                  , fun_ext     = new_co_fn } }
609 610 611
      | otherwise
      = zonk_lbind env lbind   -- The normal case

612 613
    zonk_export env (ABE{ abe_ext = x
                        , abe_wrap = wrap
614 615 616
                        , abe_poly = poly_id
                        , abe_mono = mono_id
                        , abe_prags = prags })
ian@well-typed.com's avatar
ian@well-typed.com committed
617 618 619
        = do new_poly_id <- zonkIdBndr env poly_id
             (_, new_wrap) <- zonkCoFn env wrap
             new_prags <- zonkSpecPrags env prags
620 621
             return (ABE{ abe_ext = x
                        , abe_wrap = new_wrap
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
622
                        , abe_poly = new_poly_id
ian@well-typed.com's avatar
ian@well-typed.com committed
623 624
                        , abe_mono = zonkIdOcc env mono_id
                        , abe_prags = new_prags })
625
    zonk_export _ (XABExport nec) = noExtCon nec
626

627
zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id
628 629 630
                                      , psb_args = details
                                      , psb_def = lpat
                                      , psb_dir = dir }))
cactus's avatar
cactus committed
631
  = do { id' <- zonkIdBndr env id
632
       ; (env1, lpat') <- zonkPat env lpat
633
       ; let details' = zonkPatSynDetails env1 details
cactus's avatar
cactus committed
634
       ; (_env2, dir') <- zonkPatSynDir env1 dir
635
       ; return $ PatSynBind x $
636
                  bind { psb_id = L loc id'
637 638 639
                       , psb_args = details'
                       , psb_def = lpat'
                       , psb_dir = dir' } }
cactus's avatar
cactus committed
640

641 642
zonk_bind _ (PatSynBind _ (XPatSynBind nec)) = noExtCon nec
zonk_bind _ (XHsBindsLR nec)                 = noExtCon nec
643

cactus's avatar
cactus committed
644 645
zonkPatSynDetails :: ZonkEnv
                  -> HsPatSynDetails (Located TcId)
646 647 648 649 650 651 652
                  -> 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
653

654 655
zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId
              -> TcM (ZonkEnv, HsPatSynDir GhcTc)
656
zonkPatSynDir env Unidirectional        = return (env, Unidirectional)
cactus's avatar
cactus committed
657
zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
658 659 660
zonkPatSynDir env (ExplicitBidirectional mg) = do
    mg' <- zonkMatchGroup env zonkLExpr mg
    return (env, ExplicitBidirectional mg')
cactus's avatar
cactus committed
661

662 663
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
664
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
665
                                       ; return (SpecPrags ps') }
666 667 668 669

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
670
  where
671
    zonk_prag (L loc (SpecPrag id co_fn inl))
672
        = do { (_, co_fn') <- zonkCoFn env co_fn
673
             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
674

Austin Seipp's avatar
Austin Seipp committed
675 676 677
{-
************************************************************************
*                                                                      *
678
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
Austin Seipp's avatar
Austin Seipp committed
679 680 681
*                                                                      *
************************************************************************
-}
682

683
zonkMatchGroup :: ZonkEnv
684 685 686
            -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
            -> MatchGroup GhcTcId (Located (body GhcTcId))
            -> TcM (MatchGroup GhcTc (Located (body GhcTc)))
687
zonkMatchGroup env zBody (MG { mg_alts = L l ms
688 689
                             , mg_ext = MatchGroupTc arg_tys res_ty
                             , mg_origin = origin })
690
  = do  { ms' <- mapM (zonkMatch env zBody) ms
691 692
        ; arg_tys' <- zonkTcTypesToTypesX env arg_tys
        ; res_ty'  <- zonkTcTypeToTypeX env res_ty
693
        ; return (MG { mg_alts = L l ms'
694 695
                     , mg_ext = MatchGroupTc arg_tys' res_ty'
                     , mg_origin = origin }) }
696
zonkMatchGroup _ _ (XMatchGroup nec) = noExtCon nec
697

698
zonkMatch :: ZonkEnv
699 700 701
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> LMatch GhcTcId (Located (body GhcTcId))
          -> TcM (LMatch GhcTc (Located (body GhcTc)))
702 703
zonkMatch env zBody (L loc match@(Match { m_pats = pats
                                        , m_grhss = grhss }))
704 705
  = do  { (env1, new_pats) <- zonkPats env pats
        ; new_grhss <- zonkGRHSs env1 zBody grhss
706 707
        ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
zonkMatch _ _ (L  _ (XMatch nec)) = noExtCon nec
708

709
-------------------------------------------------------------------------
710
zonkGRHSs :: ZonkEnv
711 712 713
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> GRHSs GhcTcId (Located (body GhcTcId))
          -> TcM (GRHSs GhcTc (Located (body GhcTc)))
714

715
zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do
ian@well-typed.com's avatar
ian@well-typed.com committed
716
    (new_env, new_binds) <- zonkLocalBinds env binds
717
    let
718
        zonk_grhs (GRHS xx guarded rhs)
ian@well-typed.com's avatar
ian@well-typed.com committed
719 720
          = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
               new_rhs <- zBody env2 rhs
721
               return (GRHS xx new_guarded new_rhs)
722
        zonk_grhs (XGRHS nec) = noExtCon nec
ian@well-typed.com's avatar
ian@well-typed.com committed
723
    new_grhss <- mapM (wrapLocM zonk_grhs) grhss
724
    return (GRHSs x new_grhss (L l new_binds))
725
zonkGRHSs _ _ (XGRHSs nec) = noExtCon nec
726

Austin Seipp's avatar
Austin Seipp committed
727 728 729
{-
************************************************************************
*                                                                      *
730
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
Austin Seipp's avatar
Austin Seipp committed
731 732 733
*                                                                      *
************************************************************************
-}
734

735 736 737
zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc]
zonkLExpr  :: ZonkEnv -> LHsExpr GhcTcId   -> TcM (LHsExpr GhcTc)
zonkExpr   :: ZonkEnv -> HsExpr GhcTcId    -> TcM (HsExpr GhcTc)
738

739
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
740
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
741

742
zonkExpr env (HsVar x (L l id))
Ben Gamari's avatar
Ben Gamari committed
743
  = ASSERT2( isNothing (isDataConId_maybe id), ppr id )
744
    return (HsVar x (L l (zonkIdOcc env id)))
745 746

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

748 749
zonkExpr _ (HsIPVar x id)
  = return (HsIPVar x id)
750

751
zonkExpr _ e@HsOverLabel{} = return e
Adam Gundry's avatar
Adam Gundry committed
752

753
zonkExpr env (HsLit x (HsRat e f ty))
754
  = do new_ty <- zonkTcTypeToTypeX env ty
755
       return (HsLit x (HsRat e f new_ty))
sof's avatar
sof committed
756

757 758
zonkExpr _ (HsLit x lit)
  = return (HsLit x lit)
759

760
zonkExpr env (HsOverLit x lit)
761
  = do  { lit' <- zonkOverLit env lit
762
        ; return (HsOverLit x lit') }
763

764
zonkExpr env (HsLam x matches)
ian@well-typed.com's avatar
ian@well-typed.com committed
765
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
766
       return (HsLam x new_matches)
767

768
zonkExpr env (HsLamCase x matches)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
769
  = do new_matches <- zonkMatchGroup env zonkLExpr matches
770
       return (HsLamCase x new_matches)
771

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

777
zonkExpr env (HsAppType x e t)
778
  = do new_e <- zonkLExpr env e
779
       return (HsAppType x new_e t)
780 781
       -- NB: the type is an HsType; can't zonk that!

782
zonkExpr _ e@(HsRnBracketOut _ _ _)
gmainland's avatar
gmainland committed
783 784
  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)

785 786 787 788
zonkExpr env (HsTcBracketOut x wrap body bs)
  = do wrap' <- traverse zonkQuoteWrap wrap
       bs' <- mapM (zonk_b env) bs
       return (HsTcBracketOut x wrap' body bs')
789
  where
790 791 792 793 794 795 796
    zonkQuoteWrap (QuoteWrapper ev ty) = do
        let ev' = zonkIdOcc env ev
        ty' <- zonkTcTypeToTypeX env ty
        return (QuoteWrapper ev' ty')

    zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e
                                           return (PendingTcSplice n e')
gmainland's avatar
gmainland committed
797

798
zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) =
799 800
  runTopSplice s >>= zonkExpr env

801 802
zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen
                           return (HsSpliceE x s)
803

804
zonkExpr env