ghc/compiler/typecheck/TcEnv.lhs

   1 \begin{code}
   2 module TcEnv(
   3         TcId, TcIdSet,
   4         TyThing(..), TyThingDetails(..), TcTyThing(..),
   5
   6         -- Getting stuff from the environment
   7         TcEnv, initTcEnv,
   8         tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars,
   9         getTcGST, getTcGEnv,
  10
  11         -- Instance environment
  12         tcGetInstEnv, tcSetInstEnv,
  13
  14         -- Global environment
  15         tcExtendGlobalEnv, tcExtendGlobalValEnv,
  16         tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
  17         tcLookupGlobal_maybe, tcLookupGlobal,
  18
  19         -- Local environment
  20         tcExtendKindEnv,
  21         tcExtendTyVarEnv, tcExtendTyVarEnvForMeths,
  22         tcExtendLocalValEnv, tcLookup,
  23
  24         -- Global type variables
  25         tcGetGlobalTyVars, tcExtendGlobalTyVars,
  26
  27         -- Random useful things
  28         tcAddImportedIdInfo, tcInstId,
  29
  30         -- New Ids
  31         newLocalId, newSpecPragmaId,
  32         newDefaultMethodName, newDFunName,
  33
  34         -- ???
  35         tcSetEnv, explicitLookupId
  36   ) where
  37
  38 #include "HsVersions.h"
  39
  40 import TcMonad
  41 import TcType           ( TcKind,  TcType, TcTyVar, TcTyVarSet, TcThetaType,
  42                           tcInstTyVars, zonkTcTyVars,
  43                         )
  44 import Id               ( mkUserLocal, isDataConWrapId_maybe )
  45 import IdInfo           ( vanillaIdInfo )
  46 import MkId             ( mkSpecPragmaId )
  47 import Var              ( TyVar, Id, setVarName,
  48                           idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
  49                         )
  50 import VarSet
  51 import Type             ( Kind, Type, superKind,
  52                           tyVarsOfType, tyVarsOfTypes,
  53                           splitForAllTys, splitRhoTy, splitFunTys,
  54                           splitAlgTyConApp_maybe, getTyVar, getDFunTyKey
  55                         )
  56 import DataCon          ( DataCon )
  57 import TyCon            ( TyCon, tyConKind, tyConArity, isSynTyCon )
  58 import Class            ( Class, ClassOpItem, ClassContext, classTyCon )
  59 import Subst            ( substTy )
  60 import Name             ( Name, OccName, NamedThing(..),
  61                           nameOccName, nameModule, getSrcLoc, mkGlobalName,
  62                           isLocallyDefined,
  63                           NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts,
  64                           extendNameEnv, extendNameEnvList
  65                         )
  66 import OccName          ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
  67 import Module           ( Module )
  68 import HscTypes         ( ModDetails(..), InstEnv, lookupTypeEnv, TyThing(..),
  69                           GlobalSymbolTable, Provenance(..) )
  70 import Unique           ( pprUnique10, Unique, Uniquable(..) )
  71 import UniqFM
  72 import Unique           ( Uniquable(..) )
  73 import Util             ( zipEqual, zipWith3Equal, mapAccumL )
  74 import SrcLoc           ( SrcLoc )
  75 import FastString       ( FastString )
  76 import Outputable
  77 import TcInstUtil       ( emptyInstEnv )
  78
  79 import IOExts           ( newIORef )
  80 \end{code}
  81
  82 %************************************************************************
  83 %*                                                                      *
  84 \subsection{TcEnv}
  85 %*                                                                      *
  86 %************************************************************************
  87
  88 \begin{code}
  89 type TcId    = Id                       -- Type may be a TcType
  90 type TcIdSet = IdSet
  91
  92 data TcEnv
  93   = TcEnv {
  94         tcGST    :: GlobalSymbolTable,  -- The symbol table at the moment we began this compilation
  95
  96         tcInsts  :: InstEnv,            -- All instances (both imported and in this module)
  97
  98         tcGEnv   :: NameEnv TyThing,    -- The global type environment we've accumulated while
  99                     {- TypeEnv -}       -- compiling this module:
 100                                         --      types and classes (both imported and local)
 101                                         --      imported Ids
 102                                         -- (Ids defined in this module are in the local envt)
 103
 104         tcLEnv   :: NameEnv TcTyThing,  -- The local type environment: Ids and TyVars
 105                                         -- defined in this module
 106
 107         tcTyVars :: TcRef TcTyVarSet    -- The "global tyvars"
 108                                         -- Namely, the in-scope TyVars bound in tcLEnv, plus the tyvars
 109                                         -- mentioned in the types of Ids bound in tcLEnv
 110                                         -- Why mutable? see notes with tcGetGlobalTyVars
 111     }
 112
 113 \end{code}
 114
 115 The Global-Env/Local-Env story
 116 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 117 During type checking, we keep in the GlobalEnv
 118         * All types and classes
 119         * All Ids derived from types and classes (constructors, selectors)
 120         * Imported Ids
 121
 122 At the end of type checking, we zonk the local bindings,
 123 and as we do so we add to the GlobalEnv
 124         * Locally defined top-level Ids
 125
 126 Why?  Because they are now Ids not TcIds.  This final GlobalEnv is
 127 used thus:
 128         a) fed back (via the knot) to typechecking the
 129            unfoldings of interface signatures
 130
 131         b) used to augment the GlobalSymbolTable
 132
 133
 134 \begin{code}
 135 data TcTyThing
 136   = AGlobal TyThing     -- Used only in the return type of a lookup
 137   | ATcId  TcId         -- Ids defined in this module
 138   | ATyVar TyVar        -- Type variables
 139   | AThing TcKind       -- Used temporarily, during kind checking
 140 -- Here's an example of how the AThing guy is used
 141 -- Suppose we are checking (forall a. T a Int):
 142 --      1. We first bind (a -> AThink kv), where kv is a kind variable.
 143 --      2. Then we kind-check the (T a Int) part.
 144 --      3. Then we zonk the kind variable.
 145 --      4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
 146
 147 initTcEnv :: GlobalSymbolTable -> IO TcEnv
 148 initTcEnv gst
 149   = do { gtv_var <- newIORef emptyVarSet ;
 150          return (TcEnv { tcGST    = gst,
 151                          tcGEnv   = emptyNameEnv,
 152                          tcInsts  = emptyInstEnv,
 153                          tcLEnv   = emptyNameEnv,
 154                          tcTyVars = gtv_var
 155          })}
 156
 157 tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)]
 158 tcEnvTyCons  env = [tc | ATyCon tc <- nameEnvElts (tcGEnv env)]
 159 tcEnvIds     env = [id | AnId   id <- nameEnvElts (tcGEnv env)]
 160 tcEnvTyVars  env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)]
 161 tcEnvTcIds   env = [id | ATcId  id <- nameEnvElts (tcLEnv env)]
 162
 163 getTcGST  (TcEnv { tcGST = gst })   = gst
 164 getTcGEnv (TcEnv { tcGEnv = genv }) = genv
 165
 166 -- This data type is used to help tie the knot
 167 -- when type checking type and class declarations
 168 data TyThingDetails = SynTyDetails Type
 169                     | DataTyDetails ClassContext [DataCon] [Class]
 170                     | ClassDetails ClassContext [Id] [ClassOpItem] DataCon
 171 \end{code}
 172
 173
 174 %************************************************************************
 175 %*                                                                      *
 176 \subsection{Basic lookups}
 177 %*                                                                      *
 178 %************************************************************************
 179
 180 \begin{code}
 181 lookup_global :: TcEnv -> Name -> Maybe TyThing
 182         -- Try the global envt and then the global symbol table
 183 lookup_global env name
 184   = case lookupNameEnv (tcGEnv env) name of
 185         Just thing -> Just thing
 186         Nothing    -> lookupTypeEnv (tcGST env) name
 187
 188 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
 189         -- Try the local envt and then try the global
 190 lookup_local env name
 191   = case lookupNameEnv (tcLEnv env) name of
 192         Just thing -> Just thing
 193         Nothing    -> case lookup_global env name of
 194                         Just thing -> Just (AGlobal thing)
 195                         Nothing    -> Nothing
 196
 197 explicitLookupId :: TcEnv -> Name -> Maybe Id
 198 explicitLookupId env name = case lookup_global env name of
 199                                 Just (AnId id) -> Just id
 200                                 other          -> Nothing
 201 \end{code}
 202
 203
 204 %************************************************************************
 205 %*                                                                      *
 206 \subsection{Random useful functions}
 207 %*                                                                      *
 208 %************************************************************************
 209
 210
 211 \begin{code}
 212 -- A useful function that takes an occurrence of a global thing
 213 -- and instantiates its type with fresh type variables
 214 tcInstId :: Id
 215          -> NF_TcM ([TcTyVar],  -- It's instantiated type
 216                       TcThetaType,      --
 217                       TcType)           --
 218 tcInstId id
 219   = let
 220       (tyvars, rho) = splitForAllTys (idType id)
 221     in
 222     tcInstTyVars tyvars         `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
 223     let
 224         rho'           = substTy tenv rho
 225         (theta', tau') = splitRhoTy rho'
 226     in
 227     returnNF_Tc (tyvars', theta', tau')
 228
 229 tcAddImportedIdInfo :: TcEnv -> Id -> Id
 230 tcAddImportedIdInfo unf_env id
 231   | isLocallyDefined id         -- Don't look up locally defined Ids, because they
 232                                 -- have explicit local definitions, so we get a black hole!
 233   = id
 234   | otherwise
 235   = id `lazySetIdInfo` new_info
 236         -- The Id must be returned without a data dependency on maybe_id
 237   where
 238     new_info = case explicitLookupId unf_env (getName id) of
 239                      Nothing          -> vanillaIdInfo
 240                      Just imported_id -> idInfo imported_id
 241                 -- ToDo: could check that types are the same
 242 \end{code}
 243
 244
 245 %************************************************************************
 246 %*                                                                      *
 247 \subsection{Making new Ids}
 248 %*                                                                      *
 249 %************************************************************************
 250
 251 Constructing new Ids
 252
 253 \begin{code}
 254 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId
 255 newLocalId name ty loc
 256   = tcGetUnique         `thenNF_Tc` \ uniq ->
 257     returnNF_Tc (mkUserLocal name uniq ty loc)
 258
 259 newSpecPragmaId :: Name -> TcType -> NF_TcM TcId
 260 newSpecPragmaId name ty
 261   = tcGetUnique         `thenNF_Tc` \ uniq ->
 262     returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
 263 \end{code}
 264
 265 Make a name for the dict fun for an instance decl
 266
 267 \begin{code}
 268 newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM Name
 269 newDFunName mod clas (ty:_) loc
 270   = tcGetDFunUniq dfun_string   `thenNF_Tc` \ inst_uniq ->
 271     tcGetUnique                 `thenNF_Tc` \ uniq ->
 272     returnNF_Tc (mkGlobalName uniq mod
 273                               (mkDFunOcc dfun_string inst_uniq)
 274                               loc)
 275   where
 276         -- Any string that is somewhat unique will do
 277     dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
 278
 279 newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name
 280 newDefaultMethodName op_name loc
 281   = tcGetUnique                 `thenNF_Tc` \ uniq ->
 282     returnNF_Tc (mkGlobalName uniq (nameModule op_name)
 283                               (mkDefaultMethodOcc (getOccName op_name))
 284                               loc)
 285 \end{code}
 286
 287
 288 %************************************************************************
 289 %*                                                                      *
 290 \subsection{The global environment}
 291 %*                                                                      *
 292 %************************************************************************
 293
 294 \begin{code}
 295 tcExtendGlobalEnv :: [(Name, TyThing)] -> TcM r -> TcM r
 296 tcExtendGlobalEnv bindings thing_inside
 297   = tcGetEnv                            `thenNF_Tc` \ env ->
 298     let
 299         ge' = extendNameEnvList (tcGEnv env) bindings
 300     in
 301     tcSetEnv (env {tcGEnv = ge'}) thing_inside
 302
 303 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
 304 tcExtendGlobalValEnv ids thing_inside
 305   = tcExtendGlobalEnv [(getName id, AnId id) | id <- ids] thing_inside
 306 \end{code}
 307
 308
 309 \begin{code}
 310 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
 311 tcLookupGlobal_maybe name
 312   = tcGetEnv            `thenNF_Tc` \ env ->
 313     returnNF_Tc (lookup_global env name)
 314 \end{code}
 315
 316 A variety of global lookups, when we know what we are looking for.
 317
 318 \begin{code}
 319 tcLookupGlobal :: Name -> NF_TcM TyThing
 320 tcLookupGlobal name
 321   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_thing ->
 322     case maybe_thing of
 323         Just thing -> returnNF_Tc thing
 324         other      -> notFound "tcLookupGlobal:" name
 325
 326 tcLookupGlobalId :: Name -> NF_TcM Id
 327 tcLookupGlobalId name
 328   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_id ->
 329     case maybe_id of
 330         Just (AnId clas) -> returnNF_Tc clas
 331         other            -> notFound "tcLookupGlobalId:" name
 332
 333 tcLookupDataCon :: Name -> TcM DataCon
 334 tcLookupDataCon con_name
 335   = tcLookupGlobalId con_name           `thenNF_Tc` \ con_id ->
 336     case isDataConWrapId_maybe con_id of
 337         Just data_con -> returnTc data_con
 338         Nothing       -> failWithTc (badCon con_id)
 339
 340
 341 tcLookupClass :: Name -> NF_TcM Class
 342 tcLookupClass name
 343   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_clas ->
 344     case maybe_clas of
 345         Just (AClass clas) -> returnNF_Tc clas
 346         other              -> notFound "tcLookupClass:" name
 347
 348 tcLookupTyCon :: Name -> NF_TcM TyCon
 349 tcLookupTyCon name
 350   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_tc ->
 351     case maybe_tc of
 352         Just (ATyCon tc) -> returnNF_Tc tc
 353         other            -> notFound "tcLookupTyCon:" name
 354 \end{code}
 355
 356
 357 %************************************************************************
 358 %*                                                                      *
 359 \subsection{The local environment}
 360 %*                                                                      *
 361 %************************************************************************
 362
 363 \begin{code}
 364 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
 365 tcLookup_maybe name
 366   = tcGetEnv            `thenNF_Tc` \ env ->
 367     returnNF_Tc (lookup_local env name)
 368
 369 tcLookup :: Name -> NF_TcM TcTyThing
 370 tcLookup name
 371   = tcLookup_maybe name         `thenNF_Tc` \ maybe_thing ->
 372     case maybe_thing of
 373         Just thing -> returnNF_Tc thing
 374         other      -> notFound "tcLookup:" name
 375         -- Extract the IdInfo from an IfaceSig imported from an interface file
 376 \end{code}
 377
 378
 379 \begin{code}
 380 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
 381 tcExtendKindEnv pairs thing_inside
 382   = tcGetEnv                            `thenNF_Tc` \ env ->
 383     let
 384         le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
 385         -- No need to extend global tyvars for kind checking
 386     in
 387     tcSetEnv (env {tcLEnv = le'}) thing_inside
 388
 389 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
 390 tcExtendTyVarEnv tyvars thing_inside
 391   = tcGetEnv                    `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
 392     let
 393         le'        = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
 394         new_tv_set = mkVarSet tyvars
 395     in
 396         -- It's important to add the in-scope tyvars to the global tyvar set
 397         -- as well.  Consider
 398         --      f (x::r) = let g y = y::r in ...
 399         -- Here, g mustn't be generalised.  This is also important during
 400         -- class and instance decls, when we mustn't generalise the class tyvars
 401         -- when typechecking the methods.
 402     tc_extend_gtvs gtvs new_tv_set              `thenNF_Tc` \ gtvs' ->
 403     tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
 404
 405 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
 406 --      the signature tyvars contain the original names
 407 --      the instance  tyvars are what those names should be mapped to
 408 -- It's needed when typechecking the method bindings of class and instance decls
 409 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
 410
 411 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
 412 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
 413   = tcGetEnv                                    `thenNF_Tc` \ env ->
 414     let
 415         le'   = extendNameEnvList (tcLEnv env) stuff
 416         stuff = [ (getName sig_tv, ATyVar inst_tv)
 417                 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
 418                 ]
 419     in
 420     tcSetEnv (env {tcLEnv = le'}) thing_inside
 421 \end{code}
 422
 423
 424 \begin{code}
 425 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
 426 tcExtendLocalValEnv names_w_ids thing_inside
 427   = tcGetEnv            `thenNF_Tc` \ env ->
 428     let
 429         extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
 430         extra_env           = [(name, ATcId id) | (name,id) <- names_w_ids]
 431         le'                 = extendNameEnvList (tcLEnv env) extra_env
 432     in
 433     tc_extend_gtvs (tcTyVars env) extra_global_tyvars   `thenNF_Tc` \ gtvs' ->
 434     tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
 435 \end{code}
 436
 437
 438 %************************************************************************
 439 %*                                                                      *
 440 \subsection{The global tyvars}
 441 %*                                                                      *
 442 %************************************************************************
 443
 444 \begin{code}
 445 tcExtendGlobalTyVars extra_global_tvs thing_inside
 446   = tcGetEnv                                            `thenNF_Tc` \ env ->
 447     tc_extend_gtvs (tcTyVars env) extra_global_tvs      `thenNF_Tc` \ gtvs' ->
 448     tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
 449
 450 tc_extend_gtvs gtvs extra_global_tvs
 451   = tcReadMutVar gtvs                   `thenNF_Tc` \ global_tvs ->
 452     tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
 453 \end{code}
 454
 455 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
 456 To improve subsequent calls to the same function it writes the zonked set back into
 457 the environment.
 458
 459 \begin{code}
 460 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
 461 tcGetGlobalTyVars
 462   = tcGetEnv                                    `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
 463     tcReadMutVar gtv_var                        `thenNF_Tc` \ global_tvs ->
 464     zonkTcTyVars (varSetElems global_tvs)       `thenNF_Tc` \ global_tys' ->
 465     let
 466         global_tvs' = (tyVarsOfTypes global_tys')
 467     in
 468     tcWriteMutVar gtv_var global_tvs'           `thenNF_Tc_`
 469     returnNF_Tc global_tvs'
 470 \end{code}
 471
 472
 473 %************************************************************************
 474 %*                                                                      *
 475 \subsection{The instance environment}
 476 %*                                                                      *
 477 %************************************************************************
 478
 479 \begin{code}
 480 tcGetInstEnv :: NF_TcM InstEnv
 481 tcGetInstEnv = tcGetEnv         `thenNF_Tc` \ env ->
 482                returnNF_Tc (tcInsts env)
 483
 484 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
 485 tcSetInstEnv ie thing_inside
 486   = tcGetEnv    `thenNF_Tc` \ env ->
 487     tcSetEnv (env {tcInsts = ie}) thing_inside
 488 \end{code}
 489
 490
 491 %************************************************************************
 492 %*                                                                      *
 493 \subsection{Errors}
 494 %*                                                                      *
 495 %************************************************************************
 496
 497 \begin{code}
 498 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
 499
 500 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
 501                                   ptext SLIT("is not in scope"))
 502 \end{code}