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

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

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"
 

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,

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

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

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)

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}

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

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