feat: add color to helper texts

src/Data/CLI/Args.hs

@@ -1,16 +1,20 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 -- | Global command-line options shared by all commands.
 module Data.CLI.Args (
   CLIArgs (..),
   getLogLevel,
   showVersion,
   versionOrCommand,
   argParser,
+  argParserWith,
 ) where
 
 import Control.Monad.Logger (LogLevel (..))
-import Data.List (intercalate)
+import Data.CLI.Impl (HelpStyle (..), defaultHelpStyle, styled)
 import Data.Maybe (fromMaybe)
 import Options.Applicative
+import Options.Applicative.Help.Pretty (punctuate, (<+>))
 
 -- | Parsed global options, with the command of type @c@.
 --
@@ -67,20 +71,34 @@ versionOrCommand v a run = either (const (showVersion v)) run (_command a)
 --
 -- @since 0.1.0.0
 argParser :: Parser c -> Parser (CLIArgs c)
-argParser cmdParser =
+argParser = argParserWith defaultHelpStyle
+
+-- | 'argParser' with a custom t'HelpStyle'.
+--
+-- @since 0.2.2.0
+argParserWith :: HelpStyle -> Parser c -> Parser (CLIArgs c)
+argParserWith s cmdParser =
   CLIArgs
     <$> optional
       ( option
           (maybeReader (`lookup` logLevels))
           ( short 'l'
               <> long "log-level"
               <> metavar "LEVEL"
-              <> help ("Log level: " <> intercalate ", " (fmap fst logLevels))
+              <> helpDoc (Just ("Log level:" <+> mconcat (punctuate ", " (fmap (val . fst) logLevels))))
           )
       )
-    <*> switch (short 'd' <> long "debug" <> help "Enable debug output (overruled by -l)")
+    <*> switch
+      ( short 'd'
+          <> long "debug"
+          <> helpDoc (Just ("Enable debug output (overruled by" <+> val "-l" <> ")"))
+      )
     <*> switch (short 'y' <> long "yes" <> help "Auto-accept all prompts")
-    <*> switch (short 'n' <> long "no" <> help "Auto-decline all prompts (overrides -y/--yes)")
+    <*> switch
+      ( short 'n'
+          <> long "no"
+          <> helpDoc (Just ("Auto-decline all prompts (overrides" <+> val "-y/--yes" <> ")"))
+      )
     <*> optional
       ( strOption
           (short 'c' <> long "config" <> metavar "PATH" <> help "Path to the configuration file")
@@ -90,3 +108,5 @@ argParser cmdParser =
               <|> Right
             <$> cmdParser
         )
+ where
+  val = styled _styleValue s

src/Data/CLI/Impl.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 -- | Helpers for building optparse-applicative parsers and subcommands.
 module Data.CLI.Impl (
   unboundEnumError,
@@ -11,6 +13,13 @@ module Data.CLI.Impl (
   mkCommand,
   mkCommands,
   usage,
+  usageWith,
+  HelpStyle (..),
+  defaultHelpStyle,
+  plainHelpStyle,
+  styled,
+  colorEnabled,
+  execCLIParser,
 ) where
 
 import Data.Bifunctor (first)
@@ -21,9 +30,80 @@ import Data.UUID (UUID)
 import Data.UUID qualified as UUID
 import Data.Void (Void)
 import Options.Applicative
+import Options.Applicative.Help.Pretty (
+  AnsiStyle,
+  Color (..),
+  Doc,
+  annotate,
+  bold,
+  color,
+  pretty,
+  unAnnotate,
+  underlined,
+  (<+>),
+ )
+import System.Environment (getArgs, lookupEnv)
+import System.IO (hIsTerminalDevice, stderr, stdout)
 import Text.Megaparsec (Parsec, eof, errorBundlePretty, runParser)
 import Text.Printf (printf)
 
+-- | ANSI styles applied to help texts.
+--
+-- @since 0.2.2.0
+data HelpStyle = HelpStyle
+  { _styleName :: AnsiStyle
+  -- ^ program name in the header
+  , _styleVersion :: AnsiStyle
+  -- ^ version in the header
+  , _styleValue :: AnsiStyle
+  -- ^ accepted values and option references
+  , _styleWarning :: AnsiStyle
+  -- ^ dangerous behavior
+  }
+
+-- | Bold underlined name, green version, cyan values, bold red warnings.
+--
+-- @since 0.2.2.0
+defaultHelpStyle :: HelpStyle
+defaultHelpStyle = HelpStyle (bold <> underlined) (color Green) (color Cyan) (bold <> color Red)
+
+-- | No styling.
+--
+-- @since 0.2.2.0
+plainHelpStyle :: HelpStyle
+plainHelpStyle = HelpStyle mempty mempty mempty mempty
+
+-- | Render a string with the selected style of a t'HelpStyle'.
+--
+-- @since 0.2.2.0
+styled :: (HelpStyle -> AnsiStyle) -> HelpStyle -> String -> Doc
+styled f s
+  | f s == mempty = pretty
+  | otherwise = annotate (f s) . pretty
+
+-- | Whether colors should be emitted: stdout and stderr are terminals and @NO_COLOR@ is unset or empty.
+--
+-- @since 0.2.2.0
+colorEnabled :: IO Bool
+colorEnabled = do
+  noColor <- maybe False (not . null) <$> lookupEnv "NO_COLOR"
+  ttys <- and <$> traverse hIsTerminalDevice [stdout, stderr]
+  pure (ttys && not noColor)
+
+-- | Like 'execParser', stripping help styles when 'colorEnabled' is false.
+--
+-- @since 0.2.2.0
+execCLIParser :: ParserInfo a -> IO a
+execCLIParser pinfo = do
+  c <- colorEnabled
+  res <- execParserPure defaultPrefs pinfo <$> getArgs
+  handleParseResult (if c then res else strip res)
+ where
+  strip (Failure (ParserFailure f)) = Failure (ParserFailure (\p -> let (h, e, w) = f p in (plain h, e, w)))
+  strip r = r
+  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)
+  u = fmap unAnnotate
+
 -- | Error for 'succ' called on 'maxBound' of the named enum.
 --
 -- @since 0.1.0.0
@@ -63,7 +143,12 @@ noArgs = pure
 --
 -- @since 0.1.0.0
 forceSwitch :: Parser Bool
-forceSwitch = switch (short 'f' <> long "force" <> help "force unsafe behavior")
+forceSwitch =
+  switch
+    ( short 'f'
+        <> long "force"
+        <> helpDoc (Just ("force" <+> styled _styleWarning defaultHelpStyle "unsafe" <+> "behavior"))
+    )
 
 -- | @-n@/@--noop@ switch for dry runs.
 --
@@ -103,7 +188,24 @@ mkCommands f = foldMap (mkCommand . f) (sortOn cmdname [minBound ..])
 --
 -- @since 0.1.0.0
 usage :: String -> String -> String -> Parser a -> ParserInfo a
-usage name version hdr p =
+usage = usageWith defaultHelpStyle
+
+-- | 'usage' with a custom t'HelpStyle'.
+--
+-- @since 0.2.2.0
+usageWith :: HelpStyle -> String -> String -> String -> Parser a -> ParserInfo a
+usageWith s name version hdr p =
   info
     (p <**> helper)
-    (fullDesc <> progDesc hdr <> header (printf "%s - %s - version %s" name hdr version))
+    ( fullDesc
+        <> progDesc hdr
+        <> headerDoc
+          ( Just
+              ( styled _styleName s name
+                  <+> "-"
+                  <+> pretty hdr
+                  <+> "- version"
+                  <+> styled _styleVersion s version
+              )
+          )
+    )

test/Spec.hs

@@ -1,8 +1,9 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-import Data.CLI.Impl (fromParsec, reversibleSwitch)
+import Data.CLI.Impl (fromParsec, plainHelpStyle, reversibleSwitch, usage, usageWith)
 import Data.Error.CLI (CLIError (..), displayCLIError)
+import Data.List (isInfixOf)
 import Effectful (Eff, IOE, liftIO, runEff)
 import Effectful.CLI.Conc (batchConcurrentlyWithIndex)
 import Effectful.CLI.Exception (rethrowIO)
@@ -85,3 +86,14 @@ main = hspec $ do
           parse = getParseResult . execParserPure defaultPrefs p
        in fmap parse [[], ["--no-labels"], ["--no-labels", "--labels"], ["--labels", "--no-labels"]]
             `shouldBe` fmap Just [True, False, True, False]
+
+  describe "usage"
+    $ it "styles the header unless plain"
+    $ let render st = case execParserPure defaultPrefs (st "prog" "1.0" "desc" (pure ())) ["--help"] of
+            Failure f -> fst (renderFailure f "prog")
+            _ -> ""
+       in ( "\ESC[" `isInfixOf` render usage
+          , "\ESC[" `isInfixOf` render (usageWith plainHelpStyle)
+          , "prog - desc - version 1.0" `isInfixOf` render (usageWith plainHelpStyle)
+          )
+            `shouldBe` (True, False, True)