Commit 673ecb2f authored by refold's avatar refold

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

Hidden commands don't show up in 'cabal help' or 'cabal --help' output.
parent 38a79ab9
......@@ -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 []
......
......@@ -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
-- ------------------------------------------------------------
......
......@@ -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)
......
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