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
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
......
......@@ -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"
......
......@@ -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,
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
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