Skip to content

Commit 8a993da

Browse files
drlkfdrlkf
committed
feat: add color to helper texts
1 parent d1cee74 commit 8a993da

3 files changed

Lines changed: 143 additions & 9 deletions

File tree

‎src/Data/CLI/Args.hs‎

Lines changed: 25 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,20 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
13
-- | Global command-line options shared by all commands.
24
module Data.CLI.Args (
35
CLIArgs (..),
46
getLogLevel,
57
showVersion,
68
versionOrCommand,
79
argParser,
10+
argParserWith,
811
) where
912

1013
import Control.Monad.Logger (LogLevel (..))
11-
import Data.List (intercalate)
14+
import Data.CLI.Impl (HelpStyle (..), defaultHelpStyle, styled)
1215
import Data.Maybe (fromMaybe)
1316
import Options.Applicative
17+
import Options.Applicative.Help.Pretty (punctuate, (<+>))
1418

1519
-- | Parsed global options, with the command of type @c@.
1620
--
@@ -67,20 +71,34 @@ versionOrCommand v a run = either (const (showVersion v)) run (_command a)
6771
--
6872
-- @since 0.1.0.0
6973
argParser :: Parser c -> Parser (CLIArgs c)
70-
argParser cmdParser =
74+
argParser = argParserWith defaultHelpStyle
75+
76+
-- | 'argParser' with a custom t'HelpStyle'.
77+
--
78+
-- @since 0.2.2.0
79+
argParserWith :: HelpStyle -> Parser c -> Parser (CLIArgs c)
80+
argParserWith s cmdParser =
7181
CLIArgs
7282
<$> optional
7383
( option
7484
(maybeReader (`lookup` logLevels))
7585
( short 'l'
7686
<> long "log-level"
7787
<> metavar "LEVEL"
78-
<> help ("Log level: " <> intercalate ", " (fmap fst logLevels))
88+
<> helpDoc (Just ("Log level:" <+> mconcat (punctuate ", " (fmap (val . fst) logLevels))))
7989
)
8090
)
81-
<*> switch (short 'd' <> long "debug" <> help "Enable debug output (overruled by -l)")
91+
<*> switch
92+
( short 'd'
93+
<> long "debug"
94+
<> helpDoc (Just ("Enable debug output (overruled by" <+> val "-l" <> ")"))
95+
)
8296
<*> switch (short 'y' <> long "yes" <> help "Auto-accept all prompts")
83-
<*> switch (short 'n' <> long "no" <> help "Auto-decline all prompts (overrides -y/--yes)")
97+
<*> switch
98+
( short 'n'
99+
<> long "no"
100+
<> helpDoc (Just ("Auto-decline all prompts (overrides" <+> val "-y/--yes" <> ")"))
101+
)
84102
<*> optional
85103
( strOption
86104
(short 'c' <> long "config" <> metavar "PATH" <> help "Path to the configuration file")
@@ -90,3 +108,5 @@ argParser cmdParser =
90108
<|> Right
91109
<$> cmdParser
92110
)
111+
where
112+
val = styled _styleValue s

‎src/Data/CLI/Impl.hs‎

Lines changed: 105 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,5 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
13
-- | Helpers for building optparse-applicative parsers and subcommands.
24
module Data.CLI.Impl (
35
unboundEnumError,
@@ -11,6 +13,13 @@ module Data.CLI.Impl (
1113
mkCommand,
1214
mkCommands,
1315
usage,
16+
usageWith,
17+
HelpStyle (..),
18+
defaultHelpStyle,
19+
plainHelpStyle,
20+
styled,
21+
colorEnabled,
22+
execCLIParser,
1423
) where
1524

1625
import Data.Bifunctor (first)
@@ -21,9 +30,80 @@ import Data.UUID (UUID)
2130
import Data.UUID qualified as UUID
2231
import Data.Void (Void)
2332
import Options.Applicative
33+
import Options.Applicative.Help.Pretty (
34+
AnsiStyle,
35+
Color (..),
36+
Doc,
37+
annotate,
38+
bold,
39+
color,
40+
pretty,
41+
unAnnotate,
42+
underlined,
43+
(<+>),
44+
)
45+
import System.Environment (getArgs, lookupEnv)
46+
import System.IO (hIsTerminalDevice, stderr, stdout)
2447
import Text.Megaparsec (Parsec, eof, errorBundlePretty, runParser)
2548
import Text.Printf (printf)
2649

50+
-- | ANSI styles applied to help texts.
51+
--
52+
-- @since 0.2.2.0
53+
data HelpStyle = HelpStyle
54+
{ _styleName :: AnsiStyle
55+
-- ^ program name in the header
56+
, _styleVersion :: AnsiStyle
57+
-- ^ version in the header
58+
, _styleValue :: AnsiStyle
59+
-- ^ accepted values and option references
60+
, _styleWarning :: AnsiStyle
61+
-- ^ dangerous behavior
62+
}
63+
64+
-- | Bold underlined name, green version, cyan values, bold red warnings.
65+
--
66+
-- @since 0.2.2.0
67+
defaultHelpStyle :: HelpStyle
68+
defaultHelpStyle = HelpStyle (bold <> underlined) (color Green) (color Cyan) (bold <> color Red)
69+
70+
-- | No styling.
71+
--
72+
-- @since 0.2.2.0
73+
plainHelpStyle :: HelpStyle
74+
plainHelpStyle = HelpStyle mempty mempty mempty mempty
75+
76+
-- | Render a string with the selected style of a t'HelpStyle'.
77+
--
78+
-- @since 0.2.2.0
79+
styled :: (HelpStyle -> AnsiStyle) -> HelpStyle -> String -> Doc
80+
styled f s
81+
| f s == mempty = pretty
82+
| otherwise = annotate (f s) . pretty
83+
84+
-- | Whether colors should be emitted: stdout and stderr are terminals and @NO_COLOR@ is unset or empty.
85+
--
86+
-- @since 0.2.2.0
87+
colorEnabled :: IO Bool
88+
colorEnabled = do
89+
noColor <- maybe False (not . null) <$> lookupEnv "NO_COLOR"
90+
ttys <- and <$> traverse hIsTerminalDevice [stdout, stderr]
91+
pure (ttys && not noColor)
92+
93+
-- | Like 'execParser', stripping help styles when 'colorEnabled' is false.
94+
--
95+
-- @since 0.2.2.0
96+
execCLIParser :: ParserInfo a -> IO a
97+
execCLIParser pinfo = do
98+
c <- colorEnabled
99+
res <- execParserPure defaultPrefs pinfo <$> getArgs
100+
handleParseResult (if c then res else strip res)
101+
where
102+
strip (Failure (ParserFailure f)) = Failure (ParserFailure (\p -> let (h, e, w) = f p in (plain h, e, w)))
103+
strip r = r
104+
plain (ParserHelp a b c d e f g h) = ParserHelp (u a) (u b) (u c) (u d) (u e) (u f) (u g) (u h)
105+
u = fmap unAnnotate
106+
27107
-- | Error for 'succ' called on 'maxBound' of the named enum.
28108
--
29109
-- @since 0.1.0.0
@@ -63,7 +143,12 @@ noArgs = pure
63143
--
64144
-- @since 0.1.0.0
65145
forceSwitch :: Parser Bool
66-
forceSwitch = switch (short 'f' <> long "force" <> help "force unsafe behavior")
146+
forceSwitch =
147+
switch
148+
( short 'f'
149+
<> long "force"
150+
<> helpDoc (Just ("force" <+> styled _styleWarning defaultHelpStyle "unsafe" <+> "behavior"))
151+
)
67152

68153
-- | @-n@/@--noop@ switch for dry runs.
69154
--
@@ -103,7 +188,24 @@ mkCommands f = foldMap (mkCommand . f) (sortOn cmdname [minBound ..])
103188
--
104189
-- @since 0.1.0.0
105190
usage :: String -> String -> String -> Parser a -> ParserInfo a
106-
usage name version hdr p =
191+
usage = usageWith defaultHelpStyle
192+
193+
-- | 'usage' with a custom t'HelpStyle'.
194+
--
195+
-- @since 0.2.2.0
196+
usageWith :: HelpStyle -> String -> String -> String -> Parser a -> ParserInfo a
197+
usageWith s name version hdr p =
107198
info
108199
(p <**> helper)
109-
(fullDesc <> progDesc hdr <> header (printf "%s - %s - version %s" name hdr version))
200+
( fullDesc
201+
<> progDesc hdr
202+
<> headerDoc
203+
( Just
204+
( styled _styleName s name
205+
<+> "-"
206+
<+> pretty hdr
207+
<+> "- version"
208+
<+> styled _styleVersion s version
209+
)
210+
)
211+
)

‎test/Spec.hs‎

Lines changed: 13 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,9 @@
11
{-# LANGUAGE DataKinds #-}
22
{-# LANGUAGE OverloadedStrings #-}
33

4-
import Data.CLI.Impl (fromParsec, reversibleSwitch)
4+
import Data.CLI.Impl (fromParsec, plainHelpStyle, reversibleSwitch, usage, usageWith)
55
import Data.Error.CLI (CLIError (..), displayCLIError)
6+
import Data.List (isInfixOf)
67
import Effectful (Eff, IOE, liftIO, runEff)
78
import Effectful.CLI.Conc (batchConcurrentlyWithIndex)
89
import Effectful.CLI.Exception (rethrowIO)
@@ -85,3 +86,14 @@ main = hspec $ do
8586
parse = getParseResult . execParserPure defaultPrefs p
8687
in fmap parse [[], ["--no-labels"], ["--no-labels", "--labels"], ["--labels", "--no-labels"]]
8788
`shouldBe` fmap Just [True, False, True, False]
89+
90+
describe "usage"
91+
$ it "styles the header unless plain"
92+
$ let render st = case execParserPure defaultPrefs (st "prog" "1.0" "desc" (pure ())) ["--help"] of
93+
Failure f -> fst (renderFailure f "prog")
94+
_ -> ""
95+
in ( "\ESC[" `isInfixOf` render usage
96+
, "\ESC[" `isInfixOf` render (usageWith plainHelpStyle)
97+
, "prog - desc - version 1.0" `isInfixOf` render (usageWith plainHelpStyle)
98+
)
99+
`shouldBe` (True, False, True)

0 commit comments

Comments
 (0)