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