Commit de3f0644 authored by Edward Z. Yang's avatar Edward Z. Yang

Make PackageState an abstract type.

Summary: Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: simonpj, simonmar, hvr, austin

Subscribers: simonmar, relrod, ezyang, carter

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