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