Allow marking commands as hidden and make 'win32selfupgrade' a hidden command.

Hidden commands don't show up in 'cabal help' or 'cabal --help' output.

Cabal/Distribution/Simple/Command.hs

@@ -55,6 +55,7 @@ module Distribution.Simple.Command (
   -- ** Constructing commands
   ShowOrParseArgs(..),
   makeCommand,
+  hiddenCommand,
 
   -- ** Associating actions with commands
   Command,
@@ -113,7 +114,6 @@ data CommandUI flags = CommandUI {
   }
 
 data ShowOrParseArgs = ShowArgs | ParseArgs
-
 type Name        = String
 type Description = String
 
@@ -449,7 +449,15 @@ instance Functor CommandParse where
   fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags)
 
 
-data Command action = Command String String ([String] -> CommandParse action)
+data CommandType = NormalCommand | HiddenCommand
+data Command action =
+  Command String String ([String] -> CommandParse action) CommandType
+
+-- | Mark command as hidden. Hidden commands don't show up in the 'progname
+-- help' or 'progname --help' output.
+hiddenCommand :: Command action -> Command action
+hiddenCommand (Command name synopsys f cmdType) =
+  Command name synopsys f HiddenCommand
 
 commandAddAction :: CommandUI flags
                  -> (flags -> [String] -> action)
@@ -457,8 +465,8 @@ commandAddAction :: CommandUI flags
 commandAddAction command action =
   Command (commandName command)
           (commandSynopsis command)
-          (fmap (uncurry applyDefaultArgs)
-         . commandParseArgs command False)
+          (fmap (uncurry applyDefaultArgs) . commandParseArgs command False)
+          NormalCommand
 
   where applyDefaultArgs mkflags args =
           let flags = mkflags (commandDefaultFlags command)
@@ -475,20 +483,21 @@ commandsRun globalCommand commands args =
     CommandErrors    errs          -> CommandErrors errs
     CommandReadyToGo (mkflags, args') -> case args' of
       ("help":cmdArgs) -> handleHelpCommand cmdArgs
-      (name:cmdArgs) -> case lookupCommand name of
-        [Command _ _ action] -> CommandReadyToGo (flags, action cmdArgs)
-        _                    -> CommandReadyToGo (flags, badCommand name)
-      []                     -> CommandReadyToGo (flags, noCommand)
+      (name:cmdArgs)   -> case lookupCommand name of
+        [Command _ _ action _]
+          -> CommandReadyToGo (flags, action cmdArgs)
+        _ -> CommandReadyToGo (flags, badCommand name)
+      []               -> CommandReadyToGo (flags, noCommand)
      where flags = mkflags (commandDefaultFlags globalCommand)
 
  where
-    lookupCommand cname = [ cmd | cmd@(Command cname' _ _) <- commands'
-                          , cname'==cname ]
+    lookupCommand cname = [ cmd | cmd@(Command cname' _ _ _) <- commands'
+                                , cname' == cname ]
     noCommand        = CommandErrors ["no command given (try --help)\n"]
     badCommand cname = CommandErrors ["unrecognised command: " ++ cname
                                    ++ " (try --help)\n"]
     commands'      = commands ++ [commandAddAction helpCommandUI undefined]
-    commandNames   = [ name | Command name _ _ <- commands' ]
+    commandNames   = [ name | (Command name _ _ _) <- commands' ]
     globalCommand' = globalCommand {
       commandUsage = \pname ->
            (case commandUsage globalCommand pname of
@@ -500,12 +509,13 @@ commandsRun globalCommand commands args =
       commandDescription = Just $ \pname ->
            "Commands:\n"
         ++ unlines [ "  " ++ align name ++ "    " ++ description
-                   | Command name description _ <- commands' ]
+                   | Command name description _ NormalCommand <- commands' ]
         ++ case commandDescription globalCommand of
              Nothing   -> ""
              Just desc -> '\n': desc pname
     }
-      where maxlen = maximum [ length name | Command name _ _ <- commands' ]
+      where maxlen = maximum
+                    [ length name | Command name _ _ NormalCommand <- commands' ]
             align str = str ++ replicate (maxlen - length str) ' '
 
     -- A bit of a hack: support "prog help" as a synonym of "prog --help"
@@ -518,7 +528,7 @@ commandsRun globalCommand commands args =
         CommandReadyToGo (_,[])  -> CommandHelp globalHelp
         CommandReadyToGo (_,(name:cmdArgs')) ->
           case lookupCommand name of
-            [Command _ _ action] ->
+            [Command _ _ action _] ->
               case action ("--help":cmdArgs') of
                 CommandHelp help -> CommandHelp help
                 CommandList _    -> CommandList []

cabal-install/Distribution/Client/Setup.hs

@@ -27,6 +27,7 @@ module Distribution.Client.Setup
     , unpackCommand, UnpackFlags(..)
     , initCommand, IT.InitFlags(..)
     , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
+    , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
 
     , parsePackageArgs
     --TODO: stop exporting these:
@@ -1118,6 +1119,41 @@ instance Monoid SDistExFlags where
     where
       combine field = field a `mappend` field b
 
+-- ------------------------------------------------------------
+-- * Win32SelfUpgrade flags
+-- ------------------------------------------------------------
+
+data Win32SelfUpgradeFlags = Win32SelfUpgradeFlags {
+  win32SelfUpgradeVerbosity :: Flag Verbosity
+}
+
+defaultWin32SelfUpgradeFlags :: Win32SelfUpgradeFlags
+defaultWin32SelfUpgradeFlags = Win32SelfUpgradeFlags {
+  win32SelfUpgradeVerbosity = toFlag normal
+}
+
+win32SelfUpgradeCommand :: CommandUI Win32SelfUpgradeFlags
+win32SelfUpgradeCommand = CommandUI {
+  commandName         = "win32selfupgrade",
+  commandSynopsis     = "Self-upgrade the executable on Windows",
+  commandDescription  = Nothing,
+  commandUsage        = \pname ->
+    "Usage: " ++ pname ++ " win32selfupgrade PID PATH\n\n"
+     ++ "Flags for win32selfupgrade:",
+  commandDefaultFlags = defaultWin32SelfUpgradeFlags,
+  commandOptions      = \_ ->
+      [optionVerbosity win32SelfUpgradeVerbosity
+       (\v flags -> flags { win32SelfUpgradeVerbosity = v})
+      ]
+}
+
+instance Monoid Win32SelfUpgradeFlags where
+  mempty = defaultWin32SelfUpgradeFlags
+  mappend a b = Win32SelfUpgradeFlags {
+    win32SelfUpgradeVerbosity = combine win32SelfUpgradeVerbosity
+  }
+    where combine field = field a `mappend` field b
+
 -- ------------------------------------------------------------
 -- * GetOpt Utils
 -- ------------------------------------------------------------

cabal-install/Main.hs

@@ -28,6 +28,7 @@ import Distribution.Client.Setup
          , ReportFlags(..), reportCommand
          , InitFlags(initVerbosity), initCommand
          , SDistFlags(..), SDistExFlags(..), sdistCommand
+         , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand
          , reportCommand
          , unpackCommand, UnpackFlags(..) )
 import Distribution.Simple.Setup
@@ -73,7 +74,7 @@ import Distribution.Simple.Utils
 import Distribution.Text
          ( display )
 import Distribution.Verbosity as Verbosity
-       ( Verbosity, normal, intToVerbosity, lessVerbose )
+       ( Verbosity, normal, lessVerbose )
 import qualified Paths_cabal_install (version)
 
 import System.Environment       (getArgs, getProgName)
@@ -81,7 +82,6 @@ import System.Exit              (exitFailure)
 import System.FilePath          (splitExtension, takeExtension)
 import System.Directory         (doesFileExist)
 import Data.List                (intersperse)
-import Data.Maybe               (fromMaybe)
 import Data.Monoid              (Monoid(..))
 import Control.Monad            (unless)
 
@@ -91,7 +91,6 @@ main :: IO ()
 main = getArgs >>= mainWorker
 
 mainWorker :: [String] -> IO ()
-mainWorker ("win32selfupgrade":args) = win32SelfUpgradeAction args
 mainWorker args = topHandler $
   case commandsRun globalCommand commands args of
     CommandHelp   help                 -> printGlobalHelp help
@@ -155,6 +154,8 @@ mainWorker args = topHandler $
       ,wrapperAction benchmarkCommand
                      benchmarkVerbosity     benchmarkDistPref
       ,upgradeCommand         `commandAddAction` upgradeAction
+      ,hiddenCommand $
+       win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction
       ]
 
 wrapperAction :: Monoid flags
@@ -373,15 +374,12 @@ initAction initFlags _extraArgs globalFlags = do
 
 -- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.
 --
-win32SelfUpgradeAction :: [String] -> IO ()
-win32SelfUpgradeAction (pid:path:rest) =
+win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> GlobalFlags
+                          -> IO ()
+win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do
+  let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags)
   Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path
-  where
-    verbosity = case rest of
-      (['-','-','v','e','r','b','o','s','e','=',n]:_) | n `elem` ['0'..'9']
-         -> fromMaybe Verbosity.normal (Verbosity.intToVerbosity (read [n]))
-      _  ->           Verbosity.normal
-win32SelfUpgradeAction _ = return ()
+win32SelfUpgradeAction _ _ _ = return ()
 
 --
 -- Utils (transitionary)