module Options.Applicative.Extra (
helper,
execParser,
execParserPure,
customExecParser,
usage,
ParserFailure(..),
) where
import Control.Applicative ((<$>), (<|>))
import System.Environment (getArgs, getProgName)
import System.Exit (exitWith, ExitCode(..))
import System.IO (hPutStr, stderr)
import Options.Applicative.BashCompletion
import Options.Applicative.Common
import Options.Applicative.Builder hiding (briefDesc)
import Options.Applicative.Help
import Options.Applicative.Internal
import Options.Applicative.Utils
import Options.Applicative.Types
helper :: Parser (a -> a)
helper = nullOption
( long "help"
<> reader (const (Left ShowHelpText))
<> noArgError ShowHelpText
<> short 'h'
<> help "Show this help text"
<> value id
<> metavar ""
<> hidden )
execParser :: ParserInfo a -> IO a
execParser = customExecParser (prefs idm)
customExecParser :: ParserPrefs -> ParserInfo a -> IO a
customExecParser pprefs pinfo = do
args <- getArgs
case execParserPure pprefs pinfo args of
Right a -> return a
Left failure -> do
progn <- getProgName
let c = errExitCode failure
msg <- errMessage failure progn
case c of
ExitSuccess -> putStr msg
_ -> hPutStr stderr msg
exitWith c
data Result a = Result a
| Extra ParserFailure
execParserPure :: ParserPrefs
-> ParserInfo a
-> [String]
-> Either ParserFailure a
execParserPure pprefs pinfo args =
case runP p pprefs of
(Right r, _) -> case r of
Result a -> Right a
Extra failure -> Left failure
(Left msg, ctx) -> Left $
parserFailure pprefs pinfo msg ctx
where
parser = infoParser pinfo
parser' = (Extra <$> bashCompletionParser parser pprefs)
<|> (Result <$> parser)
p = runParserFully parser' args
parserFailure :: ParserPrefs -> ParserInfo a
-> ParseError -> Context
-> ParserFailure
parserFailure pprefs pinfo msg ctx = ParserFailure
{ errMessage = \progn
-> with_context ctx pinfo $ \names ->
return
. show_help
. add_error
. add_usage names progn
, errExitCode = ExitFailure (infoFailureCode pinfo) }
where
add_usage names progn i = i
{ infoHeader = vcat
( header_line i ++
[ usage pprefs (infoParser i) ename ] ) }
where
ename = unwords (progn : names)
add_error i = i
{ infoHeader = vcat (error_msg ++ [infoHeader i]) }
error_msg = case msg of
ShowHelpText -> []
ErrorMsg m -> [m]
show_full_help = case msg of
ShowHelpText -> True
_ -> prefShowHelpOnError pprefs
show_help i
| show_full_help
= parserHelpText pprefs i
| otherwise
= unlines $ filter (not . null) [ infoHeader i ]
header_line i
| show_full_help
= [ infoHeader i ]
| otherwise
= []
with_context :: Context
-> ParserInfo a
-> (forall b . [String] -> ParserInfo b -> c)
-> c
with_context NullContext i f = f [] i
with_context (Context n i) _ f = f n i
usage :: ParserPrefs -> Parser a -> String -> String
usage pprefs p progn = foldr (<+>) ""
[ "Usage:"
, progn
, briefDesc pprefs p ]