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

Fixes #1598.

Cabal/Distribution/Simple/Setup.hs

@@ -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

cabal-install/Distribution/Client/Setup.hs

@@ -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
 

cabal-install/Main.hs

@@ -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