{-# 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 :: 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 ParserPrefs -> ParserInfo (a, b) -> [String] -> ParserResult (a, b)
forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
execParserPure (PrefsMod -> ParserPrefs
prefs PrefsMod
forall m. Monoid m => m
idm) ParserInfo (a, b)
parser [String]
args of
Failure ParserFailure ParserHelp
_ | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args -> [String] -> IO (a, b) -> IO (a, b)
forall a. [String] -> IO a -> IO a
withArgs [String
"--help"] (ParserInfo (a, b) -> IO (a, b)
forall a. ParserInfo a -> IO a
execParser ParserInfo (a, b)
parser)
ParserResult (a, b)
parseResult -> ParserResult (a, b) -> IO (a, b)
forall a. ParserResult a -> IO a
handleParseResult ParserResult (a, b)
parseResult
where parser :: ParserInfo (a, b)
parser = Parser (a, b) -> InfoMod (a, b) -> ParserInfo (a, b)
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser ((a, b) -> (a, b))
forall a. Parser (a -> a)
versionOption Parser ((a, b) -> (a, b)) -> Parser (a, b) -> Parser (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
-> ExceptT b (Writer (Mod CommandFields b)) () -> Parser (a, 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) InfoMod (a, b)
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
versionOption :: Parser (a -> a)
versionOption =
String -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption
String
versionString
(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")
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 :: String
-> String
-> (a -> b)
-> Parser a
-> ExceptT b (Writer (Mod CommandFields b)) ()
addCommand String
cmd String
title a -> b
constr Parser a
inner =
WriterT (Mod CommandFields b) Identity ()
-> ExceptT b (Writer (Mod CommandFields b)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Mod CommandFields b -> WriterT (Mod CommandFields b) Identity ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (String -> ParserInfo b -> Mod CommandFields b
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
cmd
(Parser b -> InfoMod b -> ParserInfo b
forall a. Parser a -> InfoMod a -> ParserInfo a
info (a -> b
constr (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser (a -> a)
forall a. Parser (a -> a)
helper Parser (a -> a) -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
inner))
(String -> InfoMod b
forall a. String -> InfoMod a
progDesc String
title))))
addSubCommands
:: String
-> String
-> ExceptT b (Writer (Mod CommandFields b)) ()
-> ExceptT b (Writer (Mod CommandFields b)) ()
addSubCommands :: 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 =
String
-> String
-> (((), b) -> b)
-> Parser ((), b)
-> ExceptT b (Writer (Mod CommandFields b)) ()
forall a b.
String
-> String
-> (a -> b)
-> Parser a
-> ExceptT b (Writer (Mod CommandFields b)) ()
addCommand String
cmd
String
title
(\((), b
a) -> b
a)
(Parser ()
-> ExceptT b (Writer (Mod CommandFields b)) () -> Parser ((), b)
forall a b.
Parser a
-> ExceptT b (Writer (Mod CommandFields b)) () -> Parser (a, b)
simpleParser (() -> Parser ()
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 :: Parser a
-> ExceptT b (Writer (Mod CommandFields b)) () -> Parser (a, b)
simpleParser Parser a
commonParser ExceptT b (Writer (Mod CommandFields b)) ()
commandParser =
Parser ((a, b) -> (a, b))
forall a. Parser (a -> a)
helpOption Parser ((a, b) -> (a, b)) -> Parser (a, b) -> Parser (a, b)
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)
ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a.
ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
abortOption (Maybe String -> ParseError
ShowHelpText Maybe String
forall a. Maybe a
Nothing) (Mod OptionFields (a -> a) -> Parser (a -> a))
-> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a b. (a -> b) -> a -> b
$
#else
abortOption ShowHelpText $
#endif
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"
config :: Parser (a, b)
config =
(,) (a -> b -> (a, b)) -> Parser a -> Parser (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
commonParser Parser (b -> (a, b)) -> Parser b -> Parser (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
case Writer (Mod CommandFields b) (Either b ())
-> (Either b (), Mod CommandFields b)
forall w a. Writer w a -> (a, w)
runWriter (ExceptT b (Writer (Mod CommandFields b)) ()
-> Writer (Mod CommandFields b) (Either b ())
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) -> Mod CommandFields b -> Parser b
forall a. Mod CommandFields a -> Parser a
subparser Mod CommandFields b
d
(Left b
b,Mod CommandFields b
_) -> b -> Parser b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b