{-# 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 (giDirty, giHash, tGitInfoCwdTry)
import Language.Haskell.TH (Q,Exp)
import qualified Language.Haskell.TH.Syntax as TH
import Options.Applicative
import System.Environment
simpleOptions
:: String
-> String
-> String
-> Parser a
-> ExceptT b (Writer (Mod CommandFields b)) ()
-> IO (a,b)
simpleOptions versionString h pd globalParser commandParser =
do args <- getArgs
case execParserPure (prefs idm) parser args of
Failure _ | null args -> withArgs ["--help"] (execParser parser)
parseResult -> handleParseResult parseResult
where parser = info (versionOption <*> simpleParser globalParser commandParser) desc
desc = fullDesc <> header h <> progDesc pd
versionOption =
infoOption
versionString
(long "version" <>
help "Show version")
simpleVersion :: Version -> Q Exp
simpleVersion version =
[|concat (["Version "
,$(TH.lift $ showVersion version)
] ++
case giResult of
Left _ -> []
Right gi -> [ ", Git revision "
, giHash gi
, if giDirty gi then " (dirty)" else ""
]
)|]
where
giResult = $$tGitInfoCwdTry
addCommand :: String
-> String
-> (a -> b)
-> Parser a
-> ExceptT b (Writer (Mod CommandFields b)) ()
addCommand cmd title constr inner =
lift (tell (command cmd
(info (constr <$> (helper <*> inner))
(progDesc title))))
addSubCommands
:: String
-> String
-> ExceptT b (Writer (Mod CommandFields b)) ()
-> ExceptT b (Writer (Mod CommandFields b)) ()
addSubCommands cmd title commandParser =
addCommand cmd
title
(\((), a) -> a)
(simpleParser (pure ()) commandParser)
simpleParser
:: Parser a
-> ExceptT b (Writer (Mod CommandFields b)) ()
-> Parser (a,b)
simpleParser commonParser commandParser =
helpOption <*> config
where helpOption =
abortOption ShowHelpText $
long "help" <>
help "Show this help text"
config =
(,) <$> commonParser <*>
case runWriter (runExceptT commandParser) of
(Right (),d) -> subparser d
(Left b,_) -> pure b