Commit 29c701c1 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

Refactor package related code

The package terminology is a bit of a mess. Cabal packages contain
components. Instances of these components when built with some
flags/options/dependencies are called units. Units are registered into
package databases and their metadata are called PackageConfig.

GHC only knows about package databases containing units. It is a sad
mismatch not fixed by this patch (we would have to rename parameters
such as `package-id <unit-id>` which would affect users).

This patch however fixes the following internal names:

- Renames PackageConfig into UnitInfo.
- Rename systemPackageConfig into globalPackageDatabase[Path]
- Rename PkgConfXX into PkgDbXX
- Rename pkgIdMap into unitIdMap
- Rename ModuleToPkgDbAll into ModuleNameProvidersMap
- Rename lookupPackage into lookupUnit
- Add comments on DynFlags package related fields

It also introduces a new `PackageDatabase` datatype instead of
explicitly passing the following tuple: `(FilePath,[PackageConfig])`.

The `pkgDatabase` field in `DynFlags` now contains the unit info for
each unit of each package database exactly as they have been read from
disk. Previously the command-line flag `-distrust-all-packages` would
modify these unit info. Now this flag only affects the "dynamic"
consolidated package state found in `pkgState` field. It makes sense
because `initPackages` could be called first with this
`distrust-all-packages` flag set and then again (using ghc-api) without
and it should work (package databases are not read again from disk when
`initPackages` is called the second time).

Bump haddock submodule
parent bf38a20e
Pipeline #15245 failed with stages
in 414 minutes and 44 seconds
......@@ -23,7 +23,7 @@ import GHC.Hs
import SrcLoc
import Outputable
import Module
import PackageConfig
import UnitInfo
{-
************************************************************************
......
......@@ -190,7 +190,7 @@ withBkpSession cid insts deps session_type do_this = do
importPaths = [],
-- Synthesized the flags
packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0)
let uid = unwireUnitId dflags (improveUnitId (getUnitInfoMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0)
in ExposePackage
(showSDoc dflags
(text "-unit-id" <+> ppr uid <+> ppr rn))
......@@ -271,7 +271,7 @@ buildUnit session cid insts lunit = do
dflags <- getDynFlags
-- IMPROVE IT
let deps = map (improveUnitId (getPackageConfigMap dflags)) deps0
let deps = map (improveUnitId (getUnitInfoMap dflags)) deps0
mb_old_eps <- case session of
TcSession -> fmap Just getEpsGhc
......@@ -375,20 +375,19 @@ compileExe lunit = do
ok <- load' LoadAllTargets (Just msg) mod_graph
when (failed ok) (liftIO $ exitWith (ExitFailure 1))
addPackage :: GhcMonad m => PackageConfig -> m ()
-- | Register a new virtual package database containing a single unit
addPackage :: GhcMonad m => UnitInfo -> m ()
addPackage pkg = do
dflags0 <- GHC.getSessionDynFlags
case pkgDatabase dflags0 of
dflags <- GHC.getSessionDynFlags
case pkgDatabase dflags of
Nothing -> panic "addPackage: called too early"
Just pkgs -> do let dflags = dflags0 { pkgDatabase =
Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) }
_ <- GHC.setSessionDynFlags dflags
-- By this time, the global ref has probably already
-- been forced, in which case doing this isn't actually
-- going to do you any good.
-- dflags <- GHC.getSessionDynFlags
-- liftIO $ setUnsafeGlobalDynFlags dflags
return ()
Just dbs -> do
let newdb = PackageDatabase
{ packageDatabasePath = "(in memory " ++ showSDoc dflags (ppr (unitId pkg)) ++ ")"
, packageDatabaseUnits = [pkg]
}
_ <- GHC.setSessionDynFlags (dflags { pkgDatabase = Just (dbs ++ [newdb]) })
return ()
-- Precondition: UnitId is NOT InstalledUnitId
compileInclude :: Int -> (Int, UnitId) -> BkpM ()
......@@ -397,7 +396,7 @@ compileInclude n (i, uid) = do
let dflags = hsc_dflags hsc_env
msgInclude (i, n) uid
-- Check if we've compiled it already
case lookupPackage dflags uid of
case lookupUnit dflags uid of
Nothing -> do
case splitUnitIdInsts uid of
(_, Just indef) ->
......
......@@ -170,7 +170,7 @@ import qualified FiniteMap as Map
import System.FilePath
import {-# SOURCE #-} DynFlags (DynFlags)
import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigMap, getPackageConfigMap, displayInstalledUnitId)
import {-# SOURCE #-} Packages (componentIdString, improveUnitId, UnitInfoMap, getUnitInfoMap, displayInstalledUnitId)
-- Note [The identifier lexicon]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -642,7 +642,7 @@ indefUnitIdToUnitId dflags iuid =
-- p[H=impl:H]. If we *only* wrap in p[H=impl:H]
-- IndefiniteUnitId, they won't compare equal; only
-- after improvement will the equality hold.
improveUnitId (getPackageConfigMap dflags) $
improveUnitId (getUnitInfoMap dflags) $
IndefiniteUnitId iuid
data IndefModule = IndefModule {
......@@ -943,18 +943,18 @@ type ShHoleSubst = ModuleNameEnv Module
-- @p[A=<A>]:B@ maps to @p[A=q():A]:B@ with @A=q():A@;
-- similarly, @<A>@ maps to @q():A@.
renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module
renameHoleModule dflags = renameHoleModule' (getPackageConfigMap dflags)
renameHoleModule dflags = renameHoleModule' (getUnitInfoMap dflags)
-- | Substitutes holes in a 'UnitId', suitable for renaming when
-- an include occurs; see Note [Representation of module/name variable].
--
-- @p[A=<A>]@ maps to @p[A=<B>]@ with @A=<B>@.
renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId
renameHoleUnitId dflags = renameHoleUnitId' (getPackageConfigMap dflags)
renameHoleUnitId dflags = renameHoleUnitId' (getUnitInfoMap dflags)
-- | Like 'renameHoleModule', but requires only 'PackageConfigMap'
-- | Like 'renameHoleModule', but requires only 'UnitInfoMap'
-- so it can be used by "Packages".
renameHoleModule' :: PackageConfigMap -> ShHoleSubst -> Module -> Module
renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module
renameHoleModule' pkg_map env m
| not (isHoleModule m) =
let uid = renameHoleUnitId' pkg_map env (moduleUnitId m)
......@@ -963,9 +963,9 @@ renameHoleModule' pkg_map env m
-- NB m = <Blah>, that's what's in scope.
| otherwise = m
-- | Like 'renameHoleUnitId, but requires only 'PackageConfigMap'
-- | Like 'renameHoleUnitId, but requires only 'UnitInfoMap'
-- so it can be used by "Packages".
renameHoleUnitId' :: PackageConfigMap -> ShHoleSubst -> UnitId -> UnitId
renameHoleUnitId' :: UnitInfoMap -> ShHoleSubst -> UnitId -> UnitId
renameHoleUnitId' pkg_map env uid =
case uid of
(IndefiniteUnitId
......@@ -975,7 +975,7 @@ renameHoleUnitId' pkg_map env uid =
-> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env)
then uid
-- Functorially apply the substitution to the instantiation,
-- then check the 'PackageConfigMap' to see if there is
-- then check the 'UnitInfoMap' to see if there is
-- a compiled version of this 'UnitId' we can improve to.
-- See Note [UnitId to InstalledUnitId] improvement
else improveUnitId pkg_map $
......
......@@ -387,7 +387,7 @@ Library
HscTypes
InteractiveEval
InteractiveEvalTypes
PackageConfig
UnitInfo
Packages
PlatformConstants
Plugins
......
......@@ -1255,7 +1255,7 @@ linkPackages' hsc_env new_pks pls = do
= throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (installedUnitIdFS new_pkg)))
linkPackage :: HscEnv -> PackageConfig -> IO ()
linkPackage :: HscEnv -> UnitInfo -> IO ()
linkPackage hsc_env pkg
= do
let dflags = hsc_dflags hsc_env
......@@ -1408,7 +1408,7 @@ load_dyn hsc_env crash_early dll = do
, "(the package DLL is loaded by the system linker"
, " which manages dependencies by itself)." ]
loadFrameworks :: HscEnv -> Platform -> PackageConfig -> IO ()
loadFrameworks :: HscEnv -> Platform -> UnitInfo -> IO ()
loadFrameworks hsc_env platform pkg
= when (platformUsesFrameworks platform) $ mapM_ load frameworks
where
......
......@@ -2014,7 +2014,7 @@ doCpp dflags raw input_fn output_fn = do
-- MIN_VERSION macros
let uids = explicitPackages (pkgState dflags)
pkgs = catMaybes (map (lookupPackage dflags) uids)
pkgs = catMaybes (map (lookupUnit dflags) uids)
mb_macro_include <-
if not (null pkgs) && gopt Opt_VersionMacros dflags
then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
......@@ -2074,7 +2074,7 @@ getBackendDefs _ =
-- ---------------------------------------------------------------------------
-- Macros (cribbed from Cabal)
generatePackageVersionMacros :: [PackageConfig] -> String
generatePackageVersionMacros :: [UnitInfo] -> String
generatePackageVersionMacros pkgs = concat
-- Do not add any C-style comments. See #3389.
[ generateMacros "" pkgname version
......
......@@ -55,7 +55,7 @@ module DynFlags (
PackageFlag(..), PackageArg(..), ModRenaming(..),
packageFlagsChanged,
IgnorePackageFlag(..), TrustFlag(..),
PackageDBFlag(..), PkgConfRef(..),
PackageDBFlag(..), PkgDbRef(..),
Option(..), showOpt,
DynLibLoader(..),
fFlags, fLangFlags, xFlags,
......@@ -96,7 +96,7 @@ module DynFlags (
sToolDir,
sTopDir,
sTmpDir,
sSystemPackageConfig,
sGlobalPackageDatabasePath,
sLdSupportsCompactUnwind,
sLdSupportsBuildId,
sLdSupportsFilelist,
......@@ -153,7 +153,7 @@ module DynFlags (
programName, projectVersion,
ghcUsagePath, ghciUsagePath, topDir, tmpDir,
versionedAppDir, versionedFilePath,
extraGccViaCFlags, systemPackageConfig,
extraGccViaCFlags, globalPackageDatabasePath,
pgm_L, pgm_P, pgm_F, pgm_c, pgm_a, pgm_l, pgm_dll, pgm_T,
pgm_windres, pgm_libtool, pgm_ar, pgm_ranlib, pgm_lo, pgm_lc,
pgm_lcc, pgm_i,
......@@ -254,11 +254,10 @@ import GHC.Platform
import GHC.UniqueSubdir (uniqueSubdir)
import PlatformConstants
import Module
import PackageConfig
import {-# SOURCE #-} Plugins
import {-# SOURCE #-} Hooks
import {-# SOURCE #-} PrelNames ( mAIN )
import {-# SOURCE #-} Packages (PackageState, emptyPackageState)
import {-# SOURCE #-} Packages (PackageState, emptyPackageState, PackageDatabase)
import DriverPhases ( Phase(..), phaseInputExt )
import Config
import CliOption
......@@ -1146,11 +1145,23 @@ data DynFlags = DynFlags {
packageEnv :: Maybe FilePath,
-- ^ Filepath to the package environment file (if overriding default)
-- Package state
-- NB. do not modify this field, it is calculated by
-- Packages.initPackages
pkgDatabase :: Maybe [(FilePath, [PackageConfig])],
pkgDatabase :: Maybe [PackageDatabase],
-- ^ Stack of package databases for the target platform.
--
-- A "package database" is a misleading name as it is really a Unit
-- database (cf Note [The identifier lexicon]).
--
-- This field is populated by `initPackages`.
--
-- 'Nothing' means the databases have never been read from disk. If
-- `initPackages` is called again, it doesn't reload the databases from
-- disk.
pkgState :: PackageState,
-- ^ Consolidated unit database built by 'initPackages' from the package
-- databases in 'pkgDatabase' and flags ('-ignore-package', etc.).
--
-- It also contains mapping from module names to actual Modules.
-- Temporary files
-- These have to be IORefs, because the defaultCleanupHandler needs to
......@@ -1440,8 +1451,8 @@ tmpDir :: DynFlags -> String
tmpDir dflags = fileSettings_tmpDir $ fileSettings dflags
extraGccViaCFlags :: DynFlags -> [String]
extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags
systemPackageConfig :: DynFlags -> FilePath
systemPackageConfig dflags = fileSettings_systemPackageConfig $ fileSettings dflags
globalPackageDatabasePath :: DynFlags -> FilePath
globalPackageDatabasePath dflags = fileSettings_globalPackageDatabase $ fileSettings dflags
pgm_L :: DynFlags -> String
pgm_L dflags = toolSettings_pgm_L $ toolSettings dflags
pgm_P :: DynFlags -> (String,[Option])
......@@ -1647,7 +1658,7 @@ data PackageFlag
deriving (Eq) -- NB: equality instance is used by packageFlagsChanged
data PackageDBFlag
= PackageDB PkgConfRef
= PackageDB PkgDbRef
| NoUserPackageDB
| NoGlobalPackageDB
| ClearPackageDBs
......@@ -2033,7 +2044,6 @@ defaultDynFlags mySettings llvmConfig =
trustFlags = [],
packageEnv = Nothing,
pkgDatabase = Nothing,
-- This gets filled in with GHC.setSessionDynFlags
pkgState = emptyPackageState,
ways = defaultWays mySettings,
buildTag = mkBuildTag (defaultWays mySettings),
......@@ -3856,19 +3866,19 @@ package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]
package_flags_deps = [
------- Packages ----------------------------------------------------
make_ord_flag defFlag "package-db"
(HasArg (addPkgConfRef . PkgConfFile))
, make_ord_flag defFlag "clear-package-db" (NoArg clearPkgConf)
, make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgConf)
, make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgConf)
(HasArg (addPkgDbRef . PkgDbPath))
, make_ord_flag defFlag "clear-package-db" (NoArg clearPkgDb)
, make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgDb)
, make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgDb)
, make_ord_flag defFlag "global-package-db"
(NoArg (addPkgConfRef GlobalPkgConf))
(NoArg (addPkgDbRef GlobalPkgDb))
, make_ord_flag defFlag "user-package-db"
(NoArg (addPkgConfRef UserPkgConf))
(NoArg (addPkgDbRef UserPkgDb))
-- backwards compat with GHC<=7.4 :
, make_dep_flag defFlag "package-conf"
(HasArg $ addPkgConfRef . PkgConfFile) "Use -package-db instead"
(HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead"
, make_dep_flag defFlag "no-user-package-conf"
(NoArg removeUserPkgConf) "Use -no-user-package-db instead"
(NoArg removeUserPkgDb) "Use -no-user-package-db instead"
, make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> do
upd (setUnitId name))
-- TODO: Since we JUST deprecated
......@@ -5201,26 +5211,26 @@ setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 })
setDebugLevel :: Maybe Int -> DynP ()
setDebugLevel mb_n = upd (\dfs -> dfs{ debugLevel = mb_n `orElse` 2 })
data PkgConfRef
= GlobalPkgConf
| UserPkgConf
| PkgConfFile FilePath
data PkgDbRef
= GlobalPkgDb
| UserPkgDb
| PkgDbPath FilePath
deriving Eq
addPkgConfRef :: PkgConfRef -> DynP ()
addPkgConfRef p = upd $ \s ->
addPkgDbRef :: PkgDbRef -> DynP ()
addPkgDbRef p = upd $ \s ->
s { packageDBFlags = PackageDB p : packageDBFlags s }
removeUserPkgConf :: DynP ()
removeUserPkgConf = upd $ \s ->
removeUserPkgDb :: DynP ()
removeUserPkgDb = upd $ \s ->
s { packageDBFlags = NoUserPackageDB : packageDBFlags s }
removeGlobalPkgConf :: DynP ()
removeGlobalPkgConf = upd $ \s ->
removeGlobalPkgDb :: DynP ()
removeGlobalPkgDb = upd $ \s ->
s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s }
clearPkgConf :: DynP ()
clearPkgConf = upd $ \s ->
clearPkgDb :: DynP ()
clearPkgDb = upd $ \s ->
s { packageDBFlags = ClearPackageDBs : packageDBFlags s }
parsePackageFlag :: String -- the flag
......@@ -5367,13 +5377,13 @@ parseEnvFile :: FilePath -> String -> DynP ()
parseEnvFile envfile = mapM_ parseEntry . lines
where
parseEntry str = case words str of
("package-db": _) -> addPkgConfRef (PkgConfFile (envdir </> db))
("package-db": _) -> addPkgDbRef (PkgDbPath (envdir </> db))
-- relative package dbs are interpreted relative to the env file
where envdir = takeDirectory envfile
db = drop 11 str
["clear-package-db"] -> clearPkgConf
["global-package-db"] -> addPkgConfRef GlobalPkgConf
["user-package-db"] -> addPkgConfRef UserPkgConf
["clear-package-db"] -> clearPkgDb
["global-package-db"] -> addPkgDbRef GlobalPkgDb
["user-package-db"] -> addPkgDbRef UserPkgDb
["package-id", pkgid] -> exposePackageId pkgid
(('-':'-':_):_) -> return () -- comments
-- and the original syntax introduced in 7.10:
......@@ -5603,7 +5613,7 @@ compilerInfo dflags
("Debug on", showBool debugIsOn),
("LibDir", topDir dflags),
-- The path of the global package database used by GHC
("Global Package DB", systemPackageConfig dflags)
("Global Package DB", globalPackageDatabasePath dflags)
]
where
showBool True = "YES"
......
......@@ -7,10 +7,10 @@ import GhcPrelude
-- | Paths to various files and directories used by GHC, including those that
-- provide more settings.
data FileSettings = FileSettings
{ fileSettings_ghcUsagePath :: FilePath -- ditto
, fileSettings_ghciUsagePath :: FilePath -- ditto
, fileSettings_toolDir :: Maybe FilePath -- ditto
, fileSettings_topDir :: FilePath -- ditto
, fileSettings_tmpDir :: String -- no trailing '/'
, fileSettings_systemPackageConfig :: FilePath
{ fileSettings_ghcUsagePath :: FilePath -- ditto
, fileSettings_ghciUsagePath :: FilePath -- ditto
, fileSettings_toolDir :: Maybe FilePath -- ditto
, fileSettings_topDir :: FilePath -- ditto
, fileSettings_tmpDir :: String -- no trailing '/'
, fileSettings_globalPackageDatabase :: FilePath
}
......@@ -349,12 +349,12 @@ findPackageModule hsc_env mod = do
-- requires a few invariants to be upheld: (1) the 'Module' in question must
-- be the module identifier of the *original* implementation of a module,
-- not a reexport (this invariant is upheld by @Packages.hs@) and (2)
-- the 'PackageConfig' must be consistent with the unit id in the 'Module'.
-- the 'UnitInfo' must be consistent with the unit id in the 'Module'.
-- The redundancy is to avoid an extra lookup in the package state
-- for the appropriate config.
findPackageModule_ :: HscEnv -> InstalledModule -> PackageConfig -> IO InstalledFindResult
findPackageModule_ :: HscEnv -> InstalledModule -> UnitInfo -> IO InstalledFindResult
findPackageModule_ hsc_env mod pkg_conf =
ASSERT2( installedModuleUnitId mod == installedPackageConfigId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedPackageConfigId pkg_conf) )
ASSERT2( installedModuleUnitId mod == installedUnitInfoId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedUnitInfoId pkg_conf) )
modLocationCache hsc_env mod $
-- special case for GHC.Prim; we won't find it in the filesystem.
......@@ -714,19 +714,19 @@ cantFindErr cannot_find _ dflags mod_name find_result
tried_these files dflags
pkg_hidden :: UnitId -> SDoc
pkg_hidden pkgid =
pkg_hidden uid =
text "It is a member of the hidden package"
<+> quotes (ppr pkgid)
<+> quotes (ppr uid)
--FIXME: we don't really want to show the unit id here we should
-- show the source package id or installed package id if it's ambiguous
<> dot $$ pkg_hidden_hint pkgid
pkg_hidden_hint pkgid
<> dot $$ pkg_hidden_hint uid
pkg_hidden_hint uid
| gopt Opt_BuildingCabalPackage dflags
= let pkg = expectJust "pkg_hidden" (lookupPackage dflags pkgid)
= let pkg = expectJust "pkg_hidden" (lookupUnit dflags uid)
in text "Perhaps you need to add" <+>
quotes (ppr (packageName pkg)) <+>
text "to the build-depends in your .cabal file."
| Just pkg <- lookupPackage dflags pkgid
| Just pkg <- lookupUnit dflags uid
= text "You can run" <+>
quotes (text ":set -package " <> ppr (packageName pkg)) <+>
text "to expose it." $$
......
......@@ -1311,7 +1311,7 @@ packageDbModules :: GhcMonad m =>
-> m [Module]
packageDbModules only_exposed = do
dflags <- getSessionDynFlags
let pkgs = eltsUFM (pkgIdMap (pkgState dflags))
let pkgs = eltsUFM (unitInfoMap (pkgState dflags))
return $
[ mkModule pid modname
| p <- pkgs
......
......@@ -321,23 +321,23 @@ warnUnusedPackages = do
withDash = (<+>) (text "-")
matchingStr :: String -> PackageConfig -> Bool
matchingStr :: String -> UnitInfo -> Bool
matchingStr str p
= str == sourcePackageIdString p
|| str == packageNameString p
matching :: DynFlags -> PackageArg -> PackageConfig -> Bool
matching :: DynFlags -> PackageArg -> UnitInfo -> Bool
matching _ (PackageArg str) p = matchingStr str p
matching dflags (UnitIdArg uid) p = uid == realUnitId dflags p
-- For wired-in packages, we have to unwire their id,
-- otherwise they won't match package flags
realUnitId :: DynFlags -> PackageConfig -> UnitId
realUnitId :: DynFlags -> UnitInfo -> UnitId
realUnitId dflags
= unwireUnitId dflags
. DefiniteUnitId
. DefUnitId
. installedPackageConfigId
. installedUnitInfoId
-- | Generalized version of 'load' which also supports a custom
-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
......
......@@ -1985,8 +1985,8 @@ mkQualModule dflags mod
-- (1) don't qualify if the package in question is "main", and (2) only qualify
-- with a unit id if the package ID would be ambiguous.
mkQualPackage :: DynFlags -> QueryQualifyPackage
mkQualPackage dflags pkg_key
| pkg_key == mainUnitId || pkg_key == interactiveUnitId
mkQualPackage dflags uid
| uid == mainUnitId || uid == interactiveUnitId
-- Skip the lookup if it's main, since it won't be in the package
-- database!
= False
......@@ -1997,7 +1997,7 @@ mkQualPackage dflags pkg_key
= False
| otherwise
= True
where mb_pkgid = fmap sourcePackageId (lookupPackage dflags pkg_key)
where mb_pkgid = fmap sourcePackageId (lookupUnit dflags uid)
-- | A function which only qualifies package names if necessary; but
-- qualifies all other identifiers.
......
module PackageConfig where
import FastString
import {-# SOURCE #-} Module
import GHC.PackageDb
newtype PackageName = PackageName FastString
newtype SourcePackageId = SourcePackageId FastString
type PackageConfig = InstalledPackageInfo ComponentId SourcePackageId PackageName UnitId ModuleName Module
This diff is collapsed.
......@@ -3,9 +3,10 @@ import GhcPrelude
import {-# SOURCE #-} DynFlags(DynFlags)
import {-# SOURCE #-} Module(ComponentId, UnitId, InstalledUnitId)
data PackageState
data PackageConfigMap
data UnitInfoMap
data PackageDatabase
emptyPackageState :: PackageState
componentIdString :: DynFlags -> ComponentId -> Maybe String
displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String
improveUnitId :: PackageConfigMap -> UnitId -> UnitId
getPackageConfigMap :: DynFlags -> PackageConfigMap
improveUnitId :: UnitInfoMap -> UnitId -> UnitId
getUnitInfoMap :: DynFlags -> UnitInfoMap
......@@ -7,7 +7,7 @@ module Settings
, sToolDir
, sTopDir
, sTmpDir
, sSystemPackageConfig
, sGlobalPackageDatabasePath
, sLdSupportsCompactUnwind
, sLdSupportsBuildId
, sLdSupportsFilelist
......@@ -99,8 +99,8 @@ sTopDir :: Settings -> FilePath
sTopDir = fileSettings_topDir . sFileSettings
sTmpDir :: Settings -> String
sTmpDir = fileSettings_tmpDir . sFileSettings
sSystemPackageConfig :: Settings -> FilePath
sSystemPackageConfig = fileSettings_systemPackageConfig . sFileSettings
sGlobalPackageDatabasePath :: Settings -> FilePath
sGlobalPackageDatabasePath = fileSettings_globalPackageDatabase . sFileSettings
sLdSupportsCompactUnwind :: Settings -> Bool
sLdSupportsCompactUnwind = toolSettings_ldSupportsCompactUnwind . sToolSettings
......
......@@ -108,7 +108,7 @@ initSettings top_dir = do
ldSupportsFilelist <- getBooleanSetting "ld supports filelist"
ldIsGnuLd <- getBooleanSetting "ld is GNU ld"
let pkgconfig_path = installed "package.conf.d"
let globalpkgdb_path = installed "package.conf.d"
ghc_usage_msg_path = installed "ghc-usage.txt"
ghci_usage_msg_path = installed "ghci-usage.txt"
......@@ -186,7 +186,7 @@ initSettings top_dir = do
, fileSettings_ghciUsagePath = ghci_usage_msg_path
, fileSettings_toolDir = mtool_dir
, fileSettings_topDir = top_dir
, fileSettings_systemPackageConfig = pkgconfig_path
, fileSettings_globalPackageDatabase = globalpkgdb_path
}
, sToolSettings = ToolSettings
......
......@@ -6,26 +6,26 @@
--
-- (c) The University of Glasgow, 2004
--
module PackageConfig (
module UnitInfo (
-- $package_naming
-- * UnitId
packageConfigId,
expandedPackageConfigId,
definitePackageConfigId,
installedPackageConfigId,
expandedUnitInfoId,
definiteUnitInfoId,
installedUnitInfoId,
-- * The PackageConfig type: information about a package
PackageConfig,
-- * The UnitInfo type: information about a unit
UnitInfo,
InstalledPackageInfo(..),
ComponentId(..),
SourcePackageId(..),
PackageName(..),
Version(..),
defaultPackageConfig,
defaultUnitInfo,
sourcePackageIdString,
packageNameString,
pprPackageConfig,
pprUnitInfo,
) where
#include "HsVersions.h"
......@@ -41,10 +41,10 @@ import Module
import Unique
-- -----------------------------------------------------------------------------
-- Our PackageConfig type is the InstalledPackageInfo from ghc-boot,
-- Our UnitInfo type is the InstalledPackageInfo from ghc-boot,
-- which is similar to a subset of the InstalledPackageInfo type from Cabal.
type PackageConfig = InstalledPackageInfo
type UnitInfo = InstalledPackageInfo
ComponentId
SourcePackageId
PackageName
......@@ -80,21 +80,21 @@ instance Outputable SourcePackageId where
instance Outputable PackageName where
ppr (PackageName str) = ftext str
defaultPackageConfig :: PackageConfig
defaultPackageConfig = emptyInstalledPackageInfo
defaultUnitInfo :: UnitInfo
defaultUnitInfo = emptyInstalledPackageInfo
sourcePackageIdString :: PackageConfig -> String
sourcePackageIdString :: UnitInfo -> String
sourcePackageIdString pkg = unpackFS str
where
SourcePackageId str = sourcePackageId pkg
packageNameString :: PackageConfig -> String
packageNameString :: UnitInfo -> String
packageNameString pkg = unpackFS str
where
PackageName str = packageName pkg
pprPackageConfig :: PackageConfig -> SDoc
pprPackageConfig InstalledPackageInfo {..} =
pprUnitInfo :: UnitInfo -> SDoc
pprUnitInfo InstalledPackageInfo {..} =
vcat [
field "name" (ppr packageName),
field "version" (text (showVersion packageVersion)),
......@@ -133,22 +133,22 @@ pprPackageConfig InstalledPackageInfo {..} =
-- wired-in packages like @base@ & @rts@, we don't necessarily know what the
-- version is, so these are handled specially; see #wired_in_packages#.
-- | Get the GHC 'UnitId' right out of a Cabalish 'PackageConfig'
installedPackageConfigId :: PackageConfig -> InstalledUnitId
installedPackageConfigId = unitId
-- | Get the GHC 'UnitId' right out of a Cabalish 'UnitInfo'
installedUnitInfoId :: UnitInfo -> InstalledUnitId
installedUnitInfoId = unitId
packageConfigId :: PackageConfig -> UnitId
packageConfigId :: UnitInfo -> UnitId
packageConfigId p =
if indefinite p
then newUnitId (componentId p) (instantiatedWith p)
else DefiniteUnitId (DefUnitId (unitId p))
expandedPackageConfigId :: PackageConfig -> UnitId
expandedPackageConfigId p =
expandedUnitInfoId :: UnitInfo -> UnitId
expandedUnitInfoId p =
newUnitId (componentId p) (instantiatedWith p)
definitePackageConfigId :: PackageConfig -> Maybe DefUnitId
definitePackageConfigId p =
definiteUnitInfoId :: UnitInfo -> Maybe DefUnitId
definiteUnitInfoId p =
case packageConfigId p of
DefiniteUnitId def_uid -> Just def_uid
_ -> Nothing
......@@ -51,7 +51,7 @@ import DriverPhases ( HscSource(..) )
import HscTypes ( IsBootInterface, WarningTxt(..) )
import DynFlags
import BkpSyn
import PackageConfig
import UnitInfo
-- compiler/utils
import OrdList
......
Subproject commit e2c0a757f5aae215d89e464a7e45f9777c27c8f0
Subproject commit 4808003d2238f76aee96d22cc022cee3e049f6a1
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