Add Option groups

CHANGELOG.md

@@ -1,3 +1,9 @@
+## Version 0.19.0.0
+
+- Add `parserOptionGroup` for grouping Options together, similar to command
+  groups. Requires the breaking change of adding the `propGroup :: OptGroup`
+  field to `OptProperties`.
+
 ## Version 0.18.1.0 (29 May 2023)
 
 - Change pretty printer layout algorithm used.

README.md

@@ -748,6 +748,48 @@ main = customExecParser p opts
     p = prefs showHelpOnEmpty
 ```
 
+#### Option groups
+
+The `parserOptionGroup` function can be used to group options together under
+a common heading. For example, if we have:
+
+```haskell
+Args
+  <$> parseMain
+  <*> parserOptionGroup "Group A" parseA
+  <*> parserOptionGroup "Group B" parseB
+  <*> parseOther
+```
+
+Then the `--help` page `Available options` will look like:
+
+```
+Available options:
+  <main options>
+
+Group A:
+  <A options>
+
+Group B:
+  <B options>
+
+Available options:
+  <other options>
+```
+
+Caveats:
+
+- Parser groups are like command groups in that groups are listed in creation
+  order, and (non-consecutive) duplicate groups are allowed.
+
+- Nested groups are concatenated:
+
+    ```haskell
+    parserOptionGroup "Group A" (parserOptionGroup "Group Z" parseA)
+    ```
+
+    Will group `parseA` under `GroupA.Group Z`.
+
 ### Command groups
 
 One experimental feature which may be useful for programs with many

optparse-applicative.cabal

@@ -39,6 +39,12 @@ extra-source-files:  CHANGELOG.md
                      tests/formatting-long-subcommand.err.txt
                      tests/nested.err.txt
                      tests/optional.err.txt
+                     tests/parser_group_all_grouped.err.txt
+                     tests/parser_group_basic.err.txt
+                     tests/parser_group_command_groups.err.txt
+                     tests/parser_group_duplicate_command_groups.err.txt
+                     tests/parser_group_duplicates.err.txt
+                     tests/parser_group_nested.err.txt
                      tests/nested_optional.err.txt
                      tests/subparsers.err.txt
 
@@ -131,6 +137,12 @@ test-suite tests
                      , Examples.Formatting
                      , Examples.Hello
                      , Examples.LongSub
+                     , Examples.ParserGroup.AllGrouped
+                     , Examples.ParserGroup.Basic
+                     , Examples.ParserGroup.CommandGroups
+                     , Examples.ParserGroup.DuplicateCommandGroups
+                     , 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
   --
@@ -107,8 +108,8 @@ module Options.Applicative.Builder (
   ) where
 
 import Control.Applicative
-#if __GLASGOW_HASKELL__ <= 802
-import Data.Semigroup hiding (option)
+#if __GLASGOW_HASKELL__ < 804
+import Data.Semigroup hiding (Option, option)
 #endif
 import Data.String (fromString, IsString)
 
@@ -118,6 +119,7 @@ import Options.Applicative.Common
 import Options.Applicative.Types
 import Options.Applicative.Help.Pretty
 import Options.Applicative.Help.Chunk
+import Options.Applicative.Internal (mapParserOptions)
 
 -- Readers --
 
@@ -379,6 +381,65 @@ option r m = mkParser d g rdr
     crdr = CReader (optCompleter fields) r
     rdr = OptReader (optNames fields) crdr (optNoArgError fields)
 
+-- | Prepends a group to 'OptProperties'. Nested groups are concatenated
+-- together e.g.
+--
+-- @
+--   optPropertiesGroup "Group Outer" (optPropertiesGroup "Group Inner" o)
+-- @
+--
+-- will render as "Group Outer.Group Inner".
+optPropertiesGroup :: String -> OptProperties -> OptProperties
+optPropertiesGroup g o = o { propGroup = OptGroup (g : gs) }
+  where
+    OptGroup gs = propGroup o
+
+-- | Prepends a group per 'optPropertiesGroup'.
+optionGroup :: String -> Option a -> Option a
+optionGroup grp o = o { optProps = props' }
+  where
+    props' = optPropertiesGroup grp (optProps o)
+
+-- | This function can be used to group options together under a common
+-- heading. For example, if we have:
+--
+-- > Args
+-- >   <$> parseMain
+-- >   <*> parserOptionGroup "Group A" parseA
+-- >   <*> parserOptionGroup "Group B" parseB
+-- >   <*> parseOther
+--
+-- Then the help page will look like:
+--
+-- > Available options:
+-- >   <main options>
+-- >
+-- > Group A:
+-- >   <A options>
+-- >
+-- > Group B:
+-- >   <B options>
+-- >
+-- > Available options:
+-- >   <other options>
+--
+-- Caveats:
+--
+--   - Parser groups are like command groups in that groups are listed in
+--     creation order, and (non-consecutive) duplicate groups are allowed.
+--
+--   - Nested groups are concatenated:
+--
+--       @
+--         parserOptionGroup "Group A" (parserOptionGroup "Group Z" parseA)
+--       @
+--
+--       Will group @parseA@ under @"GroupA.Group Z"@.
+--
+-- @since 0.19.0.0
+parserOptionGroup :: String -> Parser a -> Parser a
+parserOptionGroup g = mapParserOptions (optionGroup g)
+
 -- | Modifier for 'ParserInfo'.
 newtype InfoMod a = InfoMod
   { applyInfoMod :: ParserInfo a -> ParserInfo a }

src/Options/Applicative/Builder/Internal.hs

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

src/Options/Applicative/Help/Core.hs

@@ -21,10 +21,9 @@ module Options.Applicative.Help.Core (
 
 import Control.Applicative
 import Control.Monad (guard)
-import Data.Function (on)
-import Data.List (sort, intersperse, groupBy)
+import Data.List (sort, intercalate, intersperse)
 import Data.Foldable (any, foldl')
-import Data.Maybe (catMaybes, fromMaybe)
+import Data.Maybe (fromMaybe, catMaybes)
 #if !MIN_VERSION_base(4,8,0)
 import Data.Monoid (mempty)
 #endif
@@ -34,6 +33,7 @@ import Data.Semigroup (Semigroup (..))
 import Prelude hiding (any)
 
 import Options.Applicative.Common
+import Options.Applicative.Internal (groupFstAll)
 import Options.Applicative.Types
 import Options.Applicative.Help.Pretty
 import Options.Applicative.Help.Chunk
@@ -50,12 +50,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 -> (OptGroup, 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 +87,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 +119,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 +194,41 @@ 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 (OptGroup, (Doc, Doc))] -> [[(OptGroup, (Doc, Doc))]]
+    groupByTitle = groupFstAll . catMaybes
+
+    tabulateGroup :: [(OptGroup, (Doc, Doc))] -> (OptGroup, Chunk Doc)
+    tabulateGroup l@((title,_):_) = (title, tabulate (prefTabulateFill pprefs) (snd <$> l))
+    tabulateGroup [] = mempty
+
+    -- Note that we treat Global/Available options identically, when it comes
+    -- to titles.
+    formatTitle :: (OptGroup, Chunk Doc) -> Chunk Doc
+    formatTitle (OptGroup groups, opts) =
+      case groups of
+        [] -> (pretty defTitle .$.) <$> opts
+        gs@(_:_) -> (renderGroupStr gs .$.) <$> opts
+      where
+        defTitle =
+          if global
+            then "Global options:"
+            else "Available options:"
+
+        renderGroupStr = pretty . intercalate "."
+
+    doc :: ArgumentReachability -> Option a -> Maybe (OptGroup, (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)
@@ -238,11 +266,11 @@ footerHelp chunk = mempty { helpFooter = chunk }
 parserHelp :: ParserPrefs -> Parser a -> ParserHelp
 parserHelp pprefs p =
   bodyHelp . vsepChunks $
-    with_title "Available options:" (fullDesc pprefs p)
+    (fullDesc pprefs p)
       : (group_title <$> cs)
   where
     def = "Available commands:"
-    cs = groupBy ((==) `on` fst) $ cmdDesc pprefs p
+    cs = groupFstAll $ cmdDesc pprefs p
 
     group_title a@((n, _) : _) =
       with_title (fromMaybe def n) $
@@ -255,9 +283,7 @@ parserHelp pprefs p =
 
 parserGlobals :: ParserPrefs -> Parser a -> ParserHelp
 parserGlobals pprefs p =
-  globalsHelp $
-    (.$.) <$> stringChunk "Global options:"
-          <*> globalDesc pprefs p
+  globalsHelp $ globalDesc pprefs p