module Options.Applicative.Extra (
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
helper :: Parser (a -> a)
helper = abortOption ShowHelpText $ mconcat
[ long "help"
, short 'h'
, help "Show this help text"
, hidden ]
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 }
execParser :: ParserInfo a -> IO a
execParser = customExecParser defaultPrefs
customExecParser :: ParserPrefs -> ParserInfo a -> IO a
customExecParser pprefs pinfo
= execParserPure pprefs pinfo <$> getArgs
>>= handleParseResult
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
getParseResult :: ParserResult a -> Maybe a
getParseResult (Success a) = Just a
getParseResult _ = Nothing
execParserMaybe :: ParserInfo a -> [String] -> Maybe a
execParserMaybe = customExecParserMaybe defaultPrefs
customExecParserMaybe :: ParserPrefs -> ParserInfo a -> [String] -> Maybe a
customExecParserMaybe pprefs pinfo args = getParseResult $ execParserPure pprefs pinfo args
execParserPure :: ParserPrefs
-> ParserInfo a
-> [String]
-> 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
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
msg' = case arg of
('-':_) -> "Invalid option `" ++ arg ++ "'"
_ -> "Invalid argument `" ++ arg ++ "'"
UnknownError
-> mempty
suggestion_help = suggestionsHelp $ case msg of
UnexpectedError arg (SomeParser x)
-> suggestions
where
suggestions = (.$.) <$> prose
<*> (indent 4 <$> (vcatChunks . fmap stringChunk $ good ))
prose = if length good < 2
then stringChunk "Did you mean this?"
else stringChunk "Did you mean one of these?"
good = filter isClose possibles
isClose a = editDistance a arg < 3
possibles = concat $ mapParser opt_completions x
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)