module Options.Applicative.Complicated
( addCommand
, addSubCommands
, complicatedOptions
, complicatedParser
) where
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Either
import Control.Monad.Trans.Writer
import Data.Monoid
import Data.Version
import Options.Applicative
import Options.Applicative.Types
import Options.Applicative.Builder.Internal
import System.Environment
complicatedOptions
:: Monoid a
=> Version
-> Maybe String
-> String
-> String
-> Parser a
-> Maybe (ParserFailure ParserHelp -> [String] -> IO (a,(b,a)))
-> EitherT b (Writer (Mod CommandFields (b,a))) ()
-> IO (a,b)
complicatedOptions numericVersion versionString h pd commonParser mOnFailure commandParser =
do args <- getArgs
(a,(b,c)) <- case execParserPure (prefs noBacktrack) parser args of
Failure _ | null args -> withArgs ["--help"] (execParser parser)
Failure f | Just onFailure <- mOnFailure -> onFailure f args
parseResult -> handleParseResult parseResult
return (mappend c a,b)
where parser = info (helpOption <*> versionOptions <*> complicatedParser commonParser commandParser) desc
desc = fullDesc <> header h <> progDesc pd
versionOptions =
case versionString of
Nothing -> versionOption (showVersion numericVersion)
Just s -> versionOption s <*> numericVersionOption
versionOption s =
infoOption
s
(long "version" <>
help "Show version")
numericVersionOption =
infoOption
(showVersion numericVersion)
(long "numeric-version" <>
help "Show only version number")
addCommand :: String
-> String
-> String
-> (a -> b)
-> Parser c
-> Parser a
-> EitherT b (Writer (Mod CommandFields (b,c))) ()
addCommand cmd title footerStr constr =
addCommand' cmd title footerStr (\a c -> (constr a,c))
addSubCommands
:: Monoid c
=> String
-> String
-> String
-> Parser c
-> EitherT b (Writer (Mod CommandFields (b,c))) ()
-> EitherT b (Writer (Mod CommandFields (b,c))) ()
addSubCommands cmd title footerStr commonParser commandParser =
addCommand' cmd
title
footerStr
(\(c1,(a,c2)) c3 -> (a,mconcat [c3, c2, c1]))
commonParser
(complicatedParser commonParser commandParser)
addCommand' :: String
-> String
-> String
-> (a -> c -> (b,c))
-> Parser c
-> Parser a
-> EitherT b (Writer (Mod CommandFields (b,c))) ()
addCommand' cmd title footerStr constr commonParser inner =
lift (tell (command cmd
(info (constr <$> inner <*> commonParser)
(progDesc title <> footer footerStr))))
complicatedParser
:: Monoid a
=> Parser a
-> EitherT b (Writer (Mod CommandFields (b,a))) ()
-> Parser (a,(b,a))
complicatedParser commonParser commandParser =
(,) <$>
commonParser <*>
case runWriter (runEitherT commandParser) of
(Right (),d) -> hsubparser' d
(Left b,_) -> pure (b,mempty)
hsubparser' :: Mod CommandFields a -> Parser a
hsubparser' m = mkParser d g rdr
where
Mod _ d g = m `mappend` metavar "COMMAND"
(cmds, subs) = mkCommand m
rdr = CmdReader cmds (fmap add_helper . subs)
add_helper pinfo = pinfo
{ infoParser = infoParser pinfo <**> helpOption }
helpOption :: Parser (a -> a)
helpOption =
abortOption ShowHelpText $
long "help" <>
help "Show this help text"