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