diff --git a/src/Data/CLI/Args.hs b/src/Data/CLI/Args.hs index 430ecb9..445fea7 100644 --- a/src/Data/CLI/Args.hs +++ b/src/Data/CLI/Args.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | Global command-line options shared by all commands. module Data.CLI.Args ( CLIArgs (..), @@ -5,12 +7,14 @@ module Data.CLI.Args ( 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,7 +71,13 @@ 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 @@ -75,12 +85,20 @@ argParser cmdParser = ( 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 diff --git a/src/Data/CLI/Impl.hs b/src/Data/CLI/Impl.hs index 8e62fde..ee1e639 100644 --- a/src/Data/CLI/Impl.hs +++ b/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 + ) + ) + ) diff --git a/test/Spec.hs b/test/Spec.hs index 29a8789..32a2c66 100644 --- a/test/Spec.hs +++ b/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)