Add Parser groups, similar to Command groups

optparse-applicative.cabal

@@ -131,6 +131,10 @@ test-suite tests
                      , Examples.Formatting
                      , Examples.Hello
                      , Examples.LongSub
+                     , Examples.ParserGroup.AllGrouped
+                     , Examples.ParserGroup.Basic
+                     , Examples.ParserGroup.Duplicates
+                     , Examples.ParserGroup.Nested
 
   build-depends:       base
                      , optparse-applicative

src/Options/Applicative.hs

@@ -105,6 +105,7 @@ module Options.Applicative (
   completer,
   idm,
   mappend,
+  parserOptionGroup,
 
   OptionFields,
   FlagFields,

src/Options/Applicative/Builder.hs

@@ -49,6 +49,7 @@ module Options.Applicative.Builder (
   completer,
   idm,
   mappend,
+  parserOptionGroup,
 
   -- * Readers
   --
@@ -379,6 +380,45 @@ option r m = mkParser d g rdr
     crdr = CReader (optCompleter fields) r
     rdr = OptReader (optNames fields) crdr (optNoArgError fields)
 
+-- | Add group to 'OptProperties'. Always overwrites the group, if it exists.
+-- This means, in particular, that we do not allow "nested groups" i.e. a
+-- parser group within a parser group.
+optPropertiesGroup :: String -> OptProperties -> OptProperties
+-- If we changed this to only overwrite Nothing, it would allow users to
+-- defined "nested groups" e.g.
+--
+--     parserOptionGroup "General group" $
+--       (,)
+--         <$> parserA
+--         <*> parserOptionGroup "B group" parserB
+--
+-- Despite the nested definition, these would still be flatted on the help
+-- page.
+--
+-- Since we __always__ overwrite the group, the above instead puts
+-- parserA and parserB into the same "General group". We judge this to be
+-- simpler.
+optPropertiesGroup grp o = o { propGroup = Just grp }
+
+-- | Add a group to 'Option'.
+optionGroup :: String -> Option a -> Option a
+optionGroup grp o = o { optProps = props' }
+  where
+    props' = optPropertiesGroup grp (optProps o)
+
+-- | @parserOptionGroup g p@ groups all of @p@'s option subparsers into the
+-- same group in the 'Additional options:' section on the help page. That is,
+-- if @q@ is a subparser of @p@ and @q@ is either a regular option or a flag,
+-- then it will be displayed in the given group.
+--
+-- @since 0.19.0.0
+parserOptionGroup :: String -> Parser a -> Parser a
+parserOptionGroup _ (NilP x) = NilP x
+parserOptionGroup g (OptP o) = OptP (optionGroup g o)
+parserOptionGroup g (MultP p1 p2) = MultP (parserOptionGroup g p1) (parserOptionGroup g p2)
+parserOptionGroup g (AltP p1 p2) = AltP (parserOptionGroup g p1) (parserOptionGroup g p2)
+parserOptionGroup g (BindP p1 p2) = BindP (parserOptionGroup g p1) (\x -> parserOptionGroup g (p2 x))
+
 -- | Modifier for 'ParserInfo'.
 newtype InfoMod a = InfoMod
   { applyInfoMod :: ParserInfo a -> ParserInfo a }

src/Options/Applicative/Builder/Internal.hs

@@ -150,6 +150,7 @@ baseProps = OptProperties
   , propShowDefault = Nothing
   , propDescMod = Nothing
   , propShowGlobal = True
+  , propGroup = Nothing
   }
 
 mkCommand :: Mod CommandFields a -> (Maybe String, [(String, ParserInfo a)])

src/Options/Applicative/Help/Core.hs

@@ -24,7 +24,7 @@ import Control.Monad (guard)
 import Data.Function (on)
 import Data.List (sort, intersperse, groupBy)
 import Data.Foldable (any, foldl')
-import Data.Maybe (catMaybes, fromMaybe)
+import Data.Maybe (fromMaybe)
 #if !MIN_VERSION_base(4,8,0)
 import Data.Monoid (mempty)
 #endif
@@ -34,6 +34,7 @@ import Data.Semigroup (Semigroup (..))
 import Prelude hiding (any)
 
 import Options.Applicative.Common
+import Options.Applicative.Internal (sortGroupFst)
 import Options.Applicative.Types
 import Options.Applicative.Help.Pretty
 import Options.Applicative.Help.Chunk
@@ -50,12 +51,13 @@ safelast :: [a] -> Maybe a
 safelast = foldl' (const Just) Nothing
 
 -- | Generate description for a single option.
-optDesc :: ParserPrefs -> OptDescStyle -> ArgumentReachability -> Option a -> (Chunk Doc, Parenthetic)
+optDesc :: ParserPrefs -> OptDescStyle -> ArgumentReachability -> Option a -> (Maybe String, Chunk Doc, Parenthetic)
 optDesc pprefs style _reachability opt =
   let names =
         sort . optionNames . optMain $ opt
       meta =
         stringChunk $ optMetaVar opt
+      grp = propGroup $ optProps opt
       descs =
         map (pretty . showOption) names
       descriptions =
@@ -86,7 +88,7 @@ optDesc pprefs style _reachability opt =
           desc
       modified =
         maybe id fmap (optDescMod opt) rendered
-   in (modified, wrapping)
+   in (grp, modified, wrapping)
 
 -- | Generate descriptions for commands.
 cmdDesc :: ParserPrefs -> Parser a -> [(Maybe String, Chunk Doc)]
@@ -118,7 +120,7 @@ briefDesc' showOptional pprefs =
   wrapOver NoDefault MaybeRequired
     . foldTree pprefs style
     . mfilterOptional
-    . treeMapParser (optDesc pprefs style)
+    . treeMapParser (\a -> (\(_, x, y) -> (x, y)) . optDesc pprefs style a)
   where
     mfilterOptional
       | showOptional =
@@ -193,14 +195,31 @@ globalDesc = optionsDesc True
 
 -- | Common generator for full descriptions and globals
 optionsDesc :: Bool -> ParserPrefs -> Parser a -> Chunk Doc
-optionsDesc global pprefs = tabulate (prefTabulateFill pprefs) . catMaybes . mapParser doc
+optionsDesc global pprefs p = vsepChunks
+  . fmap formatTitle
+  . fmap tabulateGroup
+  . groupByTitle
+  $ mapParser doc p
   where
+    groupByTitle :: [Maybe (Maybe String, (Doc, Doc))] -> [[(Maybe String, (Doc, Doc))]]
+    groupByTitle = sortGroupFst
+
+    tabulateGroup :: [(Maybe String, (Doc, Doc))] -> (Maybe String, Chunk Doc)
+    tabulateGroup l@((title,_):_) = (title, tabulate (prefTabulateFill pprefs) (snd <$> l))
+    tabulateGroup [] = mempty
+
+    formatTitle :: (Maybe String, Chunk Doc) -> Chunk Doc
+    formatTitle (mTitle, opts) = case mTitle of
+      Nothing -> opts
+      Just title -> (pretty (title ++ ":") .$.) <$> opts
+
+    doc :: ArgumentReachability -> Option a -> Maybe (Maybe String, (Doc, Doc))
     doc info opt = do
       guard . not . isEmpty $ n
       guard . not . isEmpty $ h
-      return (extractChunk n, align . extractChunk $ h <</>> hdef)
+      return (grp, (extractChunk n, align . extractChunk $ h <<+>> hdef))
       where
-        n = fst $ optDesc pprefs style info opt
+        (grp, n, _) = optDesc pprefs style info opt
         h = optHelp opt
         hdef = Chunk . fmap show_def . optShowDefault $ opt
         show_def s = parens (pretty "default:" <+> pretty s)

src/Options/Applicative/Internal.hs

@@ -24,6 +24,8 @@ module Options.Applicative.Internal
   , cut
   , (<!>)
   , disamb
+
+  , sortGroupFst
   ) where
 
 import Control.Applicative
@@ -35,6 +37,9 @@ import Control.Monad.Trans.Except
 import Control.Monad.Trans.Reader
   (mapReaderT, runReader, runReaderT, Reader, ReaderT, ask)
 import Control.Monad.Trans.State (StateT, get, put, modify, evalStateT, runStateT)
+import Data.Function (on)
+import Data.List (groupBy, sortBy)
+import Data.Maybe (catMaybes)
 
 import Options.Applicative.Types
 
@@ -266,3 +271,15 @@ hoistList :: Alternative m => [a] -> m a
 hoistList = foldr cons empty
   where
     cons x xs = pure x <|> xs
+
+-- | Strips 'Nothing', sorts then groups on the first element of the tuple.
+sortGroupFst :: (Ord a) => [Maybe (a, b)] -> [[(a, b)]]
+sortGroupFst =
+  groupFst
+    -- By sorting prior to grouping, we ensure all Eq a's are consecutive,
+    -- meaning we are guaranteed to have exactly one representative for
+    -- each group.
+    . sortBy (compare `on` fst)
+    . catMaybes
+  where
+    groupFst = groupBy ((==) `on` fst)

src/Options/Applicative/Types.hs

@@ -155,17 +155,20 @@ data OptProperties = OptProperties
   , propShowDefault :: Maybe String       -- ^ what to show in the help text as the default
   , propShowGlobal :: Bool                -- ^ whether the option is presented in global options text
   , propDescMod :: Maybe ( Doc -> Doc )   -- ^ a function to run over the brief description
+  , propGroup :: Maybe String             -- ^ optional group name
   }
 
 instance Show OptProperties where
-  showsPrec p (OptProperties pV pH pMV pSD pSG _)
+  showsPrec p (OptProperties pV pH pMV pSD pSG _ pGrp)
     = showParen (p >= 11)
     $ showString "OptProperties { propVisibility = " . shows pV
     . showString ", propHelp = " . shows pH
     . showString ", propMetaVar = " . shows pMV
     . showString ", propShowDefault = " . shows pSD
     . showString ", propShowGlobal = " . shows pSG
-    . showString ", propDescMod = _ }"
+    . showString ", propDescMod = _"
+    . showString ", propGroup = " . shows pGrp
+    . showString "}"
 
 -- | A single option of a parser.
 data Option a = Option

tests/Examples/ParserGroup/AllGrouped.hs

@@ -0,0 +1,93 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Examples.ParserGroup.AllGrouped (opts) where
+
+import Options.Applicative
+
+-- Tests the help page when every option belongs to some group i.e. there are
+-- no top-level options. Notice we put the helper (<**> helper) __inside__
+-- one of the groups, so that it is not a top-level option.
+--
+-- Also notice that although we add cmdParser to the same group, it is __not__
+-- rendered as part of this group. This is what we want, as it is an Argument
+-- and should not be rendered with the Options.
+
+data LogGroup = LogGroup
+  { logPath :: Maybe String,
+    logVerbosity :: Maybe Int
+  }
+  deriving (Show)
+
+data SystemGroup = SystemGroup
+  { poll :: Bool,
+    timeout :: Int
+  }
+  deriving (Show)
+
+data Sample = Sample
+  { logGroup :: LogGroup,
+    systemGroup :: SystemGroup,
+    cmd :: String
+  }
+  deriving (Show)
+
+sample :: Parser Sample
+sample = do
+  logGroup <- parseLogGroup
+  systemGroup <- parseSystemGroup
+  cmd <- parseCmd
+
+  pure $
+    Sample
+      { logGroup,
+        systemGroup,
+        cmd
+      }
+  where
+    parseLogGroup =
+      parserOptionGroup "Logging" $
+        LogGroup
+          <$> optional
+            ( strOption
+                ( long "file-log-path"
+                    <> metavar "PATH"
+                    <> help "Log file path"
+                )
+            )
+          <*> optional
+            ( option
+                auto
+                ( long "file-log-verbosity"
+                    <> metavar "INT"
+                    <> help "File log verbosity"
+                )
+            )
+          <**> helper
+
+    parseSystemGroup =
+      parserOptionGroup "System Options" $
+        SystemGroup
+          <$> switch
+            ( long "poll"
+                <> help "Whether to poll"
+            )
+          <*> ( option
+                  auto
+                  ( long "timeout"
+                      <> metavar "INT"
+                      <> help "Whether to time out"
+                  )
+              )
+
+    parseCmd = argument str (metavar "Command")
+
+opts :: ParserInfo Sample
+opts =
+  info
+    sample
+    ( fullDesc
+        <> progDesc "Every option is grouped"
+        <> header "parser_group.all_grouped - a test for optparse-applicative"
+    )
+