Commit 16f1796d authored by Mikhail Glushenkov's avatar Mikhail Glushenkov

Make 'list' and 'info' accept the '--package-db' option.

Fixes #1598.
parent b62e3bc0
......@@ -62,7 +62,7 @@ module Distribution.Simple.Setup (
GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand,
ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand,
configAbsolutePaths,
configAbsolutePaths, readPackageDbList, showPackageDbList,
CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand,
InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand,
HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand,
......@@ -549,20 +549,6 @@ configureOptions showOrParseArgs =
showFlagList fs = [ if not set then '-':fname else fname
| (FlagName fname, set) <- fs]
readPackageDbList :: String -> [Maybe PackageDB]
readPackageDbList "clear" = [Nothing]
readPackageDbList "global" = [Just GlobalPackageDB]
readPackageDbList "user" = [Just UserPackageDB]
readPackageDbList other = [Just (SpecificPackageDB other)]
showPackageDbList :: [Maybe PackageDB] -> [String]
showPackageDbList = map showPackageDb
where
showPackageDb Nothing = "clear"
showPackageDb (Just GlobalPackageDB) = "global"
showPackageDb (Just UserPackageDB) = "user"
showPackageDb (Just (SpecificPackageDB db)) = db
liftInstallDirs =
liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v })
......@@ -570,6 +556,21 @@ configureOptions showOrParseArgs =
reqArgFlag title _sf _lf d
(fmap fromPathTemplate . get) (set . fmap toPathTemplate)
readPackageDbList :: String -> [Maybe PackageDB]
readPackageDbList "clear" = [Nothing]
readPackageDbList "global" = [Just GlobalPackageDB]
readPackageDbList "user" = [Just UserPackageDB]
readPackageDbList other = [Just (SpecificPackageDB other)]
showPackageDbList :: [Maybe PackageDB] -> [String]
showPackageDbList = map showPackageDb
where
showPackageDb Nothing = "clear"
showPackageDb (Just GlobalPackageDB) = "global"
showPackageDb (Just UserPackageDB) = "user"
showPackageDb (Just (SpecificPackageDB db)) = db
parseDependency :: Parse.ReadP r (PackageName, InstalledPackageId)
parseDependency = do
x <- parse
......
......@@ -50,6 +50,7 @@ import qualified Distribution.Client.Init.Types as IT
import Distribution.Client.Targets
( UserConstraint, readUserConstraint )
import Distribution.Simple.Compiler (PackageDB)
import Distribution.Simple.Program
( defaultProgramConfiguration )
import Distribution.Simple.Command hiding (boolOpt)
......@@ -57,6 +58,7 @@ import qualified Distribution.Simple.Setup as Cabal
import Distribution.Simple.Setup
( ConfigFlags(..), BuildFlags(..), TestFlags(..), BenchmarkFlags(..)
, SDistFlags(..), HaddockFlags(..)
, readPackageDbList, showPackageDbList
, Flag(..), toFlag, fromFlag, flagToMaybe, flagToList
, optionVerbosity, boolOpt, trueArg, falseArg, numJobsParser )
import Distribution.Simple.InstallDirs
......@@ -700,16 +702,18 @@ instance Monoid GetFlags where
-- ------------------------------------------------------------
data ListFlags = ListFlags {
listInstalled :: Flag Bool,
listInstalled :: Flag Bool,
listSimpleOutput :: Flag Bool,
listVerbosity :: Flag Verbosity
listVerbosity :: Flag Verbosity,
listPackageDBs :: [Maybe PackageDB]
}
defaultListFlags :: ListFlags
defaultListFlags = ListFlags {
listInstalled = Flag False,
listInstalled = Flag False,
listSimpleOutput = Flag False,
listVerbosity = toFlag normal
listVerbosity = toFlag normal,
listPackageDBs = []
}
listCommand :: CommandUI ListFlags
......@@ -732,15 +736,26 @@ listCommand = CommandUI {
listSimpleOutput (\v flags -> flags { listSimpleOutput = v })
trueArg
, option "" ["package-db"]
"Use a given package database. May be a specific file, 'global', 'user' or 'clear'."
listPackageDBs (\v flags -> flags { listPackageDBs = v })
(reqArg' "DB" readPackageDbList showPackageDbList)
]
}
instance Monoid ListFlags where
mempty = defaultListFlags
mempty = ListFlags {
listInstalled = mempty,
listSimpleOutput = mempty,
listVerbosity = mempty,
listPackageDBs = mempty
}
mappend a b = ListFlags {
listInstalled = combine listInstalled,
listInstalled = combine listInstalled,
listSimpleOutput = combine listSimpleOutput,
listVerbosity = combine listVerbosity
listVerbosity = combine listVerbosity,
listPackageDBs = combine listPackageDBs
}
where combine field = field a `mappend` field b
......@@ -749,12 +764,14 @@ instance Monoid ListFlags where
-- ------------------------------------------------------------
data InfoFlags = InfoFlags {
infoVerbosity :: Flag Verbosity
infoVerbosity :: Flag Verbosity,
infoPackageDBs :: [Maybe PackageDB]
}
defaultInfoFlags :: InfoFlags
defaultInfoFlags = InfoFlags {
infoVerbosity = toFlag normal
infoVerbosity = toFlag normal,
infoPackageDBs = []
}
infoCommand :: CommandUI InfoFlags
......@@ -766,13 +783,23 @@ infoCommand = CommandUI {
commandDefaultFlags = defaultInfoFlags,
commandOptions = \_ -> [
optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v })
, option "" ["package-db"]
"Use a given package database. May be a specific file, 'global', 'user' or 'clear'."
infoPackageDBs (\v flags -> flags { infoPackageDBs = v })
(reqArg' "DB" readPackageDbList showPackageDbList)
]
}
instance Monoid InfoFlags where
mempty = defaultInfoFlags
mempty = InfoFlags {
infoVerbosity = mempty,
infoPackageDBs = mempty
}
mappend a b = InfoFlags {
infoVerbosity = combine infoVerbosity
infoVerbosity = combine infoVerbosity,
infoPackageDBs = combine infoPackageDBs
}
where combine field = field a `mappend` field b
......
......@@ -698,7 +698,11 @@ listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()
listAction listFlags extraArgs globalFlags = do
let verbosity = fromFlag (listVerbosity listFlags)
(_, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty
let configFlags = savedConfigureFlags config
let configFlags' = savedConfigureFlags config
configFlags = configFlags' {
configPackageDBs = configPackageDBs configFlags'
`mappend` listPackageDBs listFlags
}
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, _, conf) <- configCompilerAux' configFlags
List.list verbosity
......@@ -714,7 +718,11 @@ infoAction infoFlags extraArgs globalFlags = do
let verbosity = fromFlag (infoVerbosity infoFlags)
targets <- readUserTargets verbosity extraArgs
(_, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty
let configFlags = savedConfigureFlags config
let configFlags' = savedConfigureFlags config
configFlags = configFlags' {
configPackageDBs = configPackageDBs configFlags'
`mappend` infoPackageDBs infoFlags
}
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, _, conf) <- configCompilerAuxEx configFlags
List.info verbosity
......
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