Indent nested groups when rendering

Author: tbidne

src/Options/Applicative/Builder.hs

@@ -390,9 +390,9 @@ option r m = mkParser d g rdr
 --
 -- will render as "Group Outer.Group Inner".
 optPropertiesGroup :: String -> OptProperties -> OptProperties
-optPropertiesGroup g o = o { propGroup = OptGroup (g : gs) }
+optPropertiesGroup g o = o { propGroup = updateGroupName g oldGroup }
   where
-    OptGroup gs = propGroup o
+    oldGroup = propGroup o
 
 -- | Prepends a group per 'optPropertiesGroup'.
 optionGroup :: String -> Option a -> Option a

src/Options/Applicative/Builder/Internal.hs

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

src/Options/Applicative/Help/Core.hs

@@ -198,29 +198,93 @@ optionsDesc global pprefs p = vsepChunks
   . fmap formatTitle
   . fmap tabulateGroup
   . groupByTitle
-  $ mapParser doc p
+  $ docs
   where
+    docs :: [Maybe (OptGroup, (Doc, Doc))]
+    docs = mapParser doc p
+
     groupByTitle :: [Maybe (OptGroup, (Doc, Doc))] -> [[(OptGroup, (Doc, Doc))]]
-    groupByTitle = groupFstAll . catMaybes
+    groupByTitle xs = groupFstAll . catMaybes $ xs
+
+    -- NOTE: [Nested group alignment]
+    --
+    -- For nested groups, we want to produce output like:
+    --
+    -- Group 1
+    --   --opt-1 INT          Option 1
+    --
+    -- - Group 2
+    --     --opt-2 INT        Option 2
+    --
+    --   - Group 3
+    --       - opt-3 INT      Option 3
+    --
+    -- That is, we have the following constraints:
+    --
+    --   1. Nested groups are prefixed with a hyphen '- ', where the hyphen
+    --     starts on the same column as the parent group.
+    --
+    --   2. We still want the listed options to be indented twice under the
+    --     group name, so this means nested options need to be indented
+    --     again by the standard amount (2), due to the hyphen.
+    --
+    --   3. Help text should be __globally__ aligned.
 
     tabulateGroup :: [(OptGroup, (Doc, Doc))] -> (OptGroup, Chunk Doc)
-    tabulateGroup l@((title,_):_) = (title, tabulate (prefTabulateFill pprefs) (snd <$> l))
-    tabulateGroup [] = mempty
+    tabulateGroup l@((title,_):_) =
+      (title, tabulate (prefTabulateFill pprefs) (getGroup <$> l))
+      where
+        -- Handle NOTE: [Nested group alignment] 3. here i.e. indent the
+        -- right Doc (help text) according to its indention level and
+        -- global maxGroupLevel. Notice there is an inverse relationship here,
+        -- as the further the entire group is indented, the less we need to
+        -- indent the help text.
+        getGroup :: (OptGroup, (Doc, Doc)) -> (Doc, Doc)
+        getGroup o@(_, (x, y)) =
+          let helpIndent = calcOptHelpIndent o
+          in (x, indent helpIndent y)
+
+        -- Indents the option help text, taking the option's group level and
+        -- maximum group level into account.
+        calcOptHelpIndent :: (OptGroup, a) -> Int
+        calcOptHelpIndent g =
+          let groupLvl = optGroupToLevel g
+          in lvlIndent * (maxGroupLevel - groupLvl)
+
+    tabulateGroup [] = (OptGroup 0 Nothing, 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
+    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))
+              -- indent opts an extra lvlIndent to account for hyphen
+              indentOpts = indent lvlIndent
+          in (\d -> indentGroup $ (pretty $ "- " <> title) .$. indentOpts d)
+               <$> opts
       where
+        title = case mTitle of
+          Nothing -> defTitle
+          Just t -> t
         defTitle =
           if global
             then "Global options:"
             else "Available options:"
 
-        renderGroupStr = pretty . intercalate "."
+    maxGroupLevel :: Int
+    maxGroupLevel = findMaxGroupLevel docs
+
+    -- Finds the maxium OptGroup level.
+    findMaxGroupLevel :: [Maybe (OptGroup, (Doc, Doc))] -> Int
+    findMaxGroupLevel = foldl' (\acc -> max acc . optGroupToLevel) 0 . catMaybes
+
+    optGroupToLevel :: (OptGroup, a) -> Int
+    optGroupToLevel ((OptGroup i _), _) = i
 
     doc :: ArgumentReachability -> Option a -> Maybe (OptGroup, (Doc, Doc))
     doc info opt = do
@@ -238,6 +302,9 @@ optionsDesc global pprefs p = vsepChunks
         descGlobal = global
       }
 
+    lvlIndent :: Int
+    lvlIndent = 2
+
 errorHelp :: Chunk Doc -> ParserHelp
 errorHelp chunk = mempty { helpError = chunk }
 

src/Options/Applicative/Types.hs

@@ -12,6 +12,7 @@ module Options.Applicative.Types (
   OptReader(..),
   OptProperties(..),
   OptGroup(..),
+  updateGroupName,
   OptVisibility(..),
   Backtracking(..),
   ReadM(..),
@@ -151,15 +152,16 @@ data OptVisibility
 -- | Groups for optionals. Can be multiple in the case of nested groups.
 --
 -- @since 0.19.0.0
-newtype OptGroup = OptGroup [String]
+data OptGroup = OptGroup !Int (Maybe String)
   deriving (Eq, Ord, Show)
 
-instance Semigroup OptGroup where
-  OptGroup xs <> OptGroup ys = OptGroup (xs ++ ys)
-
-instance Monoid OptGroup where
-  mempty = OptGroup []
-  mappend = (<>)
+-- | 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

tests/Examples/ParserGroup/Nested.hs

@@ -17,10 +17,22 @@ data LogGroup = LogGroup
 
 data SystemGroup = SystemGroup
   { poll :: Bool,
+    deepNested :: Nested2,
     timeout :: Int
   }
   deriving (Show)
 
+data Nested2 = Nested2
+  { nested2Str :: String,
+    nested3 :: Nested3
+  }
+  deriving (Show)
+
+newtype Nested3 = Nested3
+  { nested3Str :: String
+  }
+  deriving (Show)
+
 data Sample = Sample
   { hello :: String,
     logGroup :: LogGroup,
@@ -97,6 +109,7 @@ sample = do
             ( long "poll"
                 <> help "Whether to poll"
             )
+          <*> parseNested2
           <*> ( option
                   auto
                   ( long "timeout"
@@ -105,6 +118,27 @@ sample = do
                   )
               )
 
+    parseNested2 = parserOptionGroup "Nested2" $ do
+      nestedStr2 <-
+        ( option
+            auto
+            ( long "double-nested"
+                <> metavar "STR"
+                <> help "Some nested option"
+            )
+        )
+      nested3 <- parseNested3
+      pure $ Nested2 nestedStr2 nested3
+
+    parseNested3 = parserOptionGroup "Nested3" $
+      ( option
+          (Nested3 <$> auto)
+          ( long "triple-nested"
+              <> metavar "STR"
+              <> help "Another option"
+          )
+      )
+
     parseVerbosity =
       option
         auto

tests/parser_group_nested.err.txt

@@ -1,21 +1,28 @@
 parser_group.nested - a test for optparse-applicative
 
 Usage: parser_group_nested --hello TARGET [--file-log-path PATH] [--poll]
-                           --timeout INT [--file-log-verbosity INT] [-q|--quiet]
+                           --double-nested STR --triple-nested STR --timeout INT
+                           [--file-log-verbosity INT] [-q|--quiet]
                            (-v|--verbosity ARG) Command
 
   Nested parser groups
 
 Available options:
-  --hello TARGET           Target for the greeting
-  -q,--quiet               Whether to be quiet
-  -v,--verbosity ARG       Console verbosity
-  -h,--help                Show this help text
+  --hello TARGET                 Target for the greeting
+  -q,--quiet                     Whether to be quiet
+  -v,--verbosity ARG             Console verbosity
+  -h,--help                      Show this help text
 
 Logging
-  --file-log-path PATH     Log file path
-  --file-log-verbosity INT File log verbosity
+  --file-log-path PATH           Log file path
+  --file-log-verbosity INT       File log verbosity
 
-Logging.System Options
-  --poll                   Whether to poll
-  --timeout INT            Whether to time out
+- System Options
+    --poll                       Whether to poll
+    --timeout INT                Whether to time out
+
+  - Nested2
+      --double-nested STR        Some nested option
+
+    - Nested3
+        --triple-nested STR      Another option