-- Try to ensure that https://github.com/fpco/optparse-simple/issues/12 doesn't recur.
{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}

-- | Simple interface to program arguments.
--
-- Typical usage with no commands:
--
-- @
-- do (opts,()) <-
--      simpleOptions "ver"
--                    "header"
--                    "desc"
--                    (flag () () (long "some-flag"))
--                    empty
--    doThings opts
-- @
--
-- Typical usage with commands:
--
-- @
-- do (opts,runCmd) <-
--      simpleOptions "ver"
--                    "header"
--                    "desc"
--                    (pure ()) $
--      do addCommand "delete"
--                    "Delete the thing"
--                    (const deleteTheThing)
--                    (pure ())
--         addCommand "create"
--                    "Create a thing"
--                    createAThing
--                    (strOption (long "hello"))
--    runCmd
-- @

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

-- | Generate and execute a simple options parser.
simpleOptions
  :: String
  -- ^ version string
  -> String
  -- ^ header
  -> String
  -- ^ program description
  -> Parser a
  -- ^ global settings
  -> ExceptT b (Writer (Mod CommandFields b)) ()
  -- ^ commands (use 'addCommand')
  -> 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")

-- | Generate a string like @Version 1.2, Git revision 1234@.
--
-- @$(simpleVersion …)@ @::@ 'String'
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 ""
                         ]
           )|]

-- | Add a command to the options dispatcher.
addCommand :: String   -- ^ command string
           -> String   -- ^ title of command
           -> (a -> b) -- ^ constructor to wrap up command in common data type
           -> Parser a -- ^ command parser
           -> 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))))

-- | Add a command that takes sub-commands to the options dispatcher.
--
-- Example:
--
-- @
-- addSubCommands "thing"
--                "Subcommands that operate on things"
--                (do addCommand "delete"
--                               "Delete the thing"
--                               (const deleteTheThing)
--                               (pure ())
--                    addCommand "create"
--                               "Create a thing"
--                               createAThing
--                               (strOption (long "hello")))
-- @
--
-- If there are common options between all the sub-commands, use 'addCommand'
-- in combination with 'simpleParser' instead of 'addSubCommands'.
addSubCommands
  :: String
  -- ^ command string
  -> String
  -- ^ title of command
  -> ExceptT b (Writer (Mod CommandFields b)) ()
  -- ^ sub-commands (use 'addCommand')
  -> 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)

-- | Generate a simple options parser.
--
-- Most of the time you should use 'simpleOptions' instead, but 'simpleParser'
-- can be used for sub-commands that need common options.  For example:
--
-- @
-- addCommand "thing"
--            "Subcommands that operate on things"
--            (\\(opts,runSubCmd) -> runSubCmd opts)
--            (simpleParser (flag () () (long "some-flag")) $
--             do addCommand "delete"
--                           "Delete the thing"
--                           (const deleteTheThing)
--                           (pure ())
--                addCommand "create"
--                           "Create a thing"
--                           createAThing
--                           (strOption (long "hello")))
-- @
--
simpleParser
  :: Parser a
  -- ^ common settings
  -> ExceptT b (Writer (Mod CommandFields b)) ()
  -- ^ commands (use 'addCommand')
  -> 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