From 2c1ea2cedb1a8034b0828e24b554a35f56bb8924 Mon Sep 17 00:00:00 2001 From: Lemmih Date: Tue, 18 Apr 2006 02:36:06 +0000 Subject: [PATCH] Make the initial rdr and type scope available in the ghc-api. --- compiler/main/GHC.hs | 36 ++++++++++++++++++++++++++++++++++-- compiler/main/HscMain.lhs | 7 +++++-- compiler/main/HscTypes.lhs | 4 +++- compiler/typecheck/TcRnDriver.lhs | 4 ++-- compiler/typecheck/TcRnMonad.lhs | 4 ++-- 5 files changed, 46 insertions(+), 9 deletions(-) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 3f91af6..4e00c61 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -29,6 +29,12 @@ module GHC ( removeTarget, guessTarget, + -- * Extending the program scope + extendGlobalRdrScope, -- :: Session -> [GlobalRdrElt] -> IO () + setGlobalRdrScope, -- :: Session -> [GlobalRdrElt] -> IO () + extendGlobalTypeScope, -- :: Session -> [Id] -> IO () + setGlobalTypeScope, -- :: Session -> [Id] -> IO () + -- * Loading\/compiling the program depanal, load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal @@ -169,7 +175,7 @@ import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo, tcRnLookupName, getModuleExports ) import RdrName ( plusGlobalRdrEnv, Provenance(..), ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), - emptyGlobalRdrEnv, mkGlobalRdrEnv ) + mkGlobalRdrEnv ) import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType ) import Type ( tidyType ) import VarEnv ( emptyTidyEnv ) @@ -179,7 +185,8 @@ import GHC.Exts ( unsafeCoerce# ) import Packages ( initPackages ) import NameSet ( NameSet, nameSetToList, elemNameSet ) import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..), - globalRdrEnvElts ) + globalRdrEnvElts, extendGlobalRdrEnv, + emptyGlobalRdrEnv ) import HsSyn import Type ( Kind, Type, dropForAlls, PredType, ThetaType, pprThetaArrow, pprParendType, splitForAllTys, @@ -447,6 +454,31 @@ guessTarget file Nothing lhs_file = file `joinFileExt` "lhs" -- ----------------------------------------------------------------------------- +-- Extending the program scope + +extendGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO () +extendGlobalRdrScope session rdrElts + = modifySession session $ \hscEnv -> + let global_rdr = hsc_global_rdr_env hscEnv + in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts } + +setGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO () +setGlobalRdrScope session rdrElts + = modifySession session $ \hscEnv -> + hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts } + +extendGlobalTypeScope :: Session -> [Id] -> IO () +extendGlobalTypeScope session ids + = modifySession session $ \hscEnv -> + let global_type = hsc_global_type_env hscEnv + in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids } + +setGlobalTypeScope :: Session -> [Id] -> IO () +setGlobalTypeScope session ids + = modifySession session $ \hscEnv -> + hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids } + +-- ----------------------------------------------------------------------------- -- Loading the program -- Perform a dependency analysis starting from the current targets diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index e170f8f..986d2ce 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -47,7 +47,7 @@ import VarEnv ( emptyTidyEnv ) import Var ( Id ) import Module ( emptyModuleEnv, ModLocation(..) ) -import RdrName ( GlobalRdrEnv, RdrName ) +import RdrName ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv ) import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl ) import SrcLoc ( Located(..) ) import StringBuffer ( hGetStringBuffer, stringToStringBuffer ) @@ -74,6 +74,7 @@ import SimplStg ( stg2stg ) import CodeGen ( codeGen ) import CmmParse ( parseCmmFile ) import CodeOutput ( codeOutput ) +import NameEnv ( emptyNameEnv ) import DynFlags import ErrUtils @@ -114,7 +115,9 @@ newHscEnv dflags hsc_HPT = emptyHomePackageTable, hsc_EPS = eps_var, hsc_NC = nc_var, - hsc_FC = fc_var } ) } + hsc_FC = fc_var, + hsc_global_rdr_env = emptyGlobalRdrEnv, + hsc_global_type_env = emptyNameEnv } ) } knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index ee5438b..c46d78e 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -172,9 +172,11 @@ data HscEnv -- sucking in interface files. They cache the state of -- external interface files, in effect. - hsc_FC :: {-# UNPACK #-} !(IORef FinderCache) + hsc_FC :: {-# UNPACK #-} !(IORef FinderCache), -- The finder's cache. This caches the location of modules, -- so we don't have to search the filesystem multiple times. + hsc_global_rdr_env :: GlobalRdrEnv, + hsc_global_type_env :: TypeEnv } hscEPS :: HscEnv -> IO ExternalPackageState diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 5f4b487..347d38b 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -64,7 +64,7 @@ import ErrUtils ( Messages, mkDumpDoc, showPass ) import Id ( Id, mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) import Module ( Module, ModuleEnv, moduleEnvElts, elemModuleEnv ) -import OccName ( mkVarOccFS ) +import OccName ( mkVarOccFS, plusOccEnv ) import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName, mkExternalName, isInternalName ) import NameSet @@ -188,7 +188,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- Update the gbl env updGblEnv ( \ gbl -> - gbl { tcg_rdr_env = rdr_env, + gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, tcg_imports = tcg_imports gbl `plusImportAvails` imports, tcg_rn_imports = if save_rn_syntax then diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index ff1979b..4fa3d8d 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -96,10 +96,10 @@ initTc hsc_env hsc_src mod do_this gbl_env = TcGblEnv { tcg_mod = mod, tcg_src = hsc_src, - tcg_rdr_env = emptyGlobalRdrEnv, + tcg_rdr_env = hsc_global_rdr_env hsc_env, tcg_fix_env = emptyNameEnv, tcg_default = Nothing, - tcg_type_env = emptyNameEnv, + tcg_type_env = hsc_global_type_env hsc_env, tcg_type_env_var = type_env_var, tcg_inst_env = emptyInstEnv, tcg_inst_uses = dfuns_var, -- 1.7.10.4