{-# LANGUAGE RankNTypes #-}
module Options.Applicative.Extra (
helper,
helperWith,
hsubparser,
execParser,
customExecParser,
execParserPure,
getParseResult,
handleParseResult,
parserFailure,
renderFailure,
ParserFailure(..),
overFailure,
ParserResult(..),
ParserPrefs(..),
CompletionResult(..),
) where
import Control.Applicative
import Control.Monad (void)
import Data.Monoid
import Data.Foldable (traverse_)
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 :: forall a. Parser (a -> a)
helper =
forall a. Mod OptionFields (a -> a) -> Parser (a -> a)
helperWith (forall a. Monoid a => [a] -> a
mconcat [
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"help",
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'h',
forall (f :: * -> *) a. String -> Mod f a
help String
"Show this help text"
])
helperWith :: Mod OptionFields (a -> a) -> Parser (a -> a)
helperWith :: forall a. Mod OptionFields (a -> a) -> Parser (a -> a)
helperWith Mod OptionFields (a -> a)
modifiers =
forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall {b}. ReadM b
helpReader forall a b. (a -> b) -> a -> b
$
forall a. Monoid a => [a] -> a
mconcat
[ forall (f :: * -> *) a. HasValue f => a -> Mod f a
value forall a. a -> a
id,
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"",
forall (f :: * -> *) a. Mod f a
noGlobal,
forall a. ParseError -> Mod OptionFields a
noArgError (Maybe String -> ParseError
ShowHelpText forall a. Maybe a
Nothing),
forall (f :: * -> *) a. Mod f a
hidden,
Mod OptionFields (a -> a)
modifiers
]
where
helpReader :: ReadM b
helpReader = do
String
potentialCommand <- ReadM String
readerAsk
forall a. ParseError -> ReadM a
readerAbort forall a b. (a -> b) -> a -> b
$
Maybe String -> ParseError
ShowHelpText (forall a. a -> Maybe a
Just String
potentialCommand)
hsubparser :: Mod CommandFields a -> Parser a
hsubparser :: forall a. Mod CommandFields a -> Parser a
hsubparser Mod CommandFields a
m = forall a.
DefaultProp a
-> (OptProperties -> OptProperties) -> OptReader a -> Parser a
mkParser DefaultProp a
d OptProperties -> OptProperties
g OptReader a
rdr
where
Mod CommandFields a -> CommandFields a
_ DefaultProp a
d OptProperties -> OptProperties
g = forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"COMMAND" forall a. Monoid a => a -> a -> a
`mappend` Mod CommandFields a
m
(Maybe String
groupName, [String]
cmds, String -> Maybe (ParserInfo a)
subs) = forall a.
Mod CommandFields a
-> (Maybe String, [String], String -> Maybe (ParserInfo a))
mkCommand Mod CommandFields a
m
rdr :: OptReader a
rdr = forall a.
Maybe String
-> [String] -> (String -> Maybe (ParserInfo a)) -> OptReader a
CmdReader Maybe String
groupName [String]
cmds (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}. ParserInfo a -> ParserInfo a
add_helper forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe (ParserInfo a)
subs)
add_helper :: ParserInfo a -> ParserInfo a
add_helper ParserInfo a
pinfo = ParserInfo a
pinfo
{ infoParser :: Parser a
infoParser = forall a. ParserInfo a -> Parser a
infoParser ParserInfo a
pinfo forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> forall a. Parser (a -> a)
helper }
execParser :: ParserInfo a -> IO a
execParser :: forall a. ParserInfo a -> IO a
execParser = forall a. ParserPrefs -> ParserInfo a -> IO a
customExecParser ParserPrefs
defaultPrefs
customExecParser :: ParserPrefs -> ParserInfo a -> IO a
customExecParser :: forall a. ParserPrefs -> ParserInfo a -> IO a
customExecParser ParserPrefs
pprefs ParserInfo a
pinfo
= forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
execParserPure ParserPrefs
pprefs ParserInfo a
pinfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
getArgs
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. ParserResult a -> IO a
handleParseResult
handleParseResult :: ParserResult a -> IO a
handleParseResult :: forall a. ParserResult a -> IO a
handleParseResult (Success a
a) = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
handleParseResult (Failure ParserFailure ParserHelp
failure) = do
String
progn <- IO String
getProgName
let (String
msg, ExitCode
exit) = ParserFailure ParserHelp -> String -> (String, ExitCode)
renderFailure ParserFailure ParserHelp
failure String
progn
case ExitCode
exit of
ExitCode
ExitSuccess -> String -> IO ()
putStrLn String
msg
ExitCode
_ -> Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg
forall a. ExitCode -> IO a
exitWith ExitCode
exit
handleParseResult (CompletionInvoked CompletionResult
compl) = do
String
progn <- IO String
getProgName
String
msg <- CompletionResult -> String -> IO String
execCompletion CompletionResult
compl String
progn
String -> IO ()
putStr String
msg
forall a. IO a
exitSuccess
getParseResult :: ParserResult a -> Maybe a
getParseResult :: forall a. ParserResult a -> Maybe a
getParseResult (Success a
a) = forall a. a -> Maybe a
Just a
a
getParseResult ParserResult a
_ = forall a. Maybe a
Nothing
execParserPure :: ParserPrefs
-> ParserInfo a
-> [String]
-> ParserResult a
execParserPure :: forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
execParserPure ParserPrefs
pprefs ParserInfo a
pinfo [String]
args =
case forall a. P a -> ParserPrefs -> (Either ParseError a, [Context])
runP P (Either CompletionResult a)
p ParserPrefs
pprefs of
(Right (Right a
r), [Context]
_) -> forall a. a -> ParserResult a
Success a
r
(Right (Left CompletionResult
c), [Context]
_) -> forall a. CompletionResult -> ParserResult a
CompletionInvoked CompletionResult
c
(Left ParseError
err, [Context]
ctx) -> forall a. ParserFailure ParserHelp -> ParserResult a
Failure forall a b. (a -> b) -> a -> b
$ forall a.
ParserPrefs
-> ParserInfo a
-> ParseError
-> [Context]
-> ParserFailure ParserHelp
parserFailure ParserPrefs
pprefs ParserInfo a
pinfo ParseError
err [Context]
ctx
where
pinfo' :: ParserInfo (Either CompletionResult a)
pinfo' = ParserInfo a
pinfo
{ infoParser :: Parser (Either CompletionResult a)
infoParser = (forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ParserInfo a -> ParserPrefs -> Parser CompletionResult
bashCompletionParser ParserInfo a
pinfo ParserPrefs
pprefs)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ParserInfo a -> Parser a
infoParser ParserInfo a
pinfo) }
p :: P (Either CompletionResult a)
p = forall (m :: * -> *) a. MonadP m => ParserInfo a -> [String] -> m a
runParserInfo ParserInfo (Either CompletionResult a)
pinfo' [String]
args
parserFailure :: ParserPrefs -> ParserInfo a
-> ParseError -> [Context]
-> ParserFailure ParserHelp
parserFailure :: forall a.
ParserPrefs
-> ParserInfo a
-> ParseError
-> [Context]
-> ParserFailure ParserHelp
parserFailure ParserPrefs
pprefs ParserInfo a
pinfo ParseError
msg [Context]
ctx0 = forall h. (String -> (h, ExitCode, Int)) -> ParserFailure h
ParserFailure forall a b. (a -> b) -> a -> b
$ \String
progn ->
let h :: ParserHelp
h = forall a c.
[Context]
-> ParserInfo a -> (forall b. [String] -> ParserInfo b -> c) -> c
with_context [Context]
ctx ParserInfo a
pinfo forall a b. (a -> b) -> a -> b
$ \[String]
names ParserInfo b
pinfo' -> forall a. Monoid a => [a] -> a
mconcat
[ forall a. ParserInfo a -> ParserHelp
base_help ParserInfo b
pinfo'
, forall {a}. String -> [String] -> ParserInfo a -> ParserHelp
usage_help String
progn [String]
names ParserInfo b
pinfo'
, ParserHelp
suggestion_help
, [Context] -> ParserHelp
globals [Context]
ctx
, ParserHelp
error_help ]
in (ParserHelp
h, ExitCode
exit_code, ParserPrefs -> Int
prefColumns ParserPrefs
pprefs)
where
ctx :: [Context]
ctx = case ParseError
msg of
ShowHelpText (Just String
potentialCommand) ->
let ctx1 :: [Context]
ctx1 = forall a c.
[Context]
-> ParserInfo a -> (forall b. [String] -> ParserInfo b -> c) -> c
with_context [Context]
ctx0 ParserInfo a
pinfo forall a b. (a -> b) -> a -> b
$ \[String]
_ ParserInfo b
pinfo' ->
forall a b. (a, b) -> b
snd
forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. P a -> ParserPrefs -> (Either ParseError a, [Context])
runP ParserPrefs
defaultPrefs { prefBacktrack :: Backtracking
prefBacktrack = Backtracking
SubparserInline }
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadP m =>
ArgPolicy
-> Parser a -> String -> [String] -> m (Maybe (Parser a), [String])
runParserStep (forall a. ParserInfo a -> ArgPolicy
infoPolicy ParserInfo b
pinfo') (forall a. ParserInfo a -> Parser a
infoParser ParserInfo b
pinfo') String
potentialCommand []
in [Context]
ctx1 forall a. Monoid a => a -> a -> a
`mappend` [Context]
ctx0
ParseError
_ ->
[Context]
ctx0
exit_code :: ExitCode
exit_code = case ParseError
msg of
ErrorMsg {} -> Int -> ExitCode
ExitFailure (forall a. ParserInfo a -> Int
infoFailureCode ParserInfo a
pinfo)
ParseError
UnknownError -> Int -> ExitCode
ExitFailure (forall a. ParserInfo a -> Int
infoFailureCode ParserInfo a
pinfo)
MissingError {} -> Int -> ExitCode
ExitFailure (forall a. ParserInfo a -> Int
infoFailureCode ParserInfo a
pinfo)
ExpectsArgError {} -> Int -> ExitCode
ExitFailure (forall a. ParserInfo a -> Int
infoFailureCode ParserInfo a
pinfo)
UnexpectedError {} -> Int -> ExitCode
ExitFailure (forall a. ParserInfo a -> Int
infoFailureCode ParserInfo a
pinfo)
ShowHelpText {} -> ExitCode
ExitSuccess
InfoMsg {} -> ExitCode
ExitSuccess
with_context :: [Context]
-> ParserInfo a
-> (forall b . [String] -> ParserInfo b -> c)
-> c
with_context :: forall a c.
[Context]
-> ParserInfo a -> (forall b. [String] -> ParserInfo b -> c) -> c
with_context [] ParserInfo a
i forall b. [String] -> ParserInfo b -> c
f = forall b. [String] -> ParserInfo b -> c
f [] ParserInfo a
i
with_context c :: [Context]
c@(Context String
_ ParserInfo a
i:[Context]
_) ParserInfo a
_ forall b. [String] -> ParserInfo b -> c
f = forall b. [String] -> ParserInfo b -> c
f ([Context] -> [String]
contextNames [Context]
c) ParserInfo a
i
globals :: [Context] -> ParserHelp
globals :: [Context] -> ParserHelp
globals [Context]
cs =
let
voided :: [ParserInfo ()]
voided =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Context String
_ ParserInfo a
p) -> forall (f :: * -> *) a. Functor f => f a -> f ()
void ParserInfo a
p) [Context]
cs forall a. Monoid a => a -> a -> a
`mappend` forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. Functor f => f a -> f ()
void ParserInfo a
pinfo)
globalParsers :: Parser ()
globalParsers =
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall a. ParserInfo a -> Parser a
infoParser forall a b. (a -> b) -> a -> b
$
forall a. Int -> [a] -> [a]
drop Int
1 [ParserInfo ()]
voided
in
if ParserPrefs -> Bool
prefHelpShowGlobal ParserPrefs
pprefs then
forall a. ParserPrefs -> Parser a -> ParserHelp
parserGlobals ParserPrefs
pprefs Parser ()
globalParsers
else
forall a. Monoid a => a
mempty
usage_help :: String -> [String] -> ParserInfo a -> ParserHelp
usage_help String
progn [String]
names ParserInfo a
i = case ParseError
msg of
InfoMsg String
_
-> forall a. Monoid a => a
mempty
ParseError
_
-> forall a. Monoid a => [a] -> a
mconcat [
Chunk Doc -> ParserHelp
usageHelp (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ParserPrefs -> Parser a -> String -> Doc
parserUsage ParserPrefs
pprefs (forall a. ParserInfo a -> Parser a
infoParser ParserInfo a
i) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords forall a b. (a -> b) -> a -> b
$ String
progn forall a. a -> [a] -> [a]
: [String]
names)
, Chunk Doc -> ParserHelp
descriptionHelp (forall a. ParserInfo a -> Chunk Doc
infoProgDesc ParserInfo a
i)
]
error_help :: ParserHelp
error_help = Chunk Doc -> ParserHelp
errorHelp forall a b. (a -> b) -> a -> b
$ case ParseError
msg of
ShowHelpText {}
-> forall a. Monoid a => a
mempty
ErrorMsg String
m
-> String -> Chunk Doc
stringChunk String
m
InfoMsg String
m
-> String -> Chunk Doc
stringChunk String
m
MissingError IsCmdStart
CmdStart SomeParser
_
| ParserPrefs -> Bool
prefShowHelpOnEmpty ParserPrefs
pprefs
-> forall a. Monoid a => a
mempty
MissingError IsCmdStart
_ (SomeParser Parser a
x)
-> String -> Chunk Doc
stringChunk String
"Missing:" Chunk Doc -> Chunk Doc -> Chunk Doc
<<+>> forall a. ParserPrefs -> Parser a -> Chunk Doc
missingDesc ParserPrefs
pprefs Parser a
x
ExpectsArgError String
x
-> String -> Chunk Doc
stringChunk forall a b. (a -> b) -> a -> b
$ String
"The option `" forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
"` expects an argument."
UnexpectedError String
arg SomeParser
_
-> String -> Chunk Doc
stringChunk String
msg'
where
msg' :: String
msg' = case String
arg of
(Char
'-':String
_) -> String
"Invalid option `" forall a. [a] -> [a] -> [a]
++ String
arg forall a. [a] -> [a] -> [a]
++ String
"'"
String
_ -> String
"Invalid argument `" forall a. [a] -> [a] -> [a]
++ String
arg forall a. [a] -> [a] -> [a]
++ String
"'"
ParseError
UnknownError
-> forall a. Monoid a => a
mempty
suggestion_help :: ParserHelp
suggestion_help = Chunk Doc -> ParserHelp
suggestionsHelp forall a b. (a -> b) -> a -> b
$ case ParseError
msg of
UnexpectedError String
arg (SomeParser Parser a
x)
-> Chunk Doc
suggestions
where
suggestions :: Chunk Doc
suggestions = Doc -> Doc -> Doc
(.$.) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chunk Doc
prose
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Doc -> Doc
indent Int
4 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Chunk Doc] -> Chunk Doc
vcatChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Chunk Doc
stringChunk forall a b. (a -> b) -> a -> b
$ [String]
good ))
prose :: Chunk Doc
prose = if forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
good forall a. Ord a => a -> a -> Bool
< Int
2 then
String -> Chunk Doc
stringChunk String
"Did you mean this?"
else
String -> Chunk Doc
stringChunk String
"Did you mean one of these?"
good :: [String]
good = forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isClose [String]
possibles
isClose :: String -> Bool
isClose String
a = forall a. Eq a => [a] -> [a] -> Int
editDistance String
a String
arg forall a. Ord a => a -> a -> Bool
< Int
3
possibles :: [String]
possibles = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall b a.
(forall x. ArgumentReachability -> Option x -> b)
-> Parser a -> [b]
mapParser forall {a}. ArgumentReachability -> Option a -> [String]
opt_completions Parser a
x
opt_completions :: ArgumentReachability -> Option a -> [String]
opt_completions ArgumentReachability
reachability Option a
opt = case forall a. Option a -> OptReader a
optMain Option a
opt of
OptReader [OptName]
ns CReader a
_ String -> ParseError
_ -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OptName -> String
showOption [OptName]
ns
FlagReader [OptName]
ns a
_ -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OptName -> String
showOption [OptName]
ns
ArgReader CReader a
_ -> []
CmdReader Maybe String
_ [String]
ns String -> Maybe (ParserInfo a)
_ | ArgumentReachability -> Bool
argumentIsUnreachable ArgumentReachability
reachability
-> []
| Bool
otherwise
-> [String]
ns
ParseError
_
-> forall a. Monoid a => a
mempty
base_help :: ParserInfo a -> ParserHelp
base_help :: forall a. ParserInfo a -> ParserHelp
base_help ParserInfo a
i
| Bool
show_full_help
= forall a. Monoid a => [a] -> a
mconcat [ParserHelp
h, ParserHelp
f, forall a. ParserPrefs -> Parser a -> ParserHelp
parserHelp ParserPrefs
pprefs (forall a. ParserInfo a -> Parser a
infoParser ParserInfo a
i)]
| Bool
otherwise
= forall a. Monoid a => a
mempty
where
h :: ParserHelp
h = Chunk Doc -> ParserHelp
headerHelp (forall a. ParserInfo a -> Chunk Doc
infoHeader ParserInfo a
i)
f :: ParserHelp
f = Chunk Doc -> ParserHelp
footerHelp (forall a. ParserInfo a -> Chunk Doc
infoFooter ParserInfo a
i)
show_full_help :: Bool
show_full_help = case ParseError
msg of
ShowHelpText {} -> Bool
True
MissingError IsCmdStart
CmdStart SomeParser
_ | ParserPrefs -> Bool
prefShowHelpOnEmpty ParserPrefs
pprefs
-> Bool
True
InfoMsg String
_ -> Bool
False
ParseError
_ -> ParserPrefs -> Bool
prefShowHelpOnError ParserPrefs
pprefs
renderFailure :: ParserFailure ParserHelp -> String -> (String, ExitCode)
renderFailure :: ParserFailure ParserHelp -> String -> (String, ExitCode)
renderFailure ParserFailure ParserHelp
failure String
progn =
let (ParserHelp
h, ExitCode
exit, Int
cols) = forall h. ParserFailure h -> String -> (h, ExitCode, Int)
execFailure ParserFailure ParserHelp
failure String
progn
in (Int -> ParserHelp -> String
renderHelp Int
cols ParserHelp
h, ExitCode
exit)