mirror of
https://github.com/ilyakooo0/optparse-applicative.git
synced 2024-09-11 10:45:25 +03:00
Add ability to display help text for commands and subcommands if the user provides no input for them
This commit is contained in:
parent
b1647a34a4
commit
162e53fbf2
@ -81,6 +81,7 @@ module Options.Applicative.Builder (
|
||||
multiSuffix,
|
||||
disambiguate,
|
||||
showHelpOnError,
|
||||
showHelpOnEmpty,
|
||||
noBacktrack,
|
||||
columns,
|
||||
prefs,
|
||||
@ -370,6 +371,9 @@ disambiguate = PrefsMod $ \p -> p { prefDisambiguate = True }
|
||||
showHelpOnError :: PrefsMod
|
||||
showHelpOnError = PrefsMod $ \p -> p { prefShowHelpOnError = True }
|
||||
|
||||
showHelpOnEmpty :: PrefsMod
|
||||
showHelpOnEmpty = PrefsMod $ \p -> p { prefShowHelpOnEmpty = True }
|
||||
|
||||
noBacktrack :: PrefsMod
|
||||
noBacktrack = PrefsMod $ \p -> p { prefBacktrack = False }
|
||||
|
||||
@ -383,6 +387,7 @@ prefs m = applyPrefsMod m base
|
||||
{ prefMultiSuffix = ""
|
||||
, prefDisambiguate = False
|
||||
, prefShowHelpOnError = False
|
||||
, prefShowHelpOnEmpty = False
|
||||
, prefBacktrack = True
|
||||
, prefColumns = 80 }
|
||||
|
||||
|
@ -100,7 +100,7 @@ argMatches opt arg = case opt of
|
||||
prefs <- getPrefs
|
||||
let runSubparser
|
||||
| prefBacktrack prefs = \i a ->
|
||||
runParser (getPolicy i) (infoParser i) a
|
||||
runParser (getPolicy i) CmdStart (infoParser i) a
|
||||
| otherwise = \i a
|
||||
-> (,) <$> runParserInfo i a <*> pure []
|
||||
enterContext arg subp *> runSubparser subp args <* exitContext
|
||||
@ -201,16 +201,16 @@ stepParser pprefs AllowOpts arg p = msum
|
||||
-- | Apply a 'Parser' to a command line, and return a result and leftover
|
||||
-- arguments. This function returns an error if any parsing error occurs, or
|
||||
-- if any options are missing and don't have a default value.
|
||||
runParser :: MonadP m => ArgPolicy -> Parser a -> Args -> m (a, Args)
|
||||
runParser SkipOpts p ("--" : argt) = runParser AllowOpts p argt
|
||||
runParser policy p args = case args of
|
||||
[] -> exitP p result
|
||||
runParser :: MonadP m => ArgPolicy -> IsCmdStart -> Parser a -> Args -> m (a, Args)
|
||||
runParser SkipOpts _ p ("--" : argt) = runParser AllowOpts CmdCont p argt
|
||||
runParser policy touched p args = case args of
|
||||
[] -> exitP touched p result
|
||||
(arg : argt) -> do
|
||||
prefs <- getPrefs
|
||||
(mp', args') <- do_step prefs arg argt
|
||||
case mp' of
|
||||
Nothing -> hoistMaybe result <|> parseError arg
|
||||
Just p' -> runParser policy p' args'
|
||||
Just p' -> runParser policy CmdCont p' args'
|
||||
where
|
||||
result = (,) <$> evalParser p <*> pure args
|
||||
do_step prefs arg argt = (`runStateT` argt)
|
||||
@ -234,7 +234,7 @@ runParserInfo i = runParserFully (getPolicy i) (infoParser i)
|
||||
|
||||
runParserFully :: MonadP m => ArgPolicy -> Parser a -> Args -> m a
|
||||
runParserFully policy p args = do
|
||||
(r, args') <- runParser policy p args
|
||||
(r, args') <- runParser policy CmdStart p args
|
||||
case args' of
|
||||
[] -> return r
|
||||
a:_ -> parseError a
|
||||
|
@ -147,11 +147,11 @@ parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->
|
||||
in (h, exit_code, prefColumns pprefs)
|
||||
where
|
||||
exit_code = case msg of
|
||||
ErrorMsg _ -> ExitFailure (infoFailureCode pinfo)
|
||||
UnknownError -> ExitFailure (infoFailureCode pinfo)
|
||||
MissingError _ -> ExitFailure (infoFailureCode pinfo)
|
||||
ShowHelpText -> ExitSuccess
|
||||
InfoMsg _ -> ExitSuccess
|
||||
ErrorMsg _ -> ExitFailure (infoFailureCode pinfo)
|
||||
UnknownError -> ExitFailure (infoFailureCode pinfo)
|
||||
MissingError _ _ -> ExitFailure (infoFailureCode pinfo)
|
||||
ShowHelpText -> ExitSuccess
|
||||
InfoMsg _ -> ExitSuccess
|
||||
|
||||
with_context :: [Context]
|
||||
-> ParserInfo a
|
||||
@ -167,11 +167,13 @@ parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->
|
||||
, fmap (indent 2) . infoProgDesc $ i ]
|
||||
|
||||
error_help = errorHelp $ case msg of
|
||||
ShowHelpText -> mempty
|
||||
ErrorMsg m -> stringChunk m
|
||||
InfoMsg m -> stringChunk m
|
||||
MissingError (SomeParser x) -> stringChunk "Missing:" <<+>> briefDesc pprefs x
|
||||
UnknownError -> mempty
|
||||
ShowHelpText -> mempty
|
||||
ErrorMsg m -> stringChunk m
|
||||
InfoMsg m -> stringChunk m
|
||||
MissingError CmdStart _ | prefShowHelpOnEmpty pprefs
|
||||
-> mempty
|
||||
MissingError _ (SomeParser x) -> stringChunk "Missing:" <<+>> briefDesc pprefs x
|
||||
UnknownError -> mempty
|
||||
|
||||
base_help :: ParserInfo a -> ParserHelp
|
||||
base_help i
|
||||
@ -184,8 +186,9 @@ parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->
|
||||
f = footerHelp (infoFooter i)
|
||||
|
||||
show_full_help = case msg of
|
||||
ShowHelpText -> True
|
||||
_ -> prefShowHelpOnError pprefs
|
||||
ShowHelpText -> True
|
||||
MissingError CmdStart _ -> prefShowHelpOnEmpty pprefs || prefShowHelpOnError pprefs
|
||||
_ -> prefShowHelpOnError pprefs
|
||||
|
||||
renderFailure :: ParserFailure ParserHelp -> String -> (String, ExitCode)
|
||||
renderFailure failure progn =
|
||||
|
@ -46,7 +46,7 @@ class (Alternative m, MonadPlus m) => MonadP m where
|
||||
missingArgP :: ParseError -> Completer -> m a
|
||||
tryP :: m a -> m (Either ParseError a)
|
||||
errorP :: ParseError -> m a
|
||||
exitP :: Parser b -> Maybe a -> m a
|
||||
exitP :: IsCmdStart -> Parser b -> Maybe a -> m a
|
||||
|
||||
newtype P a = P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a)
|
||||
|
||||
@ -81,7 +81,7 @@ instance MonadP P where
|
||||
|
||||
missingArgP e _ = errorP e
|
||||
tryP (P p) = P $ lift $ runExceptT p
|
||||
exitP p = P . (maybe (throwE . MissingError . SomeParser $ p) return)
|
||||
exitP i p = P . (maybe (throwE . MissingError i . SomeParser $ p) return)
|
||||
errorP = P . throwE
|
||||
|
||||
hoistMaybe :: MonadPlus m => Maybe a -> m a
|
||||
@ -154,7 +154,7 @@ instance MonadP Completion where
|
||||
|
||||
missingArgP _ = Completion . lift . lift . ComplOption
|
||||
tryP (Completion p) = Completion $ catchE (Right <$> p) (return . Left)
|
||||
exitP p _ = Completion . lift . lift . ComplParser $ SomeParser p
|
||||
exitP _ p _ = Completion . lift . lift . ComplParser $ SomeParser p
|
||||
errorP = Completion . throwE
|
||||
|
||||
runCompletion :: Completion r -> ParserPrefs -> Maybe (Either SomeParser Completer)
|
||||
|
@ -29,6 +29,7 @@ module Options.Applicative.Types (
|
||||
ParserHelp(..),
|
||||
SomeParser(..),
|
||||
Context(..),
|
||||
IsCmdStart(..),
|
||||
|
||||
fromM,
|
||||
oneM,
|
||||
@ -61,7 +62,10 @@ data ParseError
|
||||
| InfoMsg String
|
||||
| ShowHelpText
|
||||
| UnknownError
|
||||
| MissingError SomeParser
|
||||
| MissingError IsCmdStart SomeParser
|
||||
|
||||
data IsCmdStart = CmdStart | CmdCont
|
||||
deriving Show
|
||||
|
||||
instance Monoid ParseError where
|
||||
mempty = UnknownError
|
||||
@ -91,6 +95,8 @@ data ParserPrefs = ParserPrefs
|
||||
-- (default: False)
|
||||
, prefShowHelpOnError :: Bool -- ^ always show help text on parse errors
|
||||
-- (default: False)
|
||||
, prefShowHelpOnEmpty :: Bool -- ^ show the help text for a command or subcommand
|
||||
-- if it fails with no input (default: False)
|
||||
, prefBacktrack :: Bool -- ^ backtrack to parent parser when a
|
||||
-- subcommand fails (default: True)
|
||||
, prefColumns :: Int -- ^ number of columns in the terminal, used to
|
||||
|
@ -199,6 +199,24 @@ case_context_carry = do
|
||||
i = info (p0 <**> helper) idm
|
||||
checkHelpTextWith (ExitFailure 1) defaultPrefs "carry" i ["b", "-aA", "c"]
|
||||
|
||||
case_help_on_empty :: Assertion
|
||||
case_help_on_empty = do
|
||||
let p3 = strOption (short 'a' <> metavar "A")
|
||||
p2 = subparser (command "b" (info p3 idm) <> metavar "B")
|
||||
p1 = subparser (command "c" (info p3 idm) <> metavar "C")
|
||||
p0 = (,) <$> p2 <*> p1
|
||||
i = info (p0 <**> helper) idm
|
||||
checkHelpTextWith (ExitFailure 1) (prefs showHelpOnEmpty) "helponempty" i []
|
||||
|
||||
case_help_on_empty_sub :: Assertion
|
||||
case_help_on_empty_sub = do
|
||||
let p3 = strOption (short 'a' <> metavar "A" <> help "both commands require this")
|
||||
p2 = subparser (command "b" (info p3 idm) <> metavar "B")
|
||||
p1 = subparser (command "c" (info p3 idm) <> metavar "C")
|
||||
p0 = (,) <$> p2 <*> p1
|
||||
i = info (p0 <**> helper) idm
|
||||
checkHelpTextWith (ExitFailure 1) (prefs showHelpOnEmpty) "helponemptysub" i ["b", "-aA", "c"]
|
||||
|
||||
case_many_args :: Assertion
|
||||
case_many_args = do
|
||||
let p = many (argument str idm)
|
||||
|
8
tests/helponempty.err.txt
Normal file
8
tests/helponempty.err.txt
Normal file
@ -0,0 +1,8 @@
|
||||
Usage: helponempty B C
|
||||
|
||||
Available options:
|
||||
-h,--help Show this help text
|
||||
|
||||
Available commands:
|
||||
b
|
||||
c
|
4
tests/helponemptysub.err.txt
Normal file
4
tests/helponemptysub.err.txt
Normal file
@ -0,0 +1,4 @@
|
||||
Usage: helponemptysub c -a A
|
||||
|
||||
Available options:
|
||||
-a A both commands require this
|
Loading…
Reference in New Issue
Block a user