TcEnv.hs 41.8 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
-- (c) The University of Glasgow 2006
2
{-# LANGUAGE CPP, FlexibleInstances #-}
3
{-# LANGUAGE FlexibleContexts #-}
Jan Stolarek's avatar
Jan Stolarek committed
4 5
{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an
                                       -- orphan
6 7
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                      -- in module PlaceHolder
8

9
module TcEnv(
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
10
        TyThing(..), TcTyThing(..), TcId,
11

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
12
        -- Instance environment, and InstInfo type
13
        InstInfo(..), iDFunId, pprInstInfoDetails,
Austin Seipp's avatar
Austin Seipp committed
14
        simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
15
        InstBindings(..),
16

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
17
        -- Global environment
18 19
        tcExtendGlobalEnv, tcExtendTyConEnv,
        tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
20
        tcExtendGlobalValEnv,
Austin Seipp's avatar
Austin Seipp committed
21
        tcLookupLocatedGlobal, tcLookupGlobal,
Adam Gundry's avatar
Adam Gundry committed
22
        tcLookupTyCon, tcLookupClass,
23
        tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
24
        tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
25
        tcLookupLocatedClass, tcLookupAxiom,
26
        lookupGlobal,
Austin Seipp's avatar
Austin Seipp committed
27

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
28
        -- Local environment
29
        tcExtendKindEnv, tcExtendKindEnvList,
Austin Seipp's avatar
Austin Seipp committed
30
        tcExtendTyVarEnv, tcExtendTyVarEnv2,
31
        tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds,
32
        tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
33
        tcExtendBinderStack, tcExtendLocalTypeEnv,
34
        isTypeClosedLetBndr,
35

Austin Seipp's avatar
Austin Seipp committed
36
        tcLookup, tcLookupLocated, tcLookupLocalIds,
37
        tcLookupId, tcLookupIdMaybe, tcLookupTyVar,
Austin Seipp's avatar
Austin Seipp committed
38
        tcLookupLcl_maybe,
niteria's avatar
niteria committed
39
        getInLocalScope,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
40 41
        wrongThingErr, pprBinders,

42
        tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders,
43
        getTypeSigNames,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
44 45
        tcExtendRecEnv,         -- For knot-tying

46 47 48
        -- Tidying
        tcInitTidyEnv, tcInitOpenTidyEnv,

49 50 51
        -- Instances
        tcLookupInstance, tcGetInstEnvs,

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
52
        -- Rules
53
        tcExtendRules,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
54 55 56 57 58

        -- Defaults
        tcGetDefaultTys,

        -- Global type variables
59
        tcGetGlobalTyCoVars,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
60 61

        -- Template Haskell stuff
Austin Seipp's avatar
Austin Seipp committed
62
        checkWellStaged, tcMetaTy, thLevel,
63
        topIdLvl, isBrackStage,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
64 65

        -- New Ids
66
        newDFunName, newDFunName', newFamInstTyConName,
67
        newFamInstAxiomName,
68 69
        mkStableIdFromString, mkStableIdFromName,
        mkWrapperName
70 71
  ) where

72
#include "HsVersions.h"
73

74 75
import GhcPrelude

Simon Marlow's avatar
Simon Marlow committed
76 77
import HsSyn
import IfaceEnv
78
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
79 80
import TcMType
import TcType
81
import LoadIface
82 83
import PrelNames
import TysWiredIn
batterseapower's avatar
batterseapower committed
84
import Id
Simon Marlow's avatar
Simon Marlow committed
85
import Var
86
import VarSet
Simon Marlow's avatar
Simon Marlow committed
87 88
import RdrName
import InstEnv
89 90
import DataCon ( DataCon )
import PatSyn  ( PatSyn )
Gergő Érdi's avatar
Gergő Érdi committed
91
import ConLike
Simon Marlow's avatar
Simon Marlow committed
92
import TyCon
93
import Type
94
import CoAxiom
Simon Marlow's avatar
Simon Marlow committed
95 96
import Class
import Name
97
import NameSet
98
import NameEnv
99
import VarEnv
Simon Marlow's avatar
Simon Marlow committed
100
import HscTypes
101
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
102
import SrcLoc
103
import BasicTypes hiding( SuccessFlag(..) )
104
import Module
sof's avatar
sof committed
105
import Outputable
106
import Encoding
107
import FastString
108
import ListSetOps
109
import Util
110
import Maybes( MaybeErr(..), orElse )
111 112
import qualified GHC.LanguageExtensions as LangExt

113 114
import Data.IORef
import Data.List
115

116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132

{- *********************************************************************
*                                                                      *
            An IO interface to looking up globals
*                                                                      *
********************************************************************* -}

lookupGlobal :: HscEnv -> Name -> IO TyThing
-- An IO version, used outside the typechecker
-- It's more complicated than it looks, because it may
-- need to suck in an interface file
lookupGlobal hsc_env name
  = initTcForLookup hsc_env (tcLookupGlobal name)
    -- This initTcForLookup stuff is massive overkill
    -- but that's how it is right now, and at least
    -- this function localises it

Austin Seipp's avatar
Austin Seipp committed
133 134 135 136 137 138
{-
************************************************************************
*                                                                      *
*                      tcLookupGlobal                                  *
*                                                                      *
************************************************************************
139

140 141 142
Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
unless you know that the SrcSpan in the monad is already set to the
span of the Name.
Austin Seipp's avatar
Austin Seipp committed
143
-}
144

145

146
tcLookupLocatedGlobal :: Located Name -> TcM TyThing
147
-- c.f. IfaceEnvEnv.tcIfaceGlobal
148 149 150 151
tcLookupLocatedGlobal name
  = addLocM tcLookupGlobal name

tcLookupGlobal :: Name -> TcM TyThing
152 153 154
-- The Name is almost always an ExternalName, but not always
-- In GHCi, we may make command-line bindings (ghci> let x = True)
-- that bind a GlobalId, but with an InternalName
155
tcLookupGlobal name
156 157
  = do  {    -- Try local envt
          env <- getGblEnv
158
        ; case lookupNameEnv (tcg_type_env env) name of {
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
159
                Just thing -> return thing ;
160
                Nothing    ->
161

162
                -- Should it have been in the local envt?
Edward Z. Yang's avatar
Edward Z. Yang committed
163 164 165
                -- (NB: use semantic mod here, since names never use
                -- identity module, see Note [Identity versus semantic module].)
          if nameIsLocalOrFrom (tcg_semantic_mod env) name
166 167
          then notFound name  -- Internal names can happen in GHCi
          else
168 169

           -- Try home package table and external package table
170
    do  { mb_thing <- tcLookupImported_maybe name
171 172 173
        ; case mb_thing of
            Succeeded thing -> return thing
            Failed msg      -> failWithTc msg
174
        }}}
175

176
tcLookupDataCon :: Name -> TcM DataCon
177 178
tcLookupDataCon name = do
    thing <- tcLookupGlobal name
179
    case thing of
Gergő Érdi's avatar
Gergő Érdi committed
180 181 182
        AConLike (RealDataCon con) -> return con
        _                          -> wrongThingErr "data constructor" (AGlobal thing) name

183 184 185 186 187 188 189
tcLookupPatSyn :: Name -> TcM PatSyn
tcLookupPatSyn name = do
    thing <- tcLookupGlobal name
    case thing of
        AConLike (PatSynCon ps) -> return ps
        _                       -> wrongThingErr "pattern synonym" (AGlobal thing) name

Gergő Érdi's avatar
Gergő Érdi committed
190 191 192 193 194 195
tcLookupConLike :: Name -> TcM ConLike
tcLookupConLike name = do
    thing <- tcLookupGlobal name
    case thing of
        AConLike cl -> return cl
        _           -> wrongThingErr "constructor-like thing" (AGlobal thing) name
196

197
tcLookupClass :: Name -> TcM Class
198 199
tcLookupClass name = do
    thing <- tcLookupGlobal name
200
    case thing of
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
201 202
        ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls
        _                                           -> wrongThingErr "class" (AGlobal thing) name
Ian Lynagh's avatar
Ian Lynagh committed
203

204
tcLookupTyCon :: Name -> TcM TyCon
205 206
tcLookupTyCon name = do
    thing <- tcLookupGlobal name
207
    case thing of
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
208 209
        ATyCon tc -> return tc
        _         -> wrongThingErr "type constructor" (AGlobal thing) name
210

211
tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
212 213 214 215 216 217
tcLookupAxiom name = do
    thing <- tcLookupGlobal name
    case thing of
        ACoAxiom ax -> return ax
        _           -> wrongThingErr "axiom" (AGlobal thing) name

218 219 220 221 222 223 224 225
tcLookupLocatedGlobalId :: Located Name -> TcM Id
tcLookupLocatedGlobalId = addLocM tcLookupId

tcLookupLocatedClass :: Located Name -> TcM Class
tcLookupLocatedClass = addLocM tcLookupClass

tcLookupLocatedTyCon :: Located Name -> TcM TyCon
tcLookupLocatedTyCon = addLocM tcLookupTyCon
226 227

-- Find the instance that exactly matches a type class application.  The class arguments must be precisely
228
-- the same as in the instance declaration (modulo renaming & casts).
229
--
230
tcLookupInstance :: Class -> [Type] -> TcM ClsInst
231 232 233
tcLookupInstance cls tys
  = do { instEnv <- tcGetInstEnvs
       ; case lookupUniqueInstEnv instEnv cls tys of
234
           Left err             -> failWithTc $ text "Couldn't match instance:" <+> err
Austin Seipp's avatar
Austin Seipp committed
235
           Right (inst, tys)
236 237 238 239
             | uniqueTyVars tys -> return inst
             | otherwise        -> failWithTc errNotExact
       }
  where
240
    errNotExact = text "Not an exact match (i.e., some variables get instantiated)"
Austin Seipp's avatar
Austin Seipp committed
241

242 243
    uniqueTyVars tys = all isTyVarTy tys
                    && hasNoDups (map (getTyVar "tcLookupInstance") tys)
244

245 246 247 248 249 250 251
tcGetInstEnvs :: TcM InstEnvs
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
tcGetInstEnvs = do { eps <- getEps
                   ; env <- getGblEnv
                   ; return (InstEnvs { ie_global  = eps_inst_env eps
                                      , ie_local   = tcg_inst_env env
252
                                      , ie_visible = tcVisibleOrphanMods env }) }
253

254 255 256
instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
    lookupThing = tcLookupGlobal

Austin Seipp's avatar
Austin Seipp committed
257 258 259
{-
************************************************************************
*                                                                      *
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
260
                Extending the global environment
Austin Seipp's avatar
Austin Seipp committed
261 262 263
*                                                                      *
************************************************************************
-}
264

265
setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
Austin Seipp's avatar
Austin Seipp committed
266
-- Use this to update the global type env
267
-- It updates both  * the normal tcg_type_env field
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
268
--                  * the tcg_type_env_var field seen by interface files
269 270
setGlobalTypeEnv tcg_env new_type_env
  = do  {     -- Sync the type-envt variable seen by interface files
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
271 272
           writeMutVar (tcg_type_env_var tcg_env) new_type_env
         ; return (tcg_env { tcg_type_env = new_type_env }) }
273

274 275

tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
276 277
  -- Just extend the global environment with some TyThings
  -- Do not extend tcg_tcs etc
278
tcExtendGlobalEnvImplicit things thing_inside
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
279 280 281 282
   = do { tcg_env <- getGblEnv
        ; let ge'  = extendTypeEnvList (tcg_type_env tcg_env) things
        ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
        ; setGblEnv tcg_env' thing_inside }
283

dreixel's avatar
dreixel committed
284 285 286 287 288
tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
  -- Given a mixture of Ids, TyCons, Classes, all defined in the
  -- module being compiled, extend the global environment
tcExtendGlobalEnv things thing_inside
  = do { env <- getGblEnv
Gergő Érdi's avatar
Gergő Érdi committed
289 290
       ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env,
                          tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env }
dreixel's avatar
dreixel committed
291 292 293 294
       ; setGblEnv env' $
            tcExtendGlobalEnvImplicit things thing_inside
       }

295 296 297 298 299 300 301 302 303 304
tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r
  -- Given a mixture of Ids, TyCons, Classes, all defined in the
  -- module being compiled, extend the global environment
tcExtendTyConEnv tycons thing_inside
  = do { env <- getGblEnv
       ; let env' = env { tcg_tcs = tycons ++ tcg_tcs env }
       ; setGblEnv env' $
         tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside
       }

305 306
tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
  -- Same deal as tcExtendGlobalEnv, but for Ids
Austin Seipp's avatar
Austin Seipp committed
307
tcExtendGlobalValEnv ids thing_inside
dreixel's avatar
dreixel committed
308
  = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside
309

310 311
tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
-- Extend the global environments for the type/class knot tying game
312
-- Just like tcExtendGlobalEnv, except the argument is a list of pairs
313
tcExtendRecEnv gbl_stuff thing_inside
314
 = do  { tcg_env <- getGblEnv
Austin Seipp's avatar
Austin Seipp committed
315
       ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff
316 317
       ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
       ; setGblEnv tcg_env' thing_inside }
318

Austin Seipp's avatar
Austin Seipp committed
319 320 321
{-
************************************************************************
*                                                                      *
322
\subsection{The local environment}
Austin Seipp's avatar
Austin Seipp committed
323 324 325
*                                                                      *
************************************************************************
-}
326

327 328 329
tcLookupLocated :: Located Name -> TcM TcTyThing
tcLookupLocated = addLocM tcLookup

330 331 332 333 334
tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
tcLookupLcl_maybe name
  = do { local_env <- getLclTypeEnv
       ; return (lookupNameEnv local_env name) }

335
tcLookup :: Name -> TcM TcTyThing
336
tcLookup name = do
337 338
    local_env <- getLclTypeEnv
    case lookupNameEnv local_env name of
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
339 340
        Just thing -> return thing
        Nothing    -> AGlobal <$> tcLookupGlobal name
341

342
tcLookupTyVar :: Name -> TcM TcTyVar
343 344 345 346 347
tcLookupTyVar name
  = do { thing <- tcLookup name
       ; case thing of
           ATyVar _ tv -> return tv
           _           -> pprPanic "tcLookupTyVar" (ppr name) }
348

349
tcLookupId :: Name -> TcM Id
Austin Seipp's avatar
Austin Seipp committed
350
-- Used when we aren't interested in the binding level, nor refinement.
351
-- The "no refinement" part means that we return the un-refined Id regardless
Austin Seipp's avatar
Austin Seipp committed
352
--
353
-- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
354
tcLookupId name = do
355
    thing <- tcLookupIdMaybe name
356
    case thing of
357 358 359 360 361 362 363 364 365 366
        Just id -> return id
        _       -> pprPanic "tcLookupId" (ppr name)

tcLookupIdMaybe :: Name -> TcM (Maybe Id)
tcLookupIdMaybe name
  = do { thing <- tcLookup name
       ; case thing of
           ATcId { tct_id = id} -> return $ Just id
           AGlobal (AnId id)    -> return $ Just id
           _                    -> return Nothing }
367

368 369 370
tcLookupLocalIds :: [Name] -> TcM [TcId]
-- We expect the variables to all be bound, and all at
-- the same level as the lookup.  Only used in one place...
Austin Seipp's avatar
Austin Seipp committed
371
tcLookupLocalIds ns
372
  = do { env <- getLclEnv
373
       ; return (map (lookup (tcl_env env)) ns) }
374
  where
Austin Seipp's avatar
Austin Seipp committed
375
    lookup lenv name
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
376
        = case lookupNameEnv lenv name of
377
                Just (ATcId { tct_id = id }) ->  id
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
378
                _ -> pprPanic "tcLookupLocalIds" (ppr name)
379 380

getInLocalScope :: TcM (Name -> Bool)
381 382
getInLocalScope = do { lcl_env <- getLclTypeEnv
                     ; return (`elemNameEnv` lcl_env) }
383

384
tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r
385
-- Used only during kind checking, for TcThings that are
386
--      ATcTyCon or APromotionErr
387
-- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr
388 389
tcExtendKindEnvList things thing_inside
  = do { traceTc "txExtendKindEnvList" (ppr things)
390
       ; updLclEnv upd_env thing_inside }
391 392
  where
    upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things }
dreixel's avatar
dreixel committed
393

394 395 396 397 398 399 400 401
tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r
-- A variant of tcExtendKindEvnList
tcExtendKindEnv extra_env thing_inside
  = do { traceTc "txExtendKindEnv" (ppr extra_env)
       ; updLclEnv upd_env thing_inside }
  where
    upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env }

402 403
-----------------------
-- Scoped type and kind variables
404
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
405
tcExtendTyVarEnv tvs thing_inside
406
  = tcExtendTyVarEnv2 [(tyVarName tv, tv) | tv <- tvs] thing_inside
407

408
tcExtendTyVarEnv2 :: [(Name,TcTyVar)] -> TcM r -> TcM r
409
tcExtendTyVarEnv2 binds thing_inside
410 411
  -- this should be used only for explicitly mentioned scoped variables.
  -- thus, no coercion variables
412
  = do { tc_extend_local_env NotTopLevel
413
                    [(name, ATyVar name tv) | (name, tv) <- binds] $
414 415
         tcExtendBinderStack tv_binds $
         thing_inside }
416
  where
417 418
    tv_binds :: [TcBinder]
    tv_binds = [TcTvBndr name tv | (name,tv) <- binds]
419

420
isTypeClosedLetBndr :: Id -> Bool
421
-- See Note [Bindings with closed types] in TcRnTypes
Richard Eisenberg's avatar
Richard Eisenberg committed
422
isTypeClosedLetBndr = noFreeVarsOfType . idType
423

424 425 426
tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a
-- Used for binding the recurive uses of Ids in a binding
-- both top-level value bindings and and nested let/where-bindings
427
-- Does not extend the TcBinderStack
428 429 430 431 432 433
tcExtendRecIds pairs thing_inside
  = tc_extend_local_env NotTopLevel
          [ (name, ATcId { tct_id   = let_id
                         , tct_info = NonClosedLet emptyNameSet False })
          | (name, let_id) <- pairs ] $
    thing_inside
434

435 436
tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
-- Used for binding the Ids that have a complete user type signature
437
-- Does not extend the TcBinderStack
438
tcExtendSigIds top_lvl sig_ids thing_inside
439
  = tc_extend_local_env top_lvl
440 441 442 443 444 445 446 447 448 449 450
          [ (idName id, ATcId { tct_id   = id
                              , tct_info = info })
          | id <- sig_ids
          , let closed = isTypeClosedLetBndr id
                info   = NonClosedLet emptyNameSet closed ]
     thing_inside


tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed
                  -> [TcId] -> TcM a -> TcM a
-- Used for both top-level value bindings and and nested let/where-bindings
451
-- Adds to the TcBinderStack too
452 453
tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed)
               ids thing_inside
454
  = tcExtendBinderStack [TcIdBndr id top_lvl | id <- ids] $
455 456 457 458
    tc_extend_local_env top_lvl
          [ (idName id, ATcId { tct_id   = id
                              , tct_info = mk_tct_info id })
          | id <- ids ]
459
    thing_inside
460 461 462 463 464 465 466 467 468
  where
    mk_tct_info id
      | type_closed && isEmptyNameSet rhs_fvs = ClosedLet
      | otherwise                             = NonClosedLet rhs_fvs type_closed
      where
        name        = idName id
        rhs_fvs     = lookupNameEnv fvs name `orElse` emptyNameSet
        type_closed = isTypeClosedLetBndr id &&
                      (fv_type_closed || hasCompleteSig sig_fn name)
469

470
tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
471
-- For lambda-bound and case-bound Ids
472
-- Extends the the TcBinderStack as well
Austin Seipp's avatar
Austin Seipp committed
473
tcExtendIdEnv ids thing_inside
474
  = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
475 476

tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
477
-- Exactly like tcExtendIdEnv2, but for a single (name,id) pair
Austin Seipp's avatar
Austin Seipp committed
478
tcExtendIdEnv1 name id thing_inside
479
  = tcExtendIdEnv2 [(name,id)] thing_inside
480 481 482

tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
tcExtendIdEnv2 names_w_ids thing_inside
483 484
  = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel
                        | (_,mono_id) <- names_w_ids ] $
485 486 487 488 489 490 491
    tc_extend_local_env NotTopLevel
            [ (name, ATcId { tct_id = id
                           , tct_info    = NotLetBound })
            | (name,id) <- names_w_ids]
    thing_inside

tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
492
tc_extend_local_env top_lvl extra_env thing_inside
493 494 495 496
-- Precondition: the argument list extra_env has TcTyThings
--               that ATcId or ATyVar, but nothing else
--
-- Invariant: the ATcIds are fully zonked. Reasons:
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
497 498 499 500
--      (a) The kinds of the forall'd type variables are defaulted
--          (see Kind.defaultKind, done in zonkQuantifiedTyVar)
--      (b) There are no via-Indirect occurrences of the bound variables
--          in the types, because instantiation does not look through such things
501
--      (c) The call to tyCoVarsOfTypes is ok without looking through refs
502

thomasw's avatar
thomasw committed
503 504 505
-- The second argument of type TyVarSet is a set of type variables
-- that are bound together with extra_env and should not be regarded
-- as free in the types of extra_env.
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
506
  = do  { traceTc "env2" (ppr extra_env)
507 508
        ; env0 <- getLclEnv
        ; env1 <- tcExtendLocalTypeEnv env0 extra_env
509 510
        ; stage <- getStage
        ; let env2 = extend_local_env (top_lvl, thLevel stage) extra_env env1
511
        ; setLclEnv env2 thing_inside }
512 513 514 515 516 517 518 519 520 521 522 523 524 525
  where
    extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv
    -- Extend the local LocalRdrEnv and Template Haskell staging env simultaneously
    -- Reason for extending LocalRdrEnv: after running a TH splice we need
    -- to do renaming.
    extend_local_env thlvl pairs env@(TcLclEnv { tcl_rdr = rdr_env
                                               , tcl_th_bndrs = th_bndrs })
      = env { tcl_rdr      = extendLocalRdrEnvList rdr_env
                                [ n | (n, _) <- pairs, isInternalName n ]
                                -- The LocalRdrEnv contains only non-top-level names
                                -- (GlobalRdrEnv handles the top level)
            , tcl_th_bndrs = extendNameEnvList th_bndrs  -- We only track Ids in tcl_th_bndrs
                                 [(n, thlvl) | (n, ATcId {}) <- pairs] }

526 527
tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcM TcLclEnv
tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things
528
  | isEmptyVarSet extra_tvs
529
  = return (lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things })
530
  | otherwise
531
  = do { global_tvs <- readMutVar (tcl_tyvars lcl_env)
532
       ; new_g_var  <- newMutVar (global_tvs `unionVarSet` extra_tvs)
533 534
       ; return (lcl_env { tcl_tyvars = new_g_var
                         , tcl_env = extendNameEnvList lcl_type_env tc_ty_things } ) }
535
  where
536
    extra_tvs = foldr get_tvs emptyVarSet tc_ty_things
537

538
    get_tvs (_, ATcId { tct_id = id, tct_info = closed }) tvs
539
      = case closed of
Simon Peyton Jones's avatar
Simon Peyton Jones committed
540 541 542 543 544 545 546 547 548 549 550
          ClosedLet -> ASSERT2( is_closed_type, ppr id $$ ppr (idType id) )
                       tvs
          _other    -> tvs `unionVarSet` id_tvs
        where
           id_tvs = tyCoVarsOfType (idType id)
           is_closed_type = not (anyVarSet isTyVar id_tvs)
           -- We only care about being closed wrt /type/ variables
           -- E.g. a top-level binding might have a type like
           --          foo :: t |> co
           -- where co :: * ~ *
           -- or some other as-yet-unsolved kind coercion
551

552
    get_tvs (_, ATyVar _ tv) tvs          -- See Note [Global TyVars]
553
      = tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv) `extendVarSet` tv
554

555
    get_tvs (_, ATcTyCon tc) tvs = tvs `unionVarSet` tyCoVarsOfType (tyConKind tc)
556

557 558
    get_tvs (_, AGlobal {})       tvs = tvs
    get_tvs (_, APromotionErr {}) tvs = tvs
559

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
560 561 562 563 564 565 566
        -- Note [Global TyVars]
        -- It's important to add the in-scope tyvars to the global tyvar set
        -- as well.  Consider
        --      f (_::r) = let g y = y::r in ...
        -- Here, g mustn't be generalised.  This is also important during
        -- class and instance decls, when we mustn't generalise the class tyvars
        -- when typechecking the methods.
567 568
        --
        -- Nor must we generalise g over any kind variables free in r's kind
569

570

571 572 573 574 575 576 577 578 579
{- *********************************************************************
*                                                                      *
             The TcBinderStack
*                                                                      *
********************************************************************* -}

tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack bndrs thing_inside
  = do { traceTc "tcExtendBinderStack" (ppr bndrs)
580 581 582
       ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env })
                   thing_inside }

583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614
tcInitTidyEnv :: TcM TidyEnv
-- We initialise the "tidy-env", used for tidying types before printing,
-- by building a reverse map from the in-scope type variables to the
-- OccName that the programmer originally used for them
tcInitTidyEnv
  = do  { lcl_env <- getLclEnv
        ; go emptyTidyEnv (tcl_bndrs lcl_env) }
  where
    go (env, subst) []
      = return (env, subst)
    go (env, subst) (b : bs)
      | TcTvBndr name tyvar <- b
       = do { let (env', occ') = tidyOccName env (nameOccName name)
                  name'  = tidyNameOcc name occ'
                  tyvar1 = setTyVarName tyvar name'
            ; tyvar2 <- zonkTcTyVarToTyVar tyvar1
              -- Be sure to zonk here!  Tidying applies to zonked
              -- types, so if we don't zonk we may create an
              -- ill-kinded type (Trac #14175)
            ; go (env', extendVarEnv subst tyvar tyvar2) bs }
      | otherwise
      = go (env, subst) bs

-- | Get a 'TidyEnv' that includes mappings for all vars free in the given
-- type. Useful when tidying open types.
tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
tcInitOpenTidyEnv tvs
  = do { env1 <- tcInitTidyEnv
       ; let env2 = tidyFreeTyCoVars env1 tvs
       ; return env2 }


615

616 617 618 619 620 621
{- *********************************************************************
*                                                                      *
             Adding placeholders
*                                                                      *
********************************************************************* -}

622
tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a
623 624
-- See Note [AFamDataCon: not promoting data family constructors]
tcAddDataFamConPlaceholders inst_decls thing_inside
625 626
  = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE)
                        | lid <- inst_decls, con <- get_cons lid ]
627 628 629 630
      thing_inside
      -- Note [AFamDataCon: not promoting data family constructors]
  where
    -- get_cons extracts the *constructor* bindings of the declaration
631
    get_cons :: LInstDecl GhcRn -> [Name]
632 633 634 635 636
    get_cons (L _ (TyFamInstD {}))                     = []
    get_cons (L _ (DataFamInstD { dfid_inst = fid }))  = get_fi_cons fid
    get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
      = concatMap (get_fi_cons . unLoc) fids

637
    get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
638 639
    get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
                  FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}})
640 641 642
      = map unLoc $ concatMap (getConNames . unLoc) cons


643
tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
644 645
-- See Note [Don't promote pattern synonyms]
tcAddPatSynPlaceholders pat_syns thing_inside
646 647
  = tcExtendKindEnvList [ (name, APromotionErr PatSynPE)
                        | PSB{ psb_id = L _ name } <- pat_syns ]
648 649
       thing_inside

650
getTypeSigNames :: [LSig GhcRn] -> NameSet
651 652 653 654
-- Get the names that have a user type sig
getTypeSigNames sigs
  = foldr get_type_sig emptyNameSet sigs
  where
655
    get_type_sig :: LSig GhcRn -> NameSet -> NameSet
656 657 658
    get_type_sig sig ns =
      case sig of
        L _ (TypeSig names _) -> extendNameSetList ns (map unLoc names)
659
        L _ (PatSynSig names _) -> extendNameSetList ns (map unLoc names)
660 661 662 663 664 665 666 667 668 669 670 671
        _ -> ns


{- Note [AFamDataCon: not promoting data family constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  data family T a
  data instance T Int = MkT
  data Proxy (a :: k)
  data S = MkS (Proxy 'MkT)

Is it ok to use the promoted data family instance constructor 'MkT' in
672 673 674 675
the data declaration for S (where both declarations live in the same module)?
No, we don't allow this. It *might* make sense, but at least it would mean that
we'd have to interleave typechecking instances and data types, whereas at
present we do data types *then* instances.
676 677 678 679 680

So to check for this we put in the TcLclEnv a binding for all the family
constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
type checking 'S' we'll produce a decent error message.

681 682 683
Trac #12088 describes this limitation. Of course, when MkT and S live in
different modules then all is well.

684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711
Note [Don't promote pattern synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We never promote pattern synonyms.

Consider this (Trac #11265):
  pattern A = True
  instance Eq A
We want a civilised error message from the occurrence of 'A'
in the instance, yet 'A' really has not yet been type checked.

Similarly (Trac #9161)
  {-# LANGUAGE PatternSynonyms, DataKinds #-}
  pattern A = ()
  b :: A
  b = undefined
Here, the type signature for b mentions A.  But A is a pattern
synonym, which is typechecked as part of a group of bindings (for very
good reasons; a view pattern in the RHS may mention a value binding).
It is entirely reasonable to reject this, but to do so we need A to be
in the kind environment when kind-checking the signature for B.

Hence tcAddPatSynPlaceholers adds a binding
    A -> APromotionErr PatSynPE
to the environment. Then TcHsType.tcTyVar will find A in the kind
environment, and will give a 'wrongThingErr' as a result.  But the
lookup of A won't fail.


Austin Seipp's avatar
Austin Seipp committed
712 713
************************************************************************
*                                                                      *
714
\subsection{Rules}
Austin Seipp's avatar
Austin Seipp committed
715 716 717
*                                                                      *
************************************************************************
-}
718

719
tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
720 721 722 723
        -- Just pop the new rules into the EPS and envt resp
        -- All the rules come from an interface file, not source
        -- Nevertheless, some may be for this module, if we read
        -- its interface instead of its source code
724 725
tcExtendRules lcl_rules thing_inside
 = do { env <- getGblEnv
726
      ; let
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
727
          env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
728 729
      ; setGblEnv env' thing_inside }

Austin Seipp's avatar
Austin Seipp committed
730 731 732
{-
************************************************************************
*                                                                      *
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
733
                Meta level
Austin Seipp's avatar
Austin Seipp committed
734 735 736
*                                                                      *
************************************************************************
-}
737

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
738 739 740 741
checkWellStaged :: SDoc         -- What the stage check is for
                -> ThLevel      -- Binding level (increases inside brackets)
                -> ThLevel      -- Use stage
                -> TcM ()       -- Fail if badly staged, adding an error
742
checkWellStaged pp_thing bind_lvl use_lvl
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
743 744
  | use_lvl >= bind_lvl         -- OK! Used later than bound
  = return ()                   -- E.g.  \x -> [| $(f x) |]
745

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
746
  | bind_lvl == outerLevel      -- GHC restriction on top level splices
747
  = stageRestrictionError pp_thing
748

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
749 750
  | otherwise                   -- Badly staged
  = failWithTc $                -- E.g.  \x -> $(f x)
751 752 753
    text "Stage error:" <+> pp_thing <+>
        hsep   [text "is bound at stage" <+> ppr bind_lvl,
                text "but used at stage" <+> ppr use_lvl]
754

755 756
stageRestrictionError :: SDoc -> TcM a
stageRestrictionError pp_thing
Austin Seipp's avatar
Austin Seipp committed
757
  = failWithTc $
758 759 760
    sep [ text "GHC stage restriction:"
        , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation,"
                       , text "and must be imported, not defined locally"])]
761

762
topIdLvl :: Id -> ThLevel
Austin Seipp's avatar
Austin Seipp committed
763
-- Globals may either be imported, or may be from an earlier "chunk"
764
-- (separated by declaration splices) of this module.  The former
765
--  *can* be used inside a top-level splice, but the latter cannot.
766 767
-- Hence we give the former impLevel, but the latter topLevel
-- E.g. this is bad:
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
768 769
--      x = [| foo |]
--      $( f x )
Austin Seipp's avatar
Austin Seipp committed
770
-- By the time we are prcessing the $(f x), the binding for "x"
771
-- will be in the global env, not the local one.
772
topIdLvl id | isLocalId id = outerLevel
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
773
            | otherwise    = impLevel
774 775

tcMetaTy :: Name -> TcM Type
Austin Seipp's avatar
Austin Seipp committed
776
-- Given the name of a Template Haskell data type,
777 778
-- return the type
-- E.g. given the name "Expr" return the type "Expr"
779 780 781
tcMetaTy tc_name = do
    t <- tcLookupTyCon tc_name
    return (mkTyConApp t [])
782

783 784 785
isBrackStage :: ThStage -> Bool
isBrackStage (Brack {}) = True
isBrackStage _other     = False
786

Austin Seipp's avatar
Austin Seipp committed
787 788 789 790 791 792 793
{-
************************************************************************
*                                                                      *
                 getDefaultTys
*                                                                      *
************************************************************************
-}
794

795
tcGetDefaultTys :: TcM ([Type], -- Default types
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
796
                        (Bool,  -- True <=> Use overloaded strings
797
                         Bool)) -- True <=> Use extended defaulting rules
798
tcGetDefaultTys
799
  = do  { dflags <- getDynFlags
800 801
        ; let ovl_strings = xopt LangExt.OverloadedStrings dflags
              extended_defaults = xopt LangExt.ExtendedDefaultRules dflags
Austin Seipp's avatar
Austin Seipp committed
802
                                        -- See also Trac #1974
803
              flags = (ovl_strings, extended_defaults)
Austin Seipp's avatar
Austin Seipp committed
804

805
        ; mb_defaults <- getDeclaredDefaultTys
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
806 807 808 809 810 811 812 813
        ; case mb_defaults of {
           Just tys -> return (tys, flags) ;
                                -- User-supplied defaults
           Nothing  -> do

        -- No use-supplied default
        -- Use [Integer, Double], plus modifications
        { integer_ty <- tcMetaTy integerTyConName
814
        ; list_ty <- tcMetaTy listTyConName
815
        ; checkWiredInTyCon doubleTyCon
816 817
        ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty]
                          -- Note [Extended defaults]
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
818
                          ++ [integer_ty, doubleTy]
819
                          ++ opt_deflt ovl_strings [stringTy]
820 821
        ; return (deflt_tys, flags) } } }
  where
822
    opt_deflt True  xs = xs
823 824
    opt_deflt False _  = []

Austin Seipp's avatar
Austin Seipp committed
825
{-