diff --git a/src/UI/Butcher/Monadic.hs b/src/UI/Butcher/Monadic.hs
index 35f527b..b254b00 100644
--- a/src/UI/Butcher/Monadic.hs
+++ b/src/UI/Butcher/Monadic.hs
@@ -29,6 +29,7 @@ module UI.Butcher.Monadic
-- * Builtin commands
, addHelpCommand
, addHelpCommand2
+ , addHelpCommandWith
, addButcherDebugCommand
, addShellCompletionCommand
, addShellCompletionCommand'
diff --git a/src/UI/Butcher/Monadic/BuiltinCommands.hs b/src/UI/Butcher/Monadic/BuiltinCommands.hs
index a82dafc..bc4ae92 100644
--- a/src/UI/Butcher/Monadic/BuiltinCommands.hs
+++ b/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.
--
diff --git a/src/UI/Butcher/Monadic/Flag.hs b/src/UI/Butcher/Monadic/Flag.hs
index 64b1930..0fd8119 100644
--- a/src/UI/Butcher/Monadic/Flag.hs
+++ b/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
diff --git a/src/UI/Butcher/Monadic/Internal/Core.hs b/src/UI/Butcher/Monadic/Internal/Core.hs
index 0c52434..cddd0b4 100644
--- a/src/UI/Butcher/Monadic/Internal/Core.hs
+++ b/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) -> ())
diff --git a/src/UI/Butcher/Monadic/Pretty.hs b/src/UI/Butcher/Monadic/Pretty.hs
index 755b7a5..adad104 100644
--- a/src/UI/Butcher/Monadic/Pretty.hs
+++ b/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