Add option to use option groups in brief help description

CHANGELOG.md

@@ -8,6 +8,8 @@
 
 - Add `commandWithAliases` for defining multiple aliases for the same command.
 
+- Add `briefDescOpt` for styling the brief help options.
+
 ## Version 0.19.0.0 (03 June 2025)
 
 - Add `briefHangPoint` modifier. This allows one to specify the command length

optparse-applicative.cabal

@@ -44,6 +44,8 @@ extra-source-files:  CHANGELOG.md
                      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_desc_opt_groups.err.txt
+                     tests/parser_group_nested_desc_opt_groups_style.err.txt
                      tests/parser_group_nested.err.txt
                      tests/prop_cmd_alias_dupes.err.txt
                      tests/prop_cmd_aliases.err.txt
@@ -151,6 +153,8 @@ test-suite tests
                      , Examples.ParserGroup.DuplicateCommandGroups
                      , Examples.ParserGroup.Duplicates
                      , Examples.ParserGroup.Nested
+                     , Examples.ParserGroup.NestedDescOptGroups
+                     , Examples.ParserGroup.NestedDescOptGroupsStyle
 
   build-depends:       base
                      , optparse-applicative

src/Options/Applicative.hs

@@ -202,8 +202,12 @@ module Options.Applicative (
   helpShowGlobals,
   helpIndent,
   briefHangPoint,
+  briefDescOpt,
   defaultPrefs,
 
+  -- ** Brief Description
+  BriefDescOpt (..),
+
   -- * Completions
   --
   -- | optparse-applicative supplies a rich completion system for bash,

src/Options/Applicative/Builder.hs

@@ -90,6 +90,7 @@ module Options.Applicative.Builder (
   helpShowGlobals,
   helpIndent,
   briefHangPoint,
+  briefDescOpt,
   prefs,
   defaultPrefs,
 
@@ -602,6 +603,11 @@ helpIndent w = PrefsMod $ \p -> p { prefTabulateFill = w }
 briefHangPoint :: Int -> PrefsMod
 briefHangPoint php = PrefsMod $ \p -> p { prefBriefHangPoint = php }
 
+-- | Set the brief option description style.
+--
+-- @since 0.20.0.0
+briefDescOpt :: BriefDescOpt -> PrefsMod
+briefDescOpt d = PrefsMod $ \p -> p { prefBriefDescOpt = d }
 
 -- | Create a `ParserPrefs` given a modifier
 prefs :: PrefsMod -> ParserPrefs
@@ -617,7 +623,8 @@ prefs m = applyPrefsMod m base
       , prefHelpLongEquals = False
       , prefHelpShowGlobal = False
       , prefTabulateFill = 24
-      , prefBriefHangPoint = 35 }
+      , prefBriefHangPoint = 35
+      , prefBriefDescOpt = BriefDescOptList }
 
 -- Convenience shortcuts
 

src/Options/Applicative/Help/Core.hs

@@ -19,7 +19,7 @@ module Options.Applicative.Help.Core (
   ) where
 
 import           Control.Applicative
-import           Control.Monad (guard)
+import           Control.Monad (guard, join)
 
 import           Data.Foldable (any, foldl')
 import           Data.Function (on)
@@ -34,6 +34,7 @@ import Options.Applicative.Common
 import Options.Applicative.Types
 import Options.Applicative.Help.Pretty
 import Options.Applicative.Help.Chunk
+import qualified Options.Applicative.Internal as Internal
 
 -- | Style for rendering an option.
 data OptDescStyle
@@ -53,7 +54,7 @@ optDesc pprefs style _reachability opt =
         List.sort . optionNames . optMain $ opt
       meta =
         stringChunk $ optMetaVar opt
-      grp = propGroup $ optProps opt
+      grp = optToGroup opt
       descs =
         map (pretty . showOption) names
       descriptions =
@@ -117,12 +118,24 @@ missingDesc = briefDesc' False
 -- | Generate a brief help text for a parser, allowing the specification
 --   of if optional arguments are show.
 briefDesc' :: Bool -> ParserPrefs -> Parser a -> Chunk Doc
-briefDesc' showOptional pprefs =
+briefDesc' showOptional pprefs p =
   wrapOver NoDefault MaybeRequired
     . foldTree pprefs style
     . mFilterOptional
+    . addGroupsFn
     . treeMapParser optDesc'
+    $ p'
   where
+    -- (Filtered parser, add groups function)
+    (p', addGroupsFn) = case prefBriefDescOpt pprefs of
+      -- Normal: do not filter parser, and do not add groups.
+      BriefDescOptList -> (p, id)
+      -- For both group options, filter the tree such that all options/flags
+      -- are removed. Then return a function that adds the group names to
+      -- the OptTree, to be rendered in front of the rest of the tree.
+      BriefDescOptGroups optPrefs ->
+        (Internal.filterParserOptions isNotOpt p, addGroups optPrefs p)
+
     mFilterOptional
       | showOptional =
         id
@@ -140,6 +153,47 @@ briefDesc' showOptional pprefs =
       in
         (a, b)
 
+    -- Adds groups in front of the rest of the tree as single leaves.
+    addGroups ::
+      -- Optional style function.
+      Maybe (String -> Maybe Doc) ->
+      Parser a ->
+      OptTree (Chunk Doc, Parenthetic) ->
+      OptTree (Chunk Doc, Parenthetic)
+    addGroups optStyle pGroups tr = case tr of
+      n@(Leaf _) -> MultNode (nodes ++ [n])
+      MultNode xs -> MultNode (nodes ++ xs)
+      n@(AltNode {}) -> MultNode (nodes ++ [n])
+      n@(BindNode {}) -> MultNode (nodes ++ [n])
+      where
+        groups = allOptionGroups pGroups
+        nodes = fmap (groupNameToNode optStyle) groups
+
+    -- Turns a single group name into an OptTree doc, styling as requested.
+    groupNameToNode :: Maybe (String -> Maybe Doc) -> String -> OptTree (Chunk Doc, Parenthetic)
+    groupNameToNode styleGroups =
+      Leaf
+        -- The Parenthetic value here actually isn't used, since these
+        -- are leaves. Potential bracketing and other styling is handled by
+        -- the param function.
+        . (\x -> (x,NeverRequired))
+        . Chunk
+        . fromMaybe defStyleGroups styleGroups
+
+    isNotOpt opt = case optMain opt of
+      OptReader {} -> False
+      FlagReader {} -> False
+      _ -> True
+
+    defStyleGroups :: String -> Maybe Doc
+    defStyleGroups = Just . brackets . pretty . dropColon
+      where
+        -- Default style adds brackets and drops a trailing colon if it exists
+        -- e.g. "Available options:" -> "[Available options]".
+        dropColon [] = []
+        dropColon [':'] = []
+        dropColon (x : xs) = x : dropColon xs
+
 -- | Wrap a doc in parentheses or brackets if required.
 wrapOver :: AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc
 wrapOver altnode mustWrapBeyond (chunk, wrapping)
@@ -205,15 +259,15 @@ optionsDesc :: Bool -> ParserPrefs -> Parser a -> Chunk Doc
 optionsDesc global pprefs p =
   vsepChunks
     . formatTitle'
-    . fmap tabulateGroup
+    . fmap (tabulateGroup . NE.toList)
     . groupByTitle
     $ docs
   where
     docs :: [Maybe (OptGroup, (Doc, Doc))]
     docs = mapParser doc p
 
-    groupByTitle :: [Maybe (OptGroup, (Doc, Doc))] -> [[(OptGroup, (Doc, Doc))]]
-    groupByTitle xs = groupFstAll . catMaybes $ xs
+    groupByTitle :: [Maybe (OptGroup, (Doc, Doc))] -> [NonEmpty (OptGroup, (Doc, Doc))]
+    groupByTitle = groupFstAll . catMaybes
 
     -- NOTE: [Nested group alignment]
     --
@@ -307,10 +361,7 @@ optionsDesc global pprefs p =
           Nothing -> ([], defTitle)
           Just (parentGrps, grp) -> (parentGrps, grp)
 
-        defTitle =
-          if global
-            then "Global options:"
-            else "Available options:"
+        defTitle = mkDefTitle global
 
     maxGroupLevel :: Int
     maxGroupLevel = findMaxGroupLevel docs
@@ -362,6 +413,12 @@ optionsDesc global pprefs p =
     lvlIndent :: Int
     lvlIndent = 2
 
+mkDefTitle :: Bool -> String
+mkDefTitle global =
+  if global
+    then "Global options:"
+    else "Available options:"
+
 errorHelp :: Chunk Doc -> ParserHelp
 errorHelp chunk = mempty { helpError = chunk }
 
@@ -394,7 +451,7 @@ parserHelp pprefs p =
       : (group_title <$> cs)
   where
     def = "Available commands:"
-    cs = groupFstAll $ cmdDesc pprefs p
+    cs = fmap NE.toList $ groupFstAll $ cmdDesc pprefs p
 
     group_title a@((n, _) : _) =
       with_title (fromMaybe def n) $
@@ -437,6 +494,39 @@ data Parenthetic
   -- ^ Parenthesis should always be used.
   deriving (Eq, Ord, Show)
 
+optToGroup :: Option a -> OptGroup
+optToGroup = propGroup . optProps
+
+-- | Returns all groups associated to this option. Returns
+-- [default_group_name] if there are none. Hence this is morally
+-- NonEmpty, though we return List since our immediate usage requires a
+-- List.
+optGroupToNames :: OptGroup -> [String]
+optGroupToNames (OptGroup xs) = case xs of
+  [] -> [mkDefTitle False]
+  ys -> ys
+
+-- Given a parser, returns a list of all option groups. This includes groups
+-- that do not have any bare options themselves i.e. they only contain
+-- other groups.
+--
+-- If we wanted to return only those groups that directly contained /some/
+-- options, we'd instead do 'getOptionGroups optGroupToName id', where
+--
+--   optGroupToName :: OptGroup -> String
+--   optGroupToName = -- returns the last group name or default.
+allOptionGroups :: Parser a -> [String]
+allOptionGroups = getOptionGroups optGroupToNames join
+
+getOptionGroups :: (OptGroup -> b) -> ([b] -> [String]) -> Parser a -> [String]
+getOptionGroups toGroup toStrs =
+  fmap NE.head
+    . groupAllOn id
+    . toStrs
+    . mapParser go
+  where
+    go = const (toGroup . optToGroup)
+
 -- | Groups on the first element of the tuple. This differs from the simple
 -- @groupBy ((==) `on` fst)@ in that non-adjacent groups are __also__ grouped
 -- together. For example:
@@ -454,35 +544,34 @@ data Parenthetic
 -- the first element.
 --
 -- @since 0.19.0.0
-groupFstAll :: Ord a => [(a, b)] -> [[(a, b)]]
-groupFstAll =
+groupFstAll :: Ord a => [(a, b)] -> [NonEmpty (a, b)]
+groupFstAll = groupAllOn fst
+
+groupAllOn :: Ord b => (a -> b) -> [a] -> [NonEmpty a]
+groupAllOn f =
   -- In order to group all (adjacent + non-adjacent) Eq elements together, we
   -- sort the list so that the Eq elements are in fact adjacent, _then_ group.
   -- We don't want to destroy the original order, however, so we add a
   -- temporary index that maintains this original order. The full logic is:
   --
   -- 1. Add index i that preserves original order.
-  -- 2. Sort on tuple's fst.
-  -- 3. Group by fst.
+  -- 2. Sort on function.
+  -- 3. Group on function.
   -- 4. Sort by i, restoring original order.
   -- 5. Drop index i.
-  fmap (NE.toList . dropIdx)
+  fmap dropIdx
     . List.sortOn toIdx
-    . NE.groupBy ((==) `on` fst')
-    . List.sortOn fst'
+    . NE.groupBy ((==) `on` f . snd)
+    . List.sortOn (f . snd)
     . zipWithIndex
   where
-    dropIdx :: NonEmpty (Int, (a, b)) -> NonEmpty (a, b)
+    dropIdx :: NonEmpty (Int, a) -> NonEmpty a
     dropIdx = fmap snd
 
-    toIdx :: NonEmpty (Int, (a, b)) -> Int
+    toIdx :: NonEmpty (Int, a) -> Int
     toIdx ((x, _) :| _) = x
 
-    -- Like fst, ignores our added index
-    fst' :: (Int, (a, b)) -> a
-    fst' (_, (x, _)) = x
-
-    zipWithIndex :: [(a, b)] -> [(Int, (a, b))]
+    zipWithIndex :: [a] -> [(Int, a)]
     zipWithIndex = zip [1 ..]
 
 -- | From base-4.19.0.0.

src/Options/Applicative/Internal.hs

@@ -28,6 +28,7 @@ module Options.Applicative.Internal
   , disamb
 
   , mapParserOptions
+  , filterParserOptions
   ) where
 
 import Control.Applicative
@@ -293,3 +294,19 @@ mapParserOptions f = go
     go (MultP p1 p2) = MultP (go p1) (go p2)
     go (AltP p1 p2) = AltP (go p1) (go p2)
     go (BindP p1 p2) = BindP (go p1) (\x -> go (p2 x))
+
+-- | Filters the parser based on its options.
+--
+-- @since 0.20.0.0
+filterParserOptions :: (forall x. Option x -> Bool) -> Parser a -> Parser a
+filterParserOptions f = go
+  where
+    go :: forall y. Parser y -> Parser y
+    go (NilP x) = NilP x
+    go opt@(OptP o) =
+      if f o
+        then opt
+        else NilP Nothing
+    go (MultP p1 p2) = MultP (go p1) (go p2)
+    go (AltP p1 p2) = AltP (go p1) (go p2)
+    go (BindP p1 p2) = BindP (go p1) (\x -> go (p2 x))

src/Options/Applicative/Types.hs

@@ -3,6 +3,7 @@ module Options.Applicative.Types (
   ParseError(..),
   ParserInfo(..),
   ParserPrefs(..),
+  BriefDescOpt (..),
 
   Option(..),
   OptName(..),
@@ -148,8 +149,37 @@ data ParserPrefs = ParserPrefs
                                   -- section (default: False)
   , prefTabulateFill ::Int        -- ^ Indentation width for tables
   , prefBriefHangPoint :: Int     -- ^ Width at which to hang the brief description
+  , prefBriefDescOpt :: BriefDescOpt -- ^ Styles the brief option description
   } deriving (Eq, Show)
 
+-- | How to style options in the brief description.
+--
+-- @since 0.20.0.0
+data BriefDescOpt
+  -- | Lists all option groups. The parameter function is used to style
+  -- the group names. Groups can be omitted by returning 'Nothing'.
+  --
+  -- If no function is provided, a default style is applied, which adds
+  -- brackets and drops a trailing colon.
+  --
+  -- @since 0.20.0.0
+  = BriefDescOptGroups (Maybe (String -> Maybe Doc))
+  -- | Lists all options individually. This is the default.
+  --
+  -- @since 0.20.0.0
+  | BriefDescOptList
+
+instance Show BriefDescOpt where
+  show (BriefDescOptGroups Nothing) = "BriefDescOptGroups Nothing"
+  show (BriefDescOptGroups (Just _)) = "BriefDescOptGroups (Just _)"
+  show BriefDescOptList = "BriefDescOptList"
+
+instance Eq BriefDescOpt where
+  BriefDescOptGroups Nothing == BriefDescOptGroups Nothing = True
+  BriefDescOptGroups (Just _) == BriefDescOptGroups (Just _) = True
+  BriefDescOptList == BriefDescOptList = True
+  _ == _ = False
+
 data OptName = OptShort !Char
              | OptLong !String
   deriving (Eq, Ord, Show)