Add ability to display help text for commands and subcommands if the user provides no input for them

Options/Applicative/Builder.hs

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

Options/Applicative/Common.hs

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

Options/Applicative/Extra.hs

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

Options/Applicative/Internal.hs

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

Options/Applicative/Types.hs

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

tests/Tests.hs

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

tests/helponempty.err.txt

@@ -0,0 +1,8 @@
+Usage: helponempty B C
+
+Available options:
+  -h,--help                Show this help text
+
+Available commands:
+  b                        
+  c                        

tests/helponemptysub.err.txt

@@ -0,0 +1,4 @@
+Usage: helponemptysub c -a A
+
+Available options:
+  -a A                     both commands require this