{-# LANGUAGE NoImplicitPrelude #-}
module Options.Applicative.Complicated
( addCommand
, addSubCommands
, complicatedOptions
, complicatedParser
) where
import Control.Monad.Trans.Except
import Control.Monad.Trans.Writer
import Options.Applicative
import Options.Applicative.Types
import Options.Applicative.Builder.Extra
import Options.Applicative.Builder.Internal
import Stack.Prelude
import System.Environment
complicatedOptions
:: Monoid a
=> Version
-> Maybe String
-> String
-> String
-> String
-> String
-> Parser a
-> Maybe (ParserFailure ParserHelp -> [String] -> IO (a,(b,a)))
-> ExceptT b (Writer (Mod CommandFields (b,a))) ()
-> IO (a,b)
complicatedOptions :: Version
-> Maybe String
-> String
-> String
-> String
-> String
-> Parser a
-> Maybe (ParserFailure ParserHelp -> [String] -> IO (a, (b, a)))
-> ExceptT b (Writer (Mod CommandFields (b, a))) ()
-> IO (a, b)
complicatedOptions Version
numericVersion Maybe String
stringVersion String
numericHpackVersion String
h String
pd String
footerStr Parser a
commonParser Maybe (ParserFailure ParserHelp -> [String] -> IO (a, (b, a)))
mOnFailure ExceptT b (Writer (Mod CommandFields (b, a))) ()
commandParser =
do [String]
args <- IO [String]
getArgs
(a
a,(b
b,a
c)) <- case ParserPrefs
-> ParserInfo (a, (b, a)) -> [String] -> ParserResult (a, (b, a))
forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
execParserPure (PrefsMod -> ParserPrefs
prefs PrefsMod
noBacktrack) ParserInfo (a, (b, a))
parser [String]
args of
Failure ParserFailure ParserHelp
_ | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args -> [String] -> IO (a, (b, a)) -> IO (a, (b, a))
forall a. [String] -> IO a -> IO a
withArgs [String
"--help"] (ParserInfo (a, (b, a)) -> IO (a, (b, a))
forall a. ParserInfo a -> IO a
execParser ParserInfo (a, (b, a))
parser)
Failure ParserFailure ParserHelp
f | Just ParserFailure ParserHelp -> [String] -> IO (a, (b, a))
onFailure <- Maybe (ParserFailure ParserHelp -> [String] -> IO (a, (b, a)))
mOnFailure -> ParserFailure ParserHelp -> [String] -> IO (a, (b, a))
onFailure ParserFailure ParserHelp
f [String]
args
ParserResult (a, (b, a))
parseResult -> ParserResult (a, (b, a)) -> IO (a, (b, a))
forall a. ParserResult a -> IO a
handleParseResult ParserResult (a, (b, a))
parseResult
(a, b) -> IO (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
c a
a,b
b)
where parser :: ParserInfo (a, (b, a))
parser = Parser (a, (b, a)) -> InfoMod (a, (b, a)) -> ParserInfo (a, (b, a))
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser (((a, (b, a)) -> (a, (b, a))) -> (a, (b, a)) -> (a, (b, a)))
forall a. Parser (a -> a)
helpOption Parser (((a, (b, a)) -> (a, (b, a))) -> (a, (b, a)) -> (a, (b, a)))
-> Parser ((a, (b, a)) -> (a, (b, a)))
-> Parser ((a, (b, a)) -> (a, (b, a)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ((a, (b, a)) -> (a, (b, a)))
forall a. Parser (a -> a)
versionOptions Parser ((a, (b, a)) -> (a, (b, a)))
-> Parser (a, (b, a)) -> Parser (a, (b, a))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, a))) ()
-> Parser (a, (b, a))
forall a b.
Monoid a =>
String
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, a))) ()
-> Parser (a, (b, a))
complicatedParser String
"COMMAND|FILE" Parser a
commonParser ExceptT b (Writer (Mod CommandFields (b, a))) ()
commandParser) InfoMod (a, (b, a))
forall a. InfoMod a
desc
desc :: InfoMod a
desc = InfoMod a
forall a. InfoMod a
fullDesc InfoMod a -> InfoMod a -> InfoMod a
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod a
forall a. String -> InfoMod a
header String
h InfoMod a -> InfoMod a -> InfoMod a
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod a
forall a. String -> InfoMod a
progDesc String
pd InfoMod a -> InfoMod a -> InfoMod a
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod a
forall a. String -> InfoMod a
footer String
footerStr
versionOptions :: Parser (a -> a)
versionOptions =
case Maybe String
stringVersion of
Maybe String
Nothing -> String -> Parser (a -> a)
forall a. String -> Parser (a -> a)
versionOption (Version -> String
versionString Version
numericVersion)
Just String
s -> String -> Parser (((a -> a) -> a -> a) -> (a -> a) -> a -> a)
forall a. String -> Parser (a -> a)
versionOption String
s Parser (((a -> a) -> a -> a) -> (a -> a) -> a -> a)
-> Parser ((a -> a) -> a -> a) -> Parser ((a -> a) -> a -> a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ((a -> a) -> a -> a)
forall a. Parser (a -> a)
numericVersionOption Parser ((a -> a) -> a -> a) -> Parser (a -> a) -> Parser (a -> a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (a -> a)
forall a. Parser (a -> a)
numericHpackVersionOption
versionOption :: String -> Parser (a -> a)
versionOption String
s =
String -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption
String
s
(String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"version" Mod OptionFields (a -> a)
-> Mod OptionFields (a -> a) -> Mod OptionFields (a -> a)
forall a. Semigroup a => a -> a -> a
<>
String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. String -> Mod f a
help String
"Show version")
numericVersionOption :: Parser (a -> a)
numericVersionOption =
String -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption
(Version -> String
versionString Version
numericVersion)
(String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"numeric-version" Mod OptionFields (a -> a)
-> Mod OptionFields (a -> a) -> Mod OptionFields (a -> a)
forall a. Semigroup a => a -> a -> a
<>
String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. String -> Mod f a
help String
"Show only version number")
numericHpackVersionOption :: Parser (a -> a)
numericHpackVersionOption =
String -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption
String
numericHpackVersion
(String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"hpack-numeric-version" Mod OptionFields (a -> a)
-> Mod OptionFields (a -> a) -> Mod OptionFields (a -> a)
forall a. Semigroup a => a -> a -> a
<>
String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. String -> Mod f a
help String
"Show only hpack's version number")
addCommand :: String
-> String
-> String
-> (a -> b)
-> (a -> c -> c)
-> Parser c
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b,c))) ()
addCommand :: String
-> String
-> String
-> (a -> b)
-> (a -> c -> c)
-> Parser c
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
addCommand String
cmd String
title String
footerStr a -> b
constr a -> c -> c
extendCommon =
String
-> String
-> String
-> (a -> c -> (b, c))
-> Parser c
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
forall a c b.
String
-> String
-> String
-> (a -> c -> (b, c))
-> Parser c
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
addCommand' String
cmd String
title String
footerStr (\a
a c
c -> (a -> b
constr a
a,a -> c -> c
extendCommon a
a c
c))
addSubCommands
:: Monoid c
=> String
-> String
-> String
-> Parser c
-> ExceptT b (Writer (Mod CommandFields (b,c))) ()
-> ExceptT b (Writer (Mod CommandFields (b,c))) ()
addSubCommands :: String
-> String
-> String
-> Parser c
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
addSubCommands String
cmd String
title String
footerStr Parser c
commonParser ExceptT b (Writer (Mod CommandFields (b, c))) ()
commandParser =
String
-> String
-> String
-> ((c, (b, c)) -> c -> (b, c))
-> Parser c
-> Parser (c, (b, c))
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
forall a c b.
String
-> String
-> String
-> (a -> c -> (b, c))
-> Parser c
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
addCommand' String
cmd
String
title
String
footerStr
(\(c
c1,(b
a,c
c2)) c
c3 -> (b
a,[c] -> c
forall a. Monoid a => [a] -> a
mconcat [c
c3, c
c2, c
c1]))
Parser c
commonParser
(String
-> Parser c
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
-> Parser (c, (b, c))
forall a b.
Monoid a =>
String
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, a))) ()
-> Parser (a, (b, a))
complicatedParser String
"COMMAND" Parser c
commonParser ExceptT b (Writer (Mod CommandFields (b, c))) ()
commandParser)
addCommand' :: String
-> String
-> String
-> (a -> c -> (b,c))
-> Parser c
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b,c))) ()
addCommand' :: String
-> String
-> String
-> (a -> c -> (b, c))
-> Parser c
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
addCommand' String
cmd String
title String
footerStr a -> c -> (b, c)
constr Parser c
commonParser Parser a
inner =
WriterT (Mod CommandFields (b, c)) Identity ()
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Mod CommandFields (b, c)
-> WriterT (Mod CommandFields (b, c)) Identity ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (String -> ParserInfo (b, c) -> Mod CommandFields (b, c)
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
cmd
(Parser (b, c) -> InfoMod (b, c) -> ParserInfo (b, c)
forall a. Parser a -> InfoMod a -> ParserInfo a
info (a -> c -> (b, c)
constr (a -> c -> (b, c)) -> Parser a -> Parser (c -> (b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
inner Parser (c -> (b, c)) -> Parser c -> Parser (b, c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser c
commonParser)
(String -> InfoMod (b, c)
forall a. String -> InfoMod a
progDesc String
title InfoMod (b, c) -> InfoMod (b, c) -> InfoMod (b, c)
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod (b, c)
forall a. String -> InfoMod a
footer String
footerStr))))
complicatedParser
:: Monoid a
=> String
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b,a))) ()
-> Parser (a,(b,a))
complicatedParser :: String
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, a))) ()
-> Parser (a, (b, a))
complicatedParser String
commandMetavar Parser a
commonParser ExceptT b (Writer (Mod CommandFields (b, a))) ()
commandParser =
(,) (a -> (b, a) -> (a, (b, a)))
-> Parser a -> Parser ((b, a) -> (a, (b, a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Parser a
commonParser Parser ((b, a) -> (a, (b, a)))
-> Parser (b, a) -> Parser (a, (b, a))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
case Writer (Mod CommandFields (b, a)) (Either b ())
-> (Either b (), Mod CommandFields (b, a))
forall w a. Writer w a -> (a, w)
runWriter (ExceptT b (Writer (Mod CommandFields (b, a))) ()
-> Writer (Mod CommandFields (b, a)) (Either b ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT b (Writer (Mod CommandFields (b, a))) ()
commandParser) of
(Right (),Mod CommandFields (b, a)
d) -> String -> Mod CommandFields (b, a) -> Parser (b, a)
forall a. String -> Mod CommandFields a -> Parser a
hsubparser' String
commandMetavar Mod CommandFields (b, a)
d
(Left b
b,Mod CommandFields (b, a)
_) -> (b, a) -> Parser (b, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
b,a
forall a. Monoid a => a
mempty)
hsubparser' :: String -> Mod CommandFields a -> Parser a
hsubparser' :: String -> Mod CommandFields a -> Parser a
hsubparser' String
commandMetavar Mod CommandFields a
m = DefaultProp a
-> (OptProperties -> OptProperties) -> OptReader a -> Parser a
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 = String -> Mod CommandFields a
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
commandMetavar Mod CommandFields a -> Mod CommandFields a -> Mod CommandFields a
forall a. Monoid a => a -> a -> a
`mappend` Mod CommandFields a
m
(Maybe String
groupName, [String]
cmds, String -> Maybe (ParserInfo a)
subs) = Mod CommandFields a
-> (Maybe String, [String], String -> Maybe (ParserInfo a))
forall a.
Mod CommandFields a
-> (Maybe String, [String], String -> Maybe (ParserInfo a))
mkCommand Mod CommandFields a
m
rdr :: OptReader a
rdr = Maybe String
-> [String] -> (String -> Maybe (ParserInfo a)) -> OptReader a
forall a.
Maybe String
-> [String] -> (String -> Maybe (ParserInfo a)) -> OptReader a
CmdReader Maybe String
groupName [String]
cmds ((ParserInfo a -> ParserInfo a)
-> Maybe (ParserInfo a) -> Maybe (ParserInfo a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParserInfo a -> ParserInfo a
forall a. ParserInfo a -> ParserInfo a
add_helper (Maybe (ParserInfo a) -> Maybe (ParserInfo a))
-> (String -> Maybe (ParserInfo a))
-> String
-> Maybe (ParserInfo a)
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 = ParserInfo a -> Parser a
forall a. ParserInfo a -> Parser a
infoParser ParserInfo a
pinfo Parser a -> Parser (a -> a) -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (a -> a)
forall a. Parser (a -> a)
helpOption }
helpOption :: Parser (a -> a)
helpOption :: Parser (a -> a)
helpOption =
ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a.
ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
abortOption ParseError
showHelpText (Mod OptionFields (a -> a) -> Parser (a -> a))
-> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a b. (a -> b) -> a -> b
$
String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"help" Mod OptionFields (a -> a)
-> Mod OptionFields (a -> a) -> Mod OptionFields (a -> a)
forall a. Semigroup a => a -> a -> a
<>
String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. String -> Mod f a
help String
"Show this help text"