diff options
| -rw-r--r-- | compiler/ghci/Linker.lhs | 9 | ||||
| -rw-r--r-- | compiler/main/CodeOutput.lhs | 4 | ||||
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 7 | ||||
| -rw-r--r-- | compiler/main/Finder.lhs | 8 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 4 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 5 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 5 | ||||
| -rw-r--r-- | compiler/main/Packages.lhs | 95 | ||||
| -rw-r--r-- | ghc/InteractiveUI.hs | 23 |
9 files changed, 88 insertions, 72 deletions
diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 013918c13f..40b83bbbae 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -59,7 +59,6 @@ import Control.Monad import Data.IORef import Data.List -import qualified Data.Map as Map import Control.Concurrent.MVar import System.FilePath @@ -1067,9 +1066,6 @@ linkPackages' dflags new_pks pls = do pkgs' <- link (pkgs_loaded pls) new_pks return $! pls { pkgs_loaded = pkgs' } where - pkg_map = pkgIdMap (pkgState dflags) - ipid_map = installedPackageIdMap (pkgState dflags) - link :: [PackageKey] -> [PackageKey] -> IO [PackageKey] link pkgs new_pkgs = foldM link_one pkgs new_pkgs @@ -1078,10 +1074,9 @@ linkPackages' dflags new_pks pls = do | new_pkg `elem` pkgs -- Already linked = return pkgs - | Just pkg_cfg <- lookupPackage pkg_map new_pkg + | Just pkg_cfg <- lookupPackage dflags new_pkg = do { -- Link dependents first - pkgs' <- link pkgs [ Maybes.expectJust "link_one" $ - Map.lookup ipid ipid_map + pkgs' <- link pkgs [ resolveInstalledPackageId dflags ipid | ipid <- depends pkg_cfg ] -- Now link the package itself ; linkPackage dflags pkg_cfg diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index 11a8a8ec32..7a554f4d20 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -115,7 +115,7 @@ outputC dflags filenm cmm_stream packages -- * -#include options from the cmdline and OPTIONS pragmas -- * the _stub.h file, if there is one. -- - let rts = getPackageDetails (pkgState dflags) rtsPackageKey + let rts = getPackageDetails dflags rtsPackageKey let cc_injects = unlines (map mk_include (includes rts)) mk_include h_file = @@ -210,7 +210,7 @@ outputForeignStubs dflags mod location stubs -- we need the #includes from the rts package for the stub files let rts_includes = - let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageKey in + let rts_pkg = getPackageDetails dflags rtsPackageKey in concatMap mk_include (includes rts_pkg) mk_include i = "#include \"" ++ i ++ "\"\n" diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index f33c9b54e7..f7b5eb8782 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -411,9 +411,8 @@ linkingNeeded dflags staticLink linkables pkg_deps = do -- next, check libraries. XXX this only checks Haskell libraries, -- not extra_libraries or -l things from the command line. - let pkg_map = pkgIdMap (pkgState dflags) - pkg_hslibs = [ (libraryDirs c, lib) - | Just c <- map (lookupPackage pkg_map) pkg_deps, + let pkg_hslibs = [ (libraryDirs c, lib) + | Just c <- map (lookupPackage dflags) pkg_deps, lib <- packageHsLibs dflags c ] pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs @@ -1559,7 +1558,7 @@ mkExtraObj dflags extn xs = do cFile <- newTempName dflags extn oFile <- newTempName dflags "o" writeFile cFile xs - let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageKey + let rtsDetails = getPackageDetails dflags rtsPackageKey SysTools.runCc dflags ([Option "-c", FileOption "" cFile, diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index ded85140fd..ec7dc53ba5 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -301,9 +301,8 @@ findPackageModule hsc_env mod = do let dflags = hsc_dflags hsc_env pkg_id = modulePackageKey mod - pkg_map = pkgIdMap (pkgState dflags) -- - case lookupPackage pkg_map pkg_id of + case lookupPackage dflags pkg_id of Nothing -> return (NoPackage pkg_id) Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf @@ -562,9 +561,6 @@ cantFindErr cannot_find _ dflags mod_name find_result = ptext cannot_find <+> quotes (ppr mod_name) $$ more_info where - pkg_map :: PackageConfigMap - pkg_map = pkgIdMap (pkgState dflags) - more_info = case find_result of NoPackage pkg @@ -640,7 +636,7 @@ cantFindErr cannot_find _ dflags mod_name find_result where (exposed_sugs, hidden_sugs) = partition from_exposed_pkg sugs - from_exposed_pkg m = case lookupPackage pkg_map (modulePackageKey m) of + from_exposed_pkg m = case lookupPackage dflags (modulePackageKey m) of Just pkg_config -> exposed pkg_config Nothing -> WARN( True, ppr m ) -- Should not happen False diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 4933a54cdc..9ab52ebf1d 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -81,7 +81,7 @@ module GHC ( SafeHaskellMode(..), -- * Querying the environment - packageDbModules, + -- packageDbModules, -- * Printing PrintUnqualified, alwaysQualify, @@ -1167,6 +1167,7 @@ getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) -- ----------------------------------------------------------------------------- +{- ToDo: Move the primary logic here to compiler/main/Packages.lhs -- | Return all /external/ modules available in the package database. -- Modules from the current session (i.e., from the 'HomePackageTable') are -- not included. This includes module names which are reexported by packages. @@ -1183,6 +1184,7 @@ packageDbModules only_exposed = do , let pid = packageConfigId p , modname <- exposedModules p ++ map exportName (reexportedModules p) ] + -} -- ----------------------------------------------------------------------------- -- Misc exported utils diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 8710297fd4..89c84f6596 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -962,8 +962,7 @@ hscCheckSafe' dflags m l = do packageTrusted Sf_Safe False _ = True packageTrusted _ _ m | isHomePkg m = True - | otherwise = trusted $ getPackageDetails (pkgState dflags) - (modulePackageKey m) + | otherwise = trusted $ getPackageDetails dflags (modulePackageKey m) lookup' :: Module -> Hsc (Maybe ModIface) lookup' m = do @@ -999,7 +998,7 @@ checkPkgTrust dflags pkgs = where errors = catMaybes $ map go pkgs go pkg - | trusted $ getPackageDetails (pkgState dflags) pkg + | trusted $ getPackageDetails dflags pkg = Nothing | otherwise = Just $ mkErrMsg dflags noSrcSpan (pkgQual dflags) diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index e0d11e4ef2..35bab9fe9f 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -1490,15 +1490,14 @@ mkQualPackage dflags pkg_key -- Skip the lookup if it's main, since it won't be in the package -- database! = False - | filter ((pkgid ==) . sourcePackageId) - (eltsUFM (pkgIdMap (pkgState dflags))) `lengthIs` 1 + | searchPackageId dflags pkgid `lengthIs` 1 -- this says: we are given a package pkg-0.1@MMM, are there only one -- exposed packages whose package ID is pkg-0.1? = False | otherwise = True where pkg = fromMaybe (pprPanic "qual_pkg" (ftext (packageKeyFS pkg_key))) - (lookupPackage (pkgIdMap (pkgState dflags)) pkg_key) + (lookupPackage dflags pkg_key) pkgid = sourcePackageId pkg \end{code} diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 93b566fb0e..f59fbc38e7 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -8,16 +8,20 @@ module Packages ( module PackageConfig, - -- * The PackageConfigMap - PackageConfigMap, emptyPackageConfigMap, lookupPackage, - extendPackageConfigMap, dumpPackages, simpleDumpPackages, - -- * Reading the package config, and processing cmdline args - PackageState(..), + PackageState(preloadPackages), ModuleConf(..), initPackages, + + -- * Querying the package config + lookupPackage, + resolveInstalledPackageId, + searchPackageId, + dumpPackages, + simpleDumpPackages, getPackageDetails, lookupModuleInAllPackages, lookupModuleWithSuggestions, + listVisibleModuleNames, -- * Inspecting the set of packages in scope getPackageIncludePath, @@ -144,8 +148,9 @@ data ModuleConf = ModConf { -- | Map from 'PackageId' (used for documentation) type PackageIdMap = UniqFM --- | Map from 'Module' to 'PackageId' to 'ModuleConf', see 'moduleToPkgConfAll' -type ModuleToPkgConfAll = UniqFM (PackageIdMap ModuleConf) +-- | Map from 'ModuleName' to 'PackageId' to 'ModuleConf', see +-- 'moduleToPkgConfAll' +type ModuleToPkgConfAll = UniqFM (ModuleName, PackageIdMap ModuleConf) data PackageState = PackageState { pkgIdMap :: PackageConfigMap, -- PackageKey -> PackageConfig @@ -179,10 +184,19 @@ type InstalledPackageIndex = Map InstalledPackageId PackageConfig emptyPackageConfigMap :: PackageConfigMap emptyPackageConfigMap = emptyUFM --- | Find the package we know about with the given id (e.g. \"foo-1.0\"), if any -lookupPackage :: PackageConfigMap -> PackageKey -> Maybe PackageConfig -lookupPackage = lookupUFM +-- | Find the package we know about with the given key (e.g. @foo_HASH@), if any +lookupPackage :: DynFlags -> PackageKey -> Maybe PackageConfig +lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags)) + +lookupPackage' :: PackageConfigMap -> PackageKey -> Maybe PackageConfig +lookupPackage' = lookupUFM + +-- | Search for packages with a given package ID (e.g. \"foo-0.1\") +searchPackageId :: DynFlags -> PackageId -> [PackageConfig] +searchPackageId dflags pid = filter ((pid ==) . sourcePackageId) + (listPackageConfigMap dflags) +-- | Extends the package configuration map with a list of package configs. extendPackageConfigMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap extendPackageConfigMap pkg_map new_pkgs @@ -191,8 +205,19 @@ extendPackageConfigMap pkg_map new_pkgs -- | Looks up the package with the given id in the package state, panicing if it is -- not found -getPackageDetails :: PackageState -> PackageKey -> PackageConfig -getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdMap ps) pid) +getPackageDetails :: DynFlags -> PackageKey -> PackageConfig +getPackageDetails dflags pid = + expectJust "getPackageDetails" (lookupPackage dflags pid) + +-- | Get a list of entries from the package database. NB: be careful with +-- this function, it may not do what you expect it to. +listPackageConfigMap :: DynFlags -> [PackageConfig] +listPackageConfigMap dflags = eltsUFM (pkgIdMap (pkgState dflags)) + +resolveInstalledPackageId :: DynFlags -> InstalledPackageId -> PackageKey +resolveInstalledPackageId dflags ipid = + expectJust "resolveInstalledPackageId" + (Map.lookup ipid (installedPackageIdMap (pkgState dflags))) -- ---------------------------------------------------------------------------- -- Loading the package db files and building up the package state @@ -858,7 +883,8 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- add base & rts to the preload packages basicLinkedPackages | gopt Opt_AutoLinkPackages dflags - = filter (flip elemUFM pkg_db) [basePackageKey, rtsPackageKey] + = filter (flip elemUFM pkg_db) + [basePackageKey, rtsPackageKey] | otherwise = [] -- but in any case remove the current package from the set of -- preloaded packages so that base/rts does not end up in the @@ -886,12 +912,16 @@ mkModuleMap :: PackageConfigMap -> InstalledPackageIdMap -> ModuleToPkgConfAll -mkModuleMap pkg_db ipid_map = foldr extend_modmap emptyUFM pkgids +mkModuleMap pkg_db ipid_map = + foldr extend_modmap emptyUFM (eltsUFM pkg_db) where - pkgids = map packageConfigId (eltsUFM pkg_db) - - extend_modmap pkgid modmap = addListToUFM_C (plusUFM_C merge) modmap es - where -- Invariant: m == m' && pkg == pkg' && e == e' + extend_modmap pkg modmap = addListToUFM_C merge0 modmap es + where -- Invariant: a == _a' + merge0 :: (ModuleName, PackageIdMap ModuleConf) + -> (ModuleName, PackageIdMap ModuleConf) + -> (ModuleName, PackageIdMap ModuleConf) + merge0 (a,b) (_a',b') = (a, plusUFM_C merge b b') + -- Invariant: m == m' && pkg == pkg' && e == e' -- && (e || not (v || v')) -- Some notes about the assert. Merging only ever occurs when -- we find a reexport. The interesting condition: @@ -902,18 +932,18 @@ mkModuleMap pkg_db ipid_map = foldr extend_modmap emptyUFM pkgids -- which is why we merge visibility using logical OR. merge a b = a { modConfVisible = modConfVisible a || modConfVisible b } - es = [(m, unitUFM pkgid (ModConf m pkg True (exposed pkg))) + es = [(m, (m, unitUFM pkgid (ModConf m pkg True (exposed pkg)))) | m <- exposed_mods] ++ - [(m, unitUFM pkgid (ModConf m pkg False False)) + [(m, (m, unitUFM pkgid (ModConf m pkg False False))) | m <- hidden_mods] ++ - [(m, unitUFM pkgid' (ModConf m' pkg' True (exposed pkg))) + [(m, (m, unitUFM pkgid' (ModConf m' pkg' True (exposed pkg)))) | ModuleExport{ exportName = m , exportCachedTrueOrig = Just (ipid', m')} <- reexported_mods , Just pkgid' <- [Map.lookup ipid' ipid_map] , let pkg' = pkg_lookup pkgid' ] - pkg = pkg_lookup pkgid - pkg_lookup = expectJust "mkModuleMap" . lookupPackage pkg_db + pkgid = packageConfigId pkg + pkg_lookup = expectJust "mkModuleMap" . lookupPackage' pkg_db exposed_mods = exposedModules pkg reexported_mods = reexportedModules pkg hidden_mods = hiddenModules pkg @@ -1041,7 +1071,7 @@ lookupModuleWithSuggestions lookupModuleWithSuggestions dflags m = case lookupUFM (moduleToPkgConfAll pkg_state) m of Nothing -> Left suggestions - Just ps -> Right ps + Just (_, ps) -> Right ps where pkg_state = pkgState dflags suggestions @@ -1051,11 +1081,15 @@ lookupModuleWithSuggestions dflags m all_mods :: [(String, Module)] -- All modules all_mods = [ (moduleNameString mod_nm, mkModule pkg_id mod_nm) - | pkg_config <- eltsUFM (pkgIdMap pkg_state) + | pkg_config <- listPackageConfigMap dflags , let pkg_id = packageConfigId pkg_config , mod_nm <- exposedModules pkg_config ++ map exportName (reexportedModules pkg_config) ] +listVisibleModuleNames :: DynFlags -> [ModuleName] +listVisibleModuleNames dflags = + map fst (eltsUFM (moduleToPkgConfAll (pkgState dflags))) + -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of -- 'PackageConfig's getPreloadPackagesAnd :: DynFlags -> [PackageKey] -> IO [PackageConfig] @@ -1068,7 +1102,7 @@ getPreloadPackagesAnd dflags pkgids = pairs = zip pkgids (repeat Nothing) in do all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs) - return (map (getPackageDetails state) all_pkgs) + return (map (getPackageDetails dflags) all_pkgs) -- Takes a list of packages, and returns the list with dependencies included, -- in reverse dependency order (a package appears before those it depends on). @@ -1101,7 +1135,7 @@ add_package :: PackageConfigMap add_package pkg_db ipid_map ps (p, mb_parent) | p `elem` ps = return ps -- Check if we've already added this package | otherwise = - case lookupPackage pkg_db p of + case lookupPackage' pkg_db p of Nothing -> Failed (missingPackageMsg (packageKeyString p) <> missingDependencyMsg mb_parent) Just pkg -> do @@ -1134,7 +1168,7 @@ packageKeyPackageIdString dflags pkg_key | pkg_key == mainPackageKey = "main" | otherwise = maybe "(unknown)" (display . sourcePackageId) - (lookupPackage (pkgIdMap (pkgState dflags)) pkg_key) + (lookupPackage dflags pkg_key) -- | Will the 'Name' come from a dynamically linked library? isDllName :: DynFlags -> PackageKey -> Module -> Name -> Bool @@ -1178,11 +1212,10 @@ dumpPackages = dumpPackages' showInstalledPackageInfo dumpPackages' :: (InstalledPackageInfo -> String) -> DynFlags -> IO () dumpPackages' showIPI dflags - = do let pkg_map = pkgIdMap (pkgState dflags) - putMsg dflags $ + = do putMsg dflags $ vcat (map (text . showIPI . packageConfigToInstalledPackageInfo) - (eltsUFM pkg_map)) + (listPackageConfigMap dflags)) -- | Show simplified package info on console, if verbosity == 4. -- The idea is to only print package id, and any information that might diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 96b78809d2..1b6256b8cb 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -39,15 +39,13 @@ import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, setInteractivePrintName ) import Module import Name -import Packages ( ModuleExport(..), trusted, getPackageDetails, exposed, - exposedModules, reexportedModules, pkgIdMap ) +import Packages ( trusted, getPackageDetails, listVisibleModuleNames ) import PprTyThing import RdrName ( getGRE_NameQualifier_maybes ) import SrcLoc import qualified Lexer import StringBuffer -import UniqFM ( eltsUFM ) import Outputable hiding ( printForUser, printForUserPartWay, bold ) -- Other random utilities @@ -1619,12 +1617,11 @@ isSafeModule m = do packageTrusted dflags md | thisPackage dflags == modulePackageKey md = True - | otherwise = trusted $ getPackageDetails (pkgState dflags) (modulePackageKey md) + | otherwise = trusted $ getPackageDetails dflags (modulePackageKey md) tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], []) | otherwise = partition part deps - where state = pkgState dflags - part pkg = trusted $ getPackageDetails state pkg + where part pkg = trusted $ getPackageDetails dflags pkg ----------------------------------------------------------------------------- -- :browse @@ -2478,7 +2475,7 @@ completeIdentifier = wrapIdentCompleter $ \w -> do completeModule = wrapIdentCompleter $ \w -> do dflags <- GHC.getSessionDynFlags - let pkg_mods = allExposedModules dflags + let pkg_mods = allVisibleModules dflags loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules return $ filter (w `isPrefixOf`) $ map (showPpr dflags) $ loaded_mods ++ pkg_mods @@ -2490,7 +2487,7 @@ completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do imports <- GHC.getContext return $ map iiModuleName imports _ -> do - let pkg_mods = allExposedModules dflags + let pkg_mods = allVisibleModules dflags loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules return $ loaded_mods ++ pkg_mods return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules @@ -2547,13 +2544,9 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor getModifier = find (`elem` modifChars) -- | Return a list of visible module names for autocompletion. -allExposedModules :: DynFlags -> [ModuleName] -allExposedModules dflags - = concatMap extract (filter exposed (eltsUFM pkg_db)) - where - pkg_db = pkgIdMap (pkgState dflags) - extract pkg = exposedModules pkg ++ map exportName (reexportedModules pkg) - -- Extract the *new* name, because that's what is user visible +-- (NB: exposed != visible) +allVisibleModules :: DynFlags -> [ModuleName] +allVisibleModules dflags = listVisibleModuleNames dflags completeExpression = completeQuotedWord (Just '\\') "\"" listFiles completeIdentifier |