Commit 6a831be4 authored by pcapriotti's avatar pcapriotti

Add flags to manipulate package db stack (#5977)

Introduce new flags to allow any package database stack to be set up.
The `-no-user-package-conf` and `-no-global-package-conf` flags remove
the corresponding package db from the initial stack, while
`-user-package-conf` and `-global-package-conf` push it back on top of
the stack.
parent c250f93b
......@@ -38,6 +38,7 @@ module DynFlags (
GhcMode(..), isOneShot,
GhcLink(..), isNoLink,
PackageFlag(..),
PkgConfRef(..),
Option(..), showOpt,
DynLibLoader(..),
fFlags, fWarningFlags, fLangFlags, xFlags,
......@@ -275,6 +276,7 @@ data DynFlag
| Opt_ForceRecomp
| Opt_ExcessPrecision
| Opt_EagerBlackHoling
| Opt_ReadGlobalPackageConf
| Opt_ReadUserPackageConf
| Opt_NoHsMain
| Opt_SplitObjs
......@@ -548,7 +550,7 @@ data DynFlags = DynFlags {
depSuffixes :: [String],
-- Package flags
extraPkgConfs :: [FilePath],
extraPkgConfs :: [PkgConfRef],
-- ^ The @-package-conf@ flags given on the command line, in the order
-- they appeared.
......@@ -1755,8 +1757,13 @@ dynamic_flags = [
package_flags :: [Flag (CmdLineP DynFlags)]
package_flags = [
------- Packages ----------------------------------------------------
Flag "package-conf" (HasArg extraPkgConf_)
Flag "package-conf" (HasArg (extraPkgConf_ . PkgConfFile))
, Flag "clear-package-conf" (NoArg clearPkgConf)
, Flag "no-global-package-conf" (NoArg (unSetDynFlag Opt_ReadGlobalPackageConf))
, Flag "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf))
, Flag "global-package-conf" (NoArg (extraPkgConf_ GlobalPkgConf))
, Flag "user-package-conf" (NoArg (extraPkgConf_ UserPkgConf))
, Flag "package-name" (hasArg setPackageName)
, Flag "package-id" (HasArg exposePackageId)
, Flag "package" (HasArg exposePackage)
......@@ -2066,6 +2073,7 @@ xFlags = [
defaultFlags :: [DynFlag]
defaultFlags
= [ Opt_AutoLinkPackages,
Opt_ReadGlobalPackageConf,
Opt_ReadUserPackageConf,
Opt_SharedImplib,
......@@ -2404,9 +2412,19 @@ setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 })
addCmdlineHCInclude :: String -> DynP ()
addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s})
extraPkgConf_ :: FilePath -> DynP ()
data PkgConfRef
= GlobalPkgConf
| UserPkgConf
| PkgConfFile FilePath
extraPkgConf_ :: PkgConfRef -> DynP ()
extraPkgConf_ p = upd (\s -> s{ extraPkgConfs = p : extraPkgConfs s })
clearPkgConf :: DynP ()
clearPkgConf = do
unSetDynFlag Opt_ReadGlobalPackageConf
unSetDynFlag Opt_ReadUserPackageConf
exposePackage, exposePackageId, hidePackage, ignorePackage,
trustPackage, distrustPackage :: String -> DynP ()
exposePackage p =
......
......@@ -152,10 +152,10 @@ getPackageDetails :: PackageState -> PackageId -> PackageConfig
getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdMap ps) pid)
-- ----------------------------------------------------------------------------
-- Loading the package config files and building up the package state
-- Loading the package db files and building up the package state
-- | Call this after 'DynFlags.parseDynFlags'. It reads the package
-- configuration files, and sets up various internal tables of package
-- database files, and sets up various internal tables of package
-- information, according to the package-related flags on the
-- command-line (@-package@, @-hide-package@ etc.)
--
......@@ -184,46 +184,43 @@ initPackages dflags = do
readPackageConfigs :: DynFlags -> IO [PackageConfig]
readPackageConfigs dflags = do
e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH")
system_pkgconfs <- getSystemPackageConfigs dflags
let pkgconfs = case e_pkg_path of
Left _ -> system_pkgconfs
Right path
| last cs == "" -> init cs ++ system_pkgconfs
| otherwise -> cs
where cs = parseSearchPath path
-- if the path ends in a separator (eg. "/foo/bar:")
-- the we tack on the system paths.
pkgs <- mapM (readPackageConfig dflags)
(pkgconfs ++ reverse (extraPkgConfs dflags))
-- later packages shadow earlier ones. extraPkgConfs
-- is in the opposite order to the flags on the
-- command line.
return (concat pkgs)
getSystemPackageConfigs :: DynFlags -> IO [FilePath]
getSystemPackageConfigs dflags = do
-- System one always comes first
let system_pkgconf = systemPackageConfig dflags
-- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf)
-- unless the -no-user-package-conf flag was given.
user_pkgconf <- do
if not (dopt Opt_ReadUserPackageConf dflags) then return [] else do
appdir <- getAppUserDataDirectory "ghc"
let
dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
pkgconf = dir </> "package.conf.d"
--
exist <- doesDirectoryExist pkgconf
if exist then return [pkgconf] else return []
`catchIO` (\_ -> return [])
return (system_pkgconf : user_pkgconf)
let -- Read global package db, unless the -no-user-package-conf flag was given
global_conf_refs = [GlobalPkgConf | dopt Opt_ReadGlobalPackageConf dflags]
-- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf)
-- unless the -no-user-package-conf flag was given.
user_conf_refs = [UserPkgConf | dopt Opt_ReadUserPackageConf dflags]
system_conf_refs = global_conf_refs ++ user_conf_refs
e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH")
let base_conf_refs = case e_pkg_path of
Left _ -> system_conf_refs
Right path
| null (last cs)
-> map PkgConfFile (init cs) ++ system_conf_refs
| otherwise
-> map PkgConfFile cs
where cs = parseSearchPath path
-- if the path ends in a separator (eg. "/foo/bar:")
-- the we tack on the base paths.
let conf_refs = base_conf_refs ++ reverse (extraPkgConfs dflags)
-- later packages shadow earlier ones. extraPkgConfs
-- is in the opposite order to the flags on the
-- command line.
confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs
liftM concat $ mapM (readPackageConfig dflags) confs
resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)
resolvePackageConfig _ UserPkgConf = handleIO (\_ -> return Nothing) $ do
appdir <- getAppUserDataDirectory "ghc"
let dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
pkgconf = dir </> "package.conf.d"
exist <- doesDirectoryExist pkgconf
return $ if exist then Just pkgconf else Nothing
resolvePackageConfig _ (PkgConfFile name) = return $ Just name
readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig]
readPackageConfig dflags conf_file = do
......
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