{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
module Options.Applicative.Simple
( module Options.Applicative.Simple
, module Options.Applicative
) where
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except
import Control.Monad.Trans.Writer
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#endif
import Data.Version
import GitHash (GitInfo, giDirty, giHash, tGitInfoCwdTry)
import Language.Haskell.TH (Q,Exp)
import qualified Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH.Syntax.Compat
import Options.Applicative
import System.Environment
simpleOptions
:: String
-> String
-> String
-> Parser a
-> ExceptT b (Writer (Mod CommandFields b)) ()
-> IO (a,b)
simpleOptions :: forall a b.
String
-> String
-> String
-> Parser a
-> ExceptT b (Writer (Mod CommandFields b)) ()
-> IO (a, b)
simpleOptions String
versionString String
h String
pd Parser a
globalParser ExceptT b (Writer (Mod CommandFields b)) ()
commandParser =
do [String]
args <- IO [String]
getArgs
case forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
execParserPure (PrefsMod -> ParserPrefs
prefs forall m. Monoid m => m
idm) ParserInfo (a, b)
parser [String]
args of
Failure ParserFailure ParserHelp
_ | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args -> forall a. [String] -> IO a -> IO a
withArgs [String
"--help"] (forall a. ParserInfo a -> IO a
execParser ParserInfo (a, b)
parser)
ParserResult (a, b)
parseResult -> forall a. ParserResult a -> IO a
handleParseResult ParserResult (a, b)
parseResult
where parser :: ParserInfo (a, b)
parser = forall a. Parser a -> InfoMod a -> ParserInfo a
info (forall {a}. Parser (a -> a)
versionOption forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a b.
Parser a
-> ExceptT b (Writer (Mod CommandFields b)) () -> Parser (a, b)
simpleParser Parser a
globalParser ExceptT b (Writer (Mod CommandFields b)) ()
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
versionOption :: Parser (a -> a)
versionOption =
forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption
String
versionString
(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")
simpleVersion :: Version -> Q Exp
simpleVersion :: Version -> Q Exp
simpleVersion Version
version =
[|concat (["Version "
,$(TH.lift $ showVersion version)
] ++
case $(unTypeSplice tGitInfoCwdTry) :: Either String GitInfo of
Left _ -> []
Right gi -> [ ", Git revision "
, giHash gi
, if giDirty gi then " (dirty)" else ""
]
)|]
addCommand :: String
-> String
-> (a -> b)
-> Parser a
-> ExceptT b (Writer (Mod CommandFields b)) ()
addCommand :: forall a b.
String
-> String
-> (a -> b)
-> Parser a
-> ExceptT b (Writer (Mod CommandFields b)) ()
addCommand String
cmd String
title a -> b
constr Parser a
inner =
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (forall a. String -> ParserInfo a -> Mod CommandFields a
command String
cmd
(forall a. Parser a -> InfoMod a -> ParserInfo a
info (a -> b
constr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall {a}. Parser (a -> a)
helper forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
inner))
(forall a. String -> InfoMod a
progDesc String
title))))
addSubCommands
:: String
-> String
-> ExceptT b (Writer (Mod CommandFields b)) ()
-> ExceptT b (Writer (Mod CommandFields b)) ()
addSubCommands :: forall b.
String
-> String
-> ExceptT b (Writer (Mod CommandFields b)) ()
-> ExceptT b (Writer (Mod CommandFields b)) ()
addSubCommands String
cmd String
title ExceptT b (Writer (Mod CommandFields b)) ()
commandParser =
forall a b.
String
-> String
-> (a -> b)
-> Parser a
-> ExceptT b (Writer (Mod CommandFields b)) ()
addCommand String
cmd
String
title
(\((), b
a) -> b
a)
(forall a b.
Parser a
-> ExceptT b (Writer (Mod CommandFields b)) () -> Parser (a, b)
simpleParser (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ExceptT b (Writer (Mod CommandFields b)) ()
commandParser)
simpleParser
:: Parser a
-> ExceptT b (Writer (Mod CommandFields b)) ()
-> Parser (a,b)
simpleParser :: forall a b.
Parser a
-> ExceptT b (Writer (Mod CommandFields b)) () -> Parser (a, b)
simpleParser Parser a
commonParser ExceptT b (Writer (Mod CommandFields b)) ()
commandParser =
forall {a}. Parser (a -> a)
helpOption forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (a, b)
config
where helpOption :: Parser (a -> a)
helpOption =
#if MIN_VERSION_optparse_applicative(0,16,0)
forall a.
ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
abortOption (Maybe String -> ParseError
ShowHelpText forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$
#else
abortOption ShowHelpText $
#endif
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"
config :: Parser (a, b)
config =
(,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
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 ExceptT b (Writer (Mod CommandFields b)) ()
commandParser) of
(Right (),Mod CommandFields b
d) -> forall a. Mod CommandFields a -> Parser a
subparser Mod CommandFields b
d
(Left b
b,Mod CommandFields b
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b