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