[commit: Cabal] master: Add a verbosity flag to the info list update and fetch commands (55d95fa)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/55d95fa57a9139684ad58f8f037734377273cdd4

>---------------------------------------------------------------

commit 55d95fa57a9139684ad58f8f037734377273cdd4
Author: Duncan Coutts <duncan at haskell.org>
Date:   Mon Dec 17 19:00:35 2007 +0000

    Add a verbosity flag to the info list update and fetch commands

>---------------------------------------------------------------

 cabal-install/Hackage/Setup.hs |   39 +++++++++++++++++++++++++--------------
 cabal-install/Main.hs          |   31 +++++++++++++++++++------------
 2 files changed, 44 insertions(+), 26 deletions(-)

diff --git a/cabal-install/Hackage/Setup.hs b/cabal-install/Hackage/Setup.hs
index 0ffcb27..6fc41d6 100644
--- a/cabal-install/Hackage/Setup.hs
+++ b/cabal-install/Hackage/Setup.hs
@@ -40,8 +40,9 @@ import qualified Distribution.Simple.Setup as Cabal
   RegisterFlags(..), emptyRegisterFlags, registerCommand, unregisterCommand,
   SDistFlags(..),    emptySDistFlags,    sdistCommand,
                                          testCommand-})
-import Distribution.Simple.Setup (fromFlagOrDefault, flagToMaybe)
---import System.Console.GetOpt (ArgDescr (..), OptDescr (..))
+import Distribution.Simple.Setup (Flag, toFlag, fromFlagOrDefault,
+                                  flagToMaybe, flagToList)
+import Distribution.Verbosity (Verbosity, normal, flagToVerbosity, showForCabal)
 
 import Hackage.Types (ConfigFlags(..), UnresolvedDependency(..))
 import Hackage.Utils (readPToMaybe, parseDependencyOrPackageId)
@@ -94,34 +95,34 @@ installCommand = (Cabal.configureCommand defaultProgramConfiguration) {
     commandUsage    = usagePackages "install"
   }
 
-fetchCommand :: CommandUI ()
+fetchCommand :: CommandUI (Flag Verbosity)
 fetchCommand = CommandUI {
     commandName         = "fetch",
     commandSynopsis     = "Downloads packages for later installation or study.",
     commandDescription  = Nothing,
     commandUsage        = usagePackages "fetch",
-    commandDefaultFlags = (),
-    commandOptions      = \_ -> []
+    commandDefaultFlags = toFlag normal,
+    commandOptions      = \_ -> [optionVerbose id const]
   }
 
-listCommand  :: CommandUI ()
+listCommand  :: CommandUI (Flag Verbosity)
 listCommand = CommandUI {
     commandName         = "list",
     commandSynopsis     = "List available packages on the server (cached).",
     commandDescription  = Nothing,
     commandUsage        = usagePackages "list",
-    commandDefaultFlags = (),
-    commandOptions      = \_ -> []
+    commandDefaultFlags = toFlag normal,
+    commandOptions      = \_ -> [optionVerbose id const]
   }
 
-updateCommand  :: CommandUI ()
+updateCommand  :: CommandUI (Flag Verbosity)
 updateCommand = CommandUI {
     commandName         = "update",
     commandSynopsis     = "Updates list of known packages",
     commandDescription  = Nothing,
     commandUsage        = usagePackages "update",
-    commandDefaultFlags = (),
-    commandOptions      = \_ -> []
+    commandDefaultFlags = toFlag normal,
+    commandOptions      = \_ -> [optionVerbose id const]
   }
 
 {-
@@ -135,16 +136,26 @@ cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
     options _  = []
 -}
 
-infoCommand  :: CommandUI ()
+infoCommand  :: CommandUI (Flag Verbosity)
 infoCommand = CommandUI {
     commandName         = "info",
     commandSynopsis     = "Emit some info about dependency resolution",
     commandDescription  = Nothing,
     commandUsage        = usagePackages "info",
-    commandDefaultFlags = (),
-    commandOptions      = \_ -> []
+    commandDefaultFlags = toFlag normal,
+    commandOptions      = \_ -> [optionVerbose id const]
   }
 
+optionVerbose :: (flags -> Flag Verbosity)
+              -> (Flag Verbosity -> flags -> flags)
+              -> Option flags
+optionVerbose get set =
+  option "v" ["verbose"]
+    "Control verbosity (n is 0--3, default verbosity level is 1)"
+    get set
+    (optArg "n" (toFlag . flagToVerbosity)
+                (fmap (Just . showForCabal) . flagToList))
+
 usagePackages :: String -> String -> String
 usagePackages pname name =
      "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"
diff --git a/cabal-install/Main.hs b/cabal-install/Main.hs
index 57b6ba0..2a25302 100644
--- a/cabal-install/Main.hs
+++ b/cabal-install/Main.hs
@@ -14,7 +14,9 @@
 module Main where
 
 import Hackage.Setup
+import Hackage.Types (ConfigFlags(..))
 import Distribution.PackageDescription (cabalVersion)
+import Distribution.Simple.Setup (Flag, fromFlagOrDefault)
 import qualified Distribution.Simple.Setup as Cabal
 import Distribution.Simple.Setup (fromFlag)
 import Distribution.Simple.Command
@@ -27,6 +29,7 @@ import Hackage.Update           (update)
 import Hackage.Fetch            (fetch)
 --import Hackage.Clean            (clean)
 
+import Distribution.Verbosity   (Verbosity, normal)
 import Distribution.Version     (showVersion)
 import qualified Paths_cabal_install (version)
 
@@ -126,31 +129,35 @@ installAction flags extraArgs =
       (comp, conf) <- findCompiler config
       install config comp conf flags pkgs
 
-infoAction :: () -> Args -> IO ()
-infoAction _flags extraArgs = do
+infoAction :: Cabal.Flag Verbosity -> Args -> IO ()
+infoAction flags extraArgs = do
   configFile <- defaultConfigFile --FIXME
-  config <- loadConfig configFile
+  config0 <- loadConfig configFile
+  let config = config0 { configVerbose = fromFlagOrDefault normal flags }
   (comp, conf) <- findCompiler config
   case parsePackageArgs extraArgs of
     Left  err  -> putStrLn err >> exitWith (ExitFailure 1)
     Right pkgs -> info config comp conf [] pkgs
 
-listAction :: () -> Args -> IO ()
-listAction _flags extraArgs = do
+listAction :: Cabal.Flag Verbosity -> Args -> IO ()
+listAction flags extraArgs = do
   configFile <- defaultConfigFile --FIXME
-  config <- loadConfig configFile
+  config0 <- loadConfig configFile
+  let config = config0 { configVerbose = fromFlagOrDefault normal flags }
   list config extraArgs
 
-updateAction :: () -> Args -> IO ()
-updateAction _flags _extraArgs = do
+updateAction :: Flag Verbosity -> Args -> IO ()
+updateAction flags _extraArgs = do
   configFile <- defaultConfigFile --FIXME
-  config <- loadConfig configFile
+  config0 <- loadConfig configFile
+  let config = config0 { configVerbose = fromFlagOrDefault normal flags }
   update config
 
-fetchAction :: () -> Args -> IO ()
-fetchAction _flags extraArgs = do
+fetchAction :: Flag Verbosity -> Args -> IO ()
+fetchAction flags extraArgs = do
   configFile <- defaultConfigFile --FIXME
-  config <- loadConfig configFile
+  config0 <- loadConfig configFile
+  let config = config0 { configVerbose = fromFlagOrDefault normal flags }
   (comp, conf) <- findCompiler config
   case parsePackageArgs extraArgs of
     Left  err  -> putStrLn err >> exitWith (ExitFailure 1)