Add addHelpCommandWith; Improve layouting for help/docs

src/UI/Butcher/Monadic.hs

@@ -29,6 +29,7 @@ module UI.Butcher.Monadic
     -- * Builtin commands
   , addHelpCommand
   , addHelpCommand2
+  , addHelpCommandWith
   , addButcherDebugCommand
   , addShellCompletionCommand
   , addShellCompletionCommand'

src/UI/Butcher/Monadic/BuiltinCommands.hs

@@ -2,6 +2,7 @@
 module UI.Butcher.Monadic.BuiltinCommands
   ( addHelpCommand
   , addHelpCommand2
+  , addHelpCommandWith
   , addHelpCommandShallow
   , addButcherDebugCommand
   , addShellCompletionCommand
@@ -33,22 +34,12 @@ import           System.IO
 -- | Adds a proper full help command. To obtain the 'CommandDesc' value, see
 -- 'UI.Butcher.Monadic.cmdRunParserWithHelpDesc' or
 -- 'UI.Butcher.Monadic.IO.mainFromCmdParserWithHelpDesc'.
+--
+-- > addHelpCommand = addHelpCommandWith
+-- >   (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpShallow)
 addHelpCommand :: Applicative f => CommandDesc a -> CmdParser f (IO ()) ()
-addHelpCommand desc = addCmd "help" $ do
-  addCmdSynopsis "print help about this command"
-  rest <- addParamRestOfInput "SUBCOMMAND(s)" mempty
-  addCmdImpl $ do
-    let restWords = List.words rest
-    let
-      descent :: [String] -> CommandDesc a -> CommandDesc a
-      descent [] curDesc = curDesc
-      descent (w:wr) curDesc =
-        case
-            List.lookup (Just w) $ Data.Foldable.toList $ _cmd_children curDesc
-          of
-            Nothing    -> curDesc
-            Just child -> descent wr child
-    print $ ppHelpShallow $ descent restWords desc
+addHelpCommand = addHelpCommandWith
+  (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpShallow)
 
 -- | Adds a proper full help command. In contrast to 'addHelpCommand',
 -- this version is a bit more verbose about available subcommands as it
@@ -57,8 +48,21 @@ addHelpCommand desc = addCmd "help" $ do
 -- To obtain the 'CommandDesc' value, see
 -- 'UI.Butcher.Monadic.cmdRunParserWithHelpDesc' or
 -- 'UI.Butcher.Monadic.IO.mainFromCmdParserWithHelpDesc'.
+--
+-- > addHelpCommand2 = addHelpCommandWith
+-- >   (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpDepthOne)
 addHelpCommand2 :: Applicative f => CommandDesc a -> CmdParser f (IO ()) ()
-addHelpCommand2 desc = addCmd "help" $ do
+addHelpCommand2 = addHelpCommandWith
+  (pure . PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } . ppHelpDepthOne)
+
+-- | Adds a proper full help command, using the specified function to turn
+-- the relevant subcommand's 'CommandDesc' into a String.
+addHelpCommandWith
+  :: Applicative f
+  => (CommandDesc a -> IO String)
+  -> CommandDesc a
+  -> CmdParser f (IO ()) ()
+addHelpCommandWith f desc = addCmd "help" $ do
   addCmdSynopsis "print help about this command"
   rest <- addParamRestOfInput "SUBCOMMAND(s)" mempty
   addCmdImpl $ do
@@ -72,7 +76,8 @@ addHelpCommand2 desc = addCmd "help" $ do
           of
             Nothing    -> curDesc
             Just child -> descent wr child
-    print $ ppHelpDepthOne $ descent restWords desc
+    s <- f $ descent restWords desc
+    putStrLn s
 
 -- | Adds a help command that prints help for the command currently in context.
 --

src/UI/Butcher/Monadic/Flag.hs

@@ -95,7 +95,8 @@ flagHelp h = mempty { _flag_help = Just h }
 
 -- | Create a 'Flag' with just a help text.
 flagHelpStr :: String -> Flag p
-flagHelpStr s = mempty { _flag_help = Just $ PP.text s }
+flagHelpStr s =
+  mempty { _flag_help = Just $ PP.fsep $ fmap PP.text $ List.words s }
 
 -- | Create a 'Flag' with just a default value.
 flagDefault :: p -> Flag p

src/UI/Butcher/Monadic/Internal/Core.hs

@@ -349,7 +349,8 @@ checkCmdParser mTopLevel cmdParser =
       processMain next
     Free (CmdParserSynopsis s next) -> do
       cmd :: CommandDesc out <- mGet
-      mSet $ cmd { _cmd_synopsis = Just $ PP.text s }
+      mSet
+        $ cmd { _cmd_synopsis = Just $ PP.fsep $ fmap PP.text $ List.words s }
       processMain next
     Free (CmdParserPeekDesc nextF) -> do
       processMain $ nextF monadMisuseError
@@ -546,7 +547,8 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
       processMain next
     Free (CmdParserSynopsis s next) -> do
       cmd :: CommandDesc out <- mGet
-      mSet $ cmd { _cmd_synopsis = Just $ PP.text s }
+      mSet
+        $ cmd { _cmd_synopsis = Just $ PP.fsep $ fmap PP.text $ List.words s }
       processMain next
     Free (CmdParserPeekDesc nextF) -> do
       parser                    <- mGet
@@ -1017,7 +1019,8 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
       next
     CmdParserSynopsis s next -> do
       cmd :: CommandDesc out <- mGet
-      mSet $ cmd { _cmd_synopsis = Just $ PP.text s }
+      mSet
+        $ cmd { _cmd_synopsis = Just $ PP.fsep $ fmap PP.text $ List.words s }
       next
     CmdParserPeekDesc nextF -> do
       mGet >>= nextF . fmap (\(_ :: out) -> ())

src/UI/Butcher/Monadic/Pretty.hs

@@ -320,11 +320,10 @@ ppPartDescUsage = \case
   PartSeq ps -> [ PP.fsep ds | let ds = Maybe.mapMaybe rec ps, not (null ds) ]
   PartDefault    _   p -> PP.brackets <$> rec p
   PartSuggestion sgs p -> rec p <&> \d ->
-    PP.parens
-      $  PP.fcat
-      $  PP.punctuate (PP.text "|")
-      $  [ PP.text s | CompletionString s <- sgs ]
-      ++ [d]
+    case [ PP.text s | CompletionString s <- sgs ] of
+      [] -> d
+      sgsDocs ->
+        PP.parens $ PP.fcat $ PP.punctuate (PP.text "|") $ sgsDocs ++ [d]
   PartRedirect s _ -> Just $ PP.text s
   PartMany p       -> rec p <&> (<> PP.text "+")
   PartWithHelp _ p -> rec p