Handle parent groups without top-level options

It is possible that someone defines a "parent group" that only contains child group(s) i.e. it does not contain any top-level options. This is a problem, because the parent name will not be attached to any options, thus will not be printed. To fix this, we instead represent the Option Groups as a hierarchy list of group titles e.g. ["Parent 1", "Parent 2", "Child group"]. Then, when rendering, we keep track of which group titles have already been printed. If some group has parent titles that have not yet been printed, we prepend their titles to the normal output.
pcapriotti · Aug 12, 2024 · ff8525e · ff8525e
1 parent 441c7b4
commit ff8525e
Show file tree

Hide file tree

Showing 7 changed files with 153 additions and 78 deletions.
diff --git a/README.md b/README.md
@@ -766,29 +766,33 @@ Then the `--help` page `Available options` will look like:
 ```
 Available options:
   <main options>
+  <other options>
 
-Group A:
+Group A
   <A options>
 
-Group B:
+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.
+  order, and duplicate groups are consolidated.
 
-- Nested groups are concatenated:
+- Nested groups are indented:
 
     ```haskell
-    parserOptionGroup "Group A" (parserOptionGroup "Group Z" parseA)
+    parserOptionGroup "Group Outer" (parserOptionGroup "Group Inner" parseA)
     ```
 
-    Will group `parseA` under `GroupA.Group Z`.
+    Will render as:
+
+    ```
+    Group Outer
+    - Group Inner
+      ...
+    ```
 
 ### Command groups
 

diff --git a/src/Options/Applicative/Builder.hs b/src/Options/Applicative/Builder.hs
@@ -381,18 +381,23 @@ 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.
+-- | Prepends a group to 'OptProperties'. Nested groups are indented e.g.
 --
 -- @
 --   optPropertiesGroup "Group Outer" (optPropertiesGroup "Group Inner" o)
 -- @
 --
--- will render as "Group Outer.Group Inner".
+-- will render as:
+--
+-- @
+--  Group Outer
+--   - Group Inner
+--     ...
+-- @
 optPropertiesGroup :: String -> OptProperties -> OptProperties
-optPropertiesGroup g o = o { propGroup = updateGroupName g oldGroup }
+optPropertiesGroup g o = o { propGroup = OptGroup (g : oldGroup) }
   where
-    oldGroup = propGroup o
+    OptGroup oldGroup = propGroup o
 
 -- | Prepends a group per 'optPropertiesGroup'.
 optionGroup :: String -> Option a -> Option a
@@ -416,10 +421,10 @@ optionGroup grp o = o { optProps = props' }
 -- >   <main options>
 -- >   <other options>
 -- >
--- > Group A:
+-- > Group A
 -- >   <A options>
 -- >
--- > Group B:
+-- > Group B
 -- >   <B options>
 --
 -- @since 0.19.0.0

diff --git a/src/Options/Applicative/Builder/Internal.hs b/src/Options/Applicative/Builder/Internal.hs
@@ -151,7 +151,7 @@ baseProps = OptProperties
   , propShowDefault = Nothing
   , propDescMod = Nothing
   , propShowGlobal = True
-  , propGroup = OptGroup 0 Nothing
+  , propGroup = OptGroup []
   }
 
 mkCommand :: Mod CommandFields a -> (Maybe String, [(String, ParserInfo a)])

diff --git a/src/Options/Applicative/Help/Core.hs b/src/Options/Applicative/Help/Core.hs
@@ -24,24 +24,17 @@ import           Control.Monad (guard)
 
 import           Data.Foldable (any, foldl')
 import           Data.Function (on)
-import           Data.List (sort, intersperse)
+import qualified Data.List as List
 import           Data.List.NonEmpty (NonEmpty ((:|)))
 import qualified Data.List.NonEmpty as NE
 import           Data.Maybe (fromMaybe, catMaybes)
 
-
-
-
-
-
-
 import           Prelude hiding (any)
 
 import Options.Applicative.Common
 import Options.Applicative.Types
 import Options.Applicative.Help.Pretty
 import Options.Applicative.Help.Chunk
-import qualified Data.List as List
 
 -- | Style for rendering an option.
 data OptDescStyle
@@ -58,14 +51,14 @@ safelast = foldl' (const Just) Nothing
 optDesc :: ParserPrefs -> OptDescStyle -> ArgumentReachability -> Option a -> (OptGroup, Chunk Doc, Parenthetic)
 optDesc pprefs style _reachability opt =
   let names =
-        sort . optionNames . optMain $ opt
+        List.sort . optionNames . optMain $ opt
       meta =
         stringChunk $ optMetaVar opt
       grp = propGroup $ optProps opt
       descs =
         map (pretty . showOption) names
       descriptions =
-        listToChunk (intersperse (descSep style) descs)
+        listToChunk (List.intersperse (descSep style) descs)
       desc
         | prefHelpLongEquals pprefs && not (isEmpty meta) && any isLongName (safelast names) =
           descriptions <> stringChunk "=" <> meta
@@ -201,7 +194,8 @@ globalDesc = optionsDesc True
 optionsDesc :: Bool -> ParserPrefs -> Parser a -> Chunk Doc
 optionsDesc global pprefs p =
   vsepChunks
-    . fmap (formatTitle . tabulateGroup)
+    . formatTitle'
+    . fmap tabulateGroup
     . groupByTitle
     $ docs
   where
@@ -256,26 +250,54 @@ optionsDesc global pprefs p =
           let groupLvl = optGroupToLevel g
           in lvlIndent * (maxGroupLevel - groupLvl)
 
-    tabulateGroup [] = (OptGroup 0 Nothing, mempty)
-
-    formatTitle :: (OptGroup, Chunk Doc) -> Chunk Doc
-    formatTitle (OptGroup idx mTitle, opts) =
-      -- Two cases to handle w.r.t group level (i.e. nested groups).
-      case idx of
-        -- Group not nested: no indention.
-        0 -> (\d -> pretty title .$. d) <$> opts
-        -- Handle NOTE: [Nested group alignment] 1 and 2 here.
-        n ->
-          let -- indent entire group based on its level.
-              indentGroup = indent (lvlIndent * (n - 1))
+    tabulateGroup [] = (OptGroup [], mempty)
+
+    -- Fold so we can update the (printedGroups :: [String]) arg as we
+    -- iterate. End with a reverse since we use foldl'.
+    formatTitle' :: [(OptGroup, Chunk Doc)] -> [Chunk Doc]
+    formatTitle' = reverse . snd . foldl' formatTitle ([], [])
+
+    formatTitle :: ([String], [Chunk Doc]) -> (OptGroup, Chunk Doc) -> ([String], [Chunk Doc])
+    formatTitle (printedGroups, acc) o@(OptGroup groups, opts) =
+      case parentGroups of
+        -- No nested groups: No special logic.
+        [] -> (groupTitle : printedGroups, ((\d -> pretty groupTitle .$. d) <$> opts) : acc)
+        -- We have at least one parent group title P for current group G: P has
+        -- already been printed iff it is attached to another (non-grouped)
+        -- option. In other words, P has __not__ been printed if its only
+        -- member is another group.
+        --
+        -- The parameter (printedGroups :: [String]) holds all groups that
+        -- have already been printed.
+        parents@(_ : _) ->
+          let groupLvl = optGroupToLevel o
               -- indent opts an extra lvlIndent to account for hyphen
               indentOpts = indent lvlIndent
-          in (\d -> indentGroup $ pretty ("- " <> title) .$. indentOpts d)
-               <$> opts
+
+              -- new printedGroups is all previous + this and parents.
+              printedGroups' = groupTitle : parents ++ printedGroups
+
+              parentsWithIndent = zip [0 .. ] parents
+
+              -- docs for unprinted parent title groups
+              parentDocs = pure $ mkParentDocs printedGroups parentsWithIndent
+
+              -- docs for the current group
+              thisDocs =
+                (\d -> lvlIndentNSub1 groupLvl $ (hyphenate groupTitle) .$. indentOpts d)
+                  <$> opts
+
+              allDocs = parentDocs <> thisDocs
+
+          in (printedGroups', allDocs : acc)
       where
-        title =
-          fromMaybe defaultTitle mTitle
-        defaultTitle =
+        -- Separate parentGroups and _this_ group, in case we need to also
+        -- print parent groups.
+        (parentGroups, groupTitle) = case unsnoc groups of
+          Nothing -> ([], defTitle)
+          Just (parentGrps, grp) -> (parentGrps, grp)
+
+        defTitle =
           if global
             then "Global options:"
             else "Available options:"
@@ -288,7 +310,10 @@ optionsDesc global pprefs p =
     findMaxGroupLevel = foldl' (\acc -> max acc . optGroupToLevel) 0 . catMaybes
 
     optGroupToLevel :: (OptGroup, a) -> Int
-    optGroupToLevel (OptGroup i _, _) = i
+    -- 0 (defTitle) and 1 (custom group name) are handled identically
+    -- w.r.t indenation (not indented). Hence the subtraction here.
+    optGroupToLevel (OptGroup [], _) = 0
+    optGroupToLevel (OptGroup xs@(_ : _), _) = length xs - 1
 
     doc :: ArgumentReachability -> Option a -> Maybe (OptGroup, (Doc, Doc))
     doc info opt = do
@@ -306,6 +331,27 @@ optionsDesc global pprefs p =
         descGlobal = global
       }
 
+    -- Prints all parent titles that have not already been printed
+    -- (i.e. in printedGroups).
+    mkParentDocs :: [String] -> [(Int, String)] -> Doc
+    mkParentDocs printedGroups = foldl' g (pretty "") . reverse
+      where
+        g :: Doc -> (Int, String) -> Doc
+        g acc (i, s) =
+          if s `List.elem` printedGroups
+            then acc
+            else
+              if i == 0
+                -- Top-level parent has no special formatting
+                then pretty s .$. acc
+                -- Nested parent is hyphenated and possibly indented.
+                else lvlIndentNSub1 i $ hyphenate s .$. acc
+
+    hyphenate s = pretty ("- " <> s)
+
+    lvlIndentNSub1 :: Int -> Doc -> Doc
+    lvlIndentNSub1 n = indent (lvlIndent * (n - 1))
+
     lvlIndent :: Int
     lvlIndent = 2
 
@@ -384,7 +430,6 @@ data Parenthetic
   -- ^ Parenthesis should always be used.
   deriving (Eq, Ord, Show)
 
-
 -- | 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:
@@ -432,3 +477,13 @@ groupFstAll =
 
     zipWithIndex :: [(a, b)] -> [(Int, (a, b))]
     zipWithIndex = zip [1 ..]
+
+unsnoc :: [a] -> Maybe ([a], a)
+unsnoc [] = Nothing
+unsnoc [x] = Just ([], x)
+unsnoc (x:xs) = Just (x:a, b)
+  where
+    (a, b) = case unsnoc xs of
+      Just y -> y
+      Nothing ->
+        error "Options.Applicative.Help.Core.unsnoc: impossible"
diff --git a/src/Options/Applicative/Types.hs b/src/Options/Applicative/Types.hs
@@ -12,7 +12,6 @@ module Options.Applicative.Types (
   OptReader(..),
   OptProperties(..),
   OptGroup(..),
-  updateGroupName,
   OptVisibility(..),
   Backtracking(..),
   ReadM(..),
@@ -152,17 +151,9 @@ data OptVisibility
 -- | Groups for optionals. Can be multiple in the case of nested groups.
 --
 -- @since 0.19.0.0
-data OptGroup = OptGroup !Int (Maybe String)
+newtype OptGroup = OptGroup [String]
   deriving (Eq, Ord, Show)
 
--- | If the group name is not already set, sets the group name to the
--- parameter and leaves the index as-is. If, on the other hand, the group
--- name already exists, we ignore the parameter and increment the index
--- by one.
-updateGroupName :: String -> OptGroup -> OptGroup
-updateGroupName newName (OptGroup i Nothing) = OptGroup i (Just newName)
-updateGroupName _ (OptGroup i (Just oldName)) = OptGroup (i + 1) (Just oldName)
-
 -- | Specification for an individual parser option.
 data OptProperties = OptProperties
   { propVisibility :: OptVisibility       -- ^ whether this flag is shown in the brief description
@@ -172,7 +163,7 @@ data OptProperties = OptProperties
   , propShowGlobal :: Bool                -- ^ whether the option is presented in global options text
   , propDescMod :: Maybe ( Doc -> Doc )   -- ^ a function to run over the brief description
   , propGroup :: OptGroup
-    -- ^ optional (nested) group
+    -- ^ optional group(s)
     --
     -- @since 0.19.0.0
   }

diff --git a/tests/Examples/ParserGroup/Nested.hs b/tests/Examples/ParserGroup/Nested.hs
@@ -37,6 +37,7 @@ data Sample = Sample
     logGroup :: LogGroup,
     quiet :: Bool,
     verbosity :: Int,
+    group2 :: (Int, Int),
     cmd :: String
   }
   deriving (Show)
@@ -48,6 +49,7 @@ sample =
     <*> parseLogGroup
     <*> parseQuiet
     <*> parseVerbosity
+    <*> parseGroup2
     <*> parseCmd
 
   where
@@ -58,11 +60,14 @@ sample =
             <> help "Target for the greeting"
         )
 
-    parseLogGroup = parserOptionGroup "Logging" $
-      LogGroup
-        <$> parseLogPath
-        <*> parseSystemGroup
-        <*> parseLogVerbosity
+    parseLogGroup =
+      parserOptionGroup "First group" $
+      parserOptionGroup "Second group" $
+      parserOptionGroup "Logging" $
+        LogGroup
+          <$> parseLogPath
+          <*> parseSystemGroup
+          <*> parseLogVerbosity
 
       where
         parseLogPath =
@@ -107,6 +112,12 @@ sample =
       parserOptionGroup "Nested3" $
         Nested3 <$> option auto (long "triple-nested" <> metavar "STR" <> help "Another option")
 
+    parseGroup2 :: Parser (Int, Int)
+    parseGroup2 = parserOptionGroup "Group 2" $
+      (,)
+        <$> parserOptionGroup "G 2.1" (option auto (long "one" <> help "Option 1"))
+        <*> parserOptionGroup "G 2.2" (option auto (long "two" <> help "Option 2"))
+
     parseVerbosity =
       option auto (long "verbosity" <> short 'v' <> help "Console verbosity")