{-# LANGUAGE RankNTypes #-}
module Options.Applicative.Extra (
-- * Extra parser utilities
--
-- | This module contains high-level functions to run parsers.
helper,
hsubparser,
execParser,
execParserMaybe,
customExecParser,
customExecParserMaybe,
execParserPure,
getParseResult,
handleParseResult,
parserFailure,
renderFailure,
ParserFailure(..),
overFailure,
ParserResult(..),
ParserPrefs(..),
CompletionResult(..),
) where
import Control.Applicative
import Data.Monoid
import Prelude
import System.Environment (getArgs, getProgName)
import System.Exit (exitSuccess, exitWith, ExitCode(..))
import System.IO (hPutStrLn, stderr)
import Options.Applicative.BashCompletion
import Options.Applicative.Builder
import Options.Applicative.Builder.Internal
import Options.Applicative.Common
import Options.Applicative.Help
import Options.Applicative.Internal
import Options.Applicative.Types
-- | A hidden \"helper\" option which always fails.
--
-- A common usage pattern is to apply this applicatively when
-- creating a 'ParserInfo'
--
-- > opts :: ParserInfo Sample
-- > opts = info (sample <**> helper) mempty
helper :: Parser (a -> a)
helper = abortOption ShowHelpText $ mconcat
[ long "help"
, short 'h'
, help "Show this help text"
, hidden ]
-- | Builder for a command parser with a \"helper\" option attached.
-- Used in the same way as `subparser`, but includes a \"--help|-h\" inside
-- the subcommand.
hsubparser :: Mod CommandFields a -> Parser a
hsubparser m = mkParser d g rdr
where
Mod _ d g = metavar "COMMAND" `mappend` m
(groupName, cmds, subs) = mkCommand m
rdr = CmdReader groupName cmds (fmap add_helper . subs)
add_helper pinfo = pinfo
{ infoParser = infoParser pinfo <**> helper }
-- | Run a program description.
--
-- Parse command line arguments. Display help text and exit if any parse error
-- occurs.
execParser :: ParserInfo a -> IO a
execParser = customExecParser defaultPrefs
-- | Run a program description with custom preferences.
customExecParser :: ParserPrefs -> ParserInfo a -> IO a
customExecParser pprefs pinfo
= execParserPure pprefs pinfo <$> getArgs
>>= handleParseResult
-- | Handle `ParserResult`.
handleParseResult :: ParserResult a -> IO a
handleParseResult (Success a) = return a
handleParseResult (Failure failure) = do
progn <- getProgName
let (msg, exit) = renderFailure failure progn
case exit of
ExitSuccess -> putStrLn msg
_ -> hPutStrLn stderr msg
exitWith exit
handleParseResult (CompletionInvoked compl) = do
progn <- getProgName
msg <- execCompletion compl progn
putStr msg
exitSuccess
-- | Extract the actual result from a `ParserResult` value.
--
-- This function returns 'Nothing' in case of errors. Possible error messages
-- or completion actions are simply discarded.
--
-- If you want to display error messages and invoke completion actions
-- appropriately, use 'handleParseResult' instead.
getParseResult :: ParserResult a -> Maybe a
getParseResult (Success a) = Just a
getParseResult _ = Nothing
-- | Run a program description in pure code.
--
-- This function behaves like 'execParser', but can be called from pure code.
-- Note that, in case of errors, no message is displayed, and this function
-- simply returns 'Nothing'.
--
-- If you need to keep track of error messages, use 'execParserPure' instead.
{-# DEPRECATED execParserMaybe "Use execParserPure together with getParseResult instead" #-}
execParserMaybe :: ParserInfo a -> [String] -> Maybe a
execParserMaybe = customExecParserMaybe defaultPrefs
-- | Run a program description with custom preferences in pure code.
--
-- See 'execParserMaybe' for details.
{-# DEPRECATED customExecParserMaybe "Use execParserPure together with getParseResult instead" #-}
customExecParserMaybe :: ParserPrefs -> ParserInfo a -> [String] -> Maybe a
customExecParserMaybe pprefs pinfo args = getParseResult $ execParserPure pprefs pinfo args
-- | The most general way to run a program description in pure code.
execParserPure :: ParserPrefs -- ^ Global preferences for this parser
-> ParserInfo a -- ^ Description of the program to run
-> [String] -- ^ Program arguments
-> ParserResult a
execParserPure pprefs pinfo args =
case runP p pprefs of
(Right (Right r), _) -> Success r
(Right (Left c), _) -> CompletionInvoked c
(Left err, ctx) -> Failure $ parserFailure pprefs pinfo err ctx
where
pinfo' = pinfo
{ infoParser = (Left <$> bashCompletionParser pinfo pprefs)
<|> (Right <$> infoParser pinfo) }
p = runParserInfo pinfo' args
-- | Generate a `ParserFailure` from a `ParseError` in a given `Context`.
--
-- This function can be used, for example, to show the help text for a parser:
--
-- @handleParseResult . Failure $ parserFailure pprefs pinfo ShowHelpText mempty@
parserFailure :: ParserPrefs -> ParserInfo a
-> ParseError -> [Context]
-> ParserFailure ParserHelp
parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->
let h = with_context ctx pinfo $ \names pinfo' -> mconcat
[ base_help pinfo'
, usage_help progn names pinfo'
, suggestion_help
, error_help ]
in (h, exit_code, prefColumns pprefs)
where
exit_code = case msg of
ErrorMsg {} -> ExitFailure (infoFailureCode pinfo)
UnknownError -> ExitFailure (infoFailureCode pinfo)
MissingError {} -> ExitFailure (infoFailureCode pinfo)
ExpectsArgError {} -> ExitFailure (infoFailureCode pinfo)
UnexpectedError {} -> ExitFailure (infoFailureCode pinfo)
ShowHelpText -> ExitSuccess
InfoMsg {} -> ExitSuccess
with_context :: [Context]
-> ParserInfo a
-> (forall b . [String] -> ParserInfo b -> c)
-> c
with_context [] i f = f [] i
with_context c@(Context _ i:_) _ f = f (contextNames c) i
usage_help progn names i = case msg of
InfoMsg _
-> mempty
_
-> usageHelp $ vcatChunks
[ pure . parserUsage pprefs (infoParser i) . unwords $ progn : names
, fmap (indent 2) . infoProgDesc $ i ]
error_help = errorHelp $ case msg of
ShowHelpText
-> mempty
ErrorMsg m
-> stringChunk m
InfoMsg m
-> stringChunk m
MissingError CmdStart _
| prefShowHelpOnEmpty pprefs
-> mempty
MissingError _ (SomeParser x)
-> stringChunk "Missing:" <<+>> missingDesc pprefs x
ExpectsArgError x
-> stringChunk $ "The option `" ++ x ++ "` expects an argument."
UnexpectedError arg _
-> stringChunk msg'
where
--
-- This gives us the same error we have always
-- reported
msg' = case arg of
('-':_) -> "Invalid option `" ++ arg ++ "'"
_ -> "Invalid argument `" ++ arg ++ "'"
UnknownError
-> mempty
suggestion_help = suggestionsHelp $ case msg of
UnexpectedError arg (SomeParser x)
--
-- We have an unexpected argument and the parser which
-- it's running over.
--
-- We can make a good help suggestion here if we do
-- a levenstein distance between all possible suggestions
-- and the supplied option or argument.
-> suggestions
where
--
-- Not using chunked here, as we don't want to
-- show "Did you mean" if there's nothing there
-- to show
suggestions = (.$.) <$> prose
<*> (indent 4 <$> (vcatChunks . fmap stringChunk $ good ))
--
-- We won't worry about the 0 case, it won't be
-- shown anyway.
prose = if length good < 2
then stringChunk "Did you mean this?"
else stringChunk "Did you mean one of these?"
--
-- Suggestions we will show, they're close enough
-- to what the user wrote
good = filter isClose possibles
--
-- Bit of an arbitrary decision here.
-- Edit distances of 1 or 2 will give hints
isClose a = editDistance a arg < 3
--
-- Similar to how bash completion works.
-- We map over the parser and get the names
-- ( no IO here though, unlike for completers )
possibles = concat $ mapParser opt_completions x
--
-- Look at the option and give back the possible
-- things the user could type. If it's a command
-- reader also ensure that it can be immediately
-- reachable from where the error was given.
opt_completions hinfo opt = case optMain opt of
OptReader ns _ _ -> fmap showOption ns
FlagReader ns _ -> fmap showOption ns
ArgReader _ -> []
CmdReader _ ns _ | hinfoUnreachableArgs hinfo
-> []
| otherwise
-> ns
_
-> mempty
base_help :: ParserInfo a -> ParserHelp
base_help i
| show_full_help
= mconcat [h, f, parserHelp pprefs (infoParser i)]
| otherwise
= mempty
where
h = headerHelp (infoHeader i)
f = footerHelp (infoFooter i)
show_full_help = case msg of
ShowHelpText -> True
MissingError CmdStart _ | prefShowHelpOnEmpty pprefs
-> True
_ -> prefShowHelpOnError pprefs
renderFailure :: ParserFailure ParserHelp -> String -> (String, ExitCode)
renderFailure failure progn =
let (h, exit, cols) = execFailure failure progn
in (renderHelp cols h, exit)