{-# LANGUAGE NoImplicitPrelude #-}
-- | Simple interface to complicated program arguments.
--
-- This is a "fork" of the @optparse-simple@ package that has some workarounds for
-- optparse-applicative issues that become problematic with programs that have many options and
-- subcommands. Because it makes the interface more complex, these workarounds are not suitable for
-- pushing upstream to optparse-applicative.

module Options.Applicative.Complicated
  ( addCommand
  , addSubCommands
  , complicatedOptions
  , complicatedParser
  ) where

import           Control.Monad.Trans.Except
import           Control.Monad.Trans.Writer
import           Options.Applicative
import           Options.Applicative.Types
import           Options.Applicative.Builder.Extra
import           Options.Applicative.Builder.Internal
import           Stack.Prelude
import           System.Environment

-- | Generate and execute a complicated options parser.
complicatedOptions
  :: Monoid a
  => Version
  -- ^ numeric version
  -> Maybe String
  -- ^ version string
  -> String
  -- ^ hpack numeric version, as string
  -> String
  -- ^ header
  -> String
  -- ^ program description (displayed between usage and options listing in the help output)
  -> String
  -- ^ footer
  -> Parser a
  -- ^ common settings
  -> Maybe (ParserFailure ParserHelp -> [String] -> IO (a,(b,a)))
  -- ^ optional handler for parser failure; 'handleParseResult' is called by
  -- default
  -> ExceptT b (Writer (Mod CommandFields (b,a))) ()
  -- ^ commands (use 'addCommand')
  -> IO (a,b)
complicatedOptions :: Version
-> Maybe String
-> String
-> String
-> String
-> String
-> Parser a
-> Maybe (ParserFailure ParserHelp -> [String] -> IO (a, (b, a)))
-> ExceptT b (Writer (Mod CommandFields (b, a))) ()
-> IO (a, b)
complicatedOptions Version
numericVersion Maybe String
stringVersion String
numericHpackVersion String
h String
pd String
footerStr Parser a
commonParser Maybe (ParserFailure ParserHelp -> [String] -> IO (a, (b, a)))
mOnFailure ExceptT b (Writer (Mod CommandFields (b, a))) ()
commandParser =
  do [String]
args <- IO [String]
getArgs
     (a
a,(b
b,a
c)) <- case ParserPrefs
-> ParserInfo (a, (b, a)) -> [String] -> ParserResult (a, (b, a))
forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
execParserPure (PrefsMod -> ParserPrefs
prefs PrefsMod
noBacktrack) ParserInfo (a, (b, a))
parser [String]
args of
       Failure ParserFailure ParserHelp
_ | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args -> [String] -> IO (a, (b, a)) -> IO (a, (b, a))
forall a. [String] -> IO a -> IO a
withArgs [String
"--help"] (ParserInfo (a, (b, a)) -> IO (a, (b, a))
forall a. ParserInfo a -> IO a
execParser ParserInfo (a, (b, a))
parser)
       -- call onFailure handler if it's present and parsing options failed
       Failure ParserFailure ParserHelp
f | Just ParserFailure ParserHelp -> [String] -> IO (a, (b, a))
onFailure <- Maybe (ParserFailure ParserHelp -> [String] -> IO (a, (b, a)))
mOnFailure -> ParserFailure ParserHelp -> [String] -> IO (a, (b, a))
onFailure ParserFailure ParserHelp
f [String]
args
       ParserResult (a, (b, a))
parseResult -> ParserResult (a, (b, a)) -> IO (a, (b, a))
forall a. ParserResult a -> IO a
handleParseResult ParserResult (a, (b, a))
parseResult
     (a, b) -> IO (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
c a
a,b
b)
  where parser :: ParserInfo (a, (b, a))
parser = Parser (a, (b, a)) -> InfoMod (a, (b, a)) -> ParserInfo (a, (b, a))
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser (((a, (b, a)) -> (a, (b, a))) -> (a, (b, a)) -> (a, (b, a)))
forall a. Parser (a -> a)
helpOption Parser (((a, (b, a)) -> (a, (b, a))) -> (a, (b, a)) -> (a, (b, a)))
-> Parser ((a, (b, a)) -> (a, (b, a)))
-> Parser ((a, (b, a)) -> (a, (b, a)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ((a, (b, a)) -> (a, (b, a)))
forall a. Parser (a -> a)
versionOptions Parser ((a, (b, a)) -> (a, (b, a)))
-> Parser (a, (b, a)) -> Parser (a, (b, a))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, a))) ()
-> Parser (a, (b, a))
forall a b.
Monoid a =>
String
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, a))) ()
-> Parser (a, (b, a))
complicatedParser String
"COMMAND|FILE" Parser a
commonParser ExceptT b (Writer (Mod CommandFields (b, a))) ()
commandParser) InfoMod (a, (b, a))
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 InfoMod a -> InfoMod a -> InfoMod a
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod a
forall a. String -> InfoMod a
footer String
footerStr
        versionOptions :: Parser (a -> a)
versionOptions =
          case Maybe String
stringVersion of
            Maybe String
Nothing -> String -> Parser (a -> a)
forall a. String -> Parser (a -> a)
versionOption (Version -> String
versionString Version
numericVersion)
            Just String
s -> String -> Parser (((a -> a) -> a -> a) -> (a -> a) -> a -> a)
forall a. String -> Parser (a -> a)
versionOption String
s Parser (((a -> a) -> a -> a) -> (a -> a) -> a -> a)
-> Parser ((a -> a) -> a -> a) -> Parser ((a -> a) -> a -> a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ((a -> a) -> a -> a)
forall a. Parser (a -> a)
numericVersionOption Parser ((a -> a) -> a -> a) -> Parser (a -> a) -> Parser (a -> a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (a -> a)
forall a. Parser (a -> a)
numericHpackVersionOption
        versionOption :: String -> Parser (a -> a)
versionOption String
s =
          String -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption
            String
s
            (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")
        numericVersionOption :: Parser (a -> a)
numericVersionOption =
          String -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption
            (Version -> String
versionString Version
numericVersion)
            (String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"numeric-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 only version number")
        numericHpackVersionOption :: Parser (a -> a)
numericHpackVersionOption =
          String -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption
            String
numericHpackVersion
            (String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"hpack-numeric-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 only hpack's version number")

-- | Add a command to the options dispatcher.
addCommand :: String   -- ^ command string
           -> String   -- ^ title of command
           -> String   -- ^ footer of command help
           -> (a -> b) -- ^ constructor to wrap up command in common data type
           -> (a -> c -> c) -- ^ extend common settings from local settings
           -> Parser c -- ^ common parser
           -> Parser a -- ^ command parser
           -> ExceptT b (Writer (Mod CommandFields (b,c))) ()
addCommand :: String
-> String
-> String
-> (a -> b)
-> (a -> c -> c)
-> Parser c
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
addCommand String
cmd String
title String
footerStr a -> b
constr a -> c -> c
extendCommon =
  String
-> String
-> String
-> (a -> c -> (b, c))
-> Parser c
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
forall a c b.
String
-> String
-> String
-> (a -> c -> (b, c))
-> Parser c
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
addCommand' String
cmd String
title String
footerStr (\a
a c
c -> (a -> b
constr a
a,a -> c -> c
extendCommon a
a c
c))

-- | Add a command that takes sub-commands to the options dispatcher.
addSubCommands
  :: Monoid c
  => String
  -- ^ command string
  -> String
  -- ^ title of command
  -> String
  -- ^ footer of command help
  -> Parser c
  -- ^ common parser
  -> ExceptT b (Writer (Mod CommandFields (b,c))) ()
  -- ^ sub-commands (use 'addCommand')
  -> ExceptT b (Writer (Mod CommandFields (b,c))) ()
addSubCommands :: String
-> String
-> String
-> Parser c
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
addSubCommands String
cmd String
title String
footerStr Parser c
commonParser ExceptT b (Writer (Mod CommandFields (b, c))) ()
commandParser =
  String
-> String
-> String
-> ((c, (b, c)) -> c -> (b, c))
-> Parser c
-> Parser (c, (b, c))
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
forall a c b.
String
-> String
-> String
-> (a -> c -> (b, c))
-> Parser c
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
addCommand' String
cmd
              String
title
              String
footerStr
              (\(c
c1,(b
a,c
c2)) c
c3 -> (b
a,[c] -> c
forall a. Monoid a => [a] -> a
mconcat [c
c3, c
c2, c
c1]))
              Parser c
commonParser
              (String
-> Parser c
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
-> Parser (c, (b, c))
forall a b.
Monoid a =>
String
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, a))) ()
-> Parser (a, (b, a))
complicatedParser String
"COMMAND" Parser c
commonParser ExceptT b (Writer (Mod CommandFields (b, c))) ()
commandParser)

-- | Add a command to the options dispatcher.
addCommand' :: String   -- ^ command string
            -> String   -- ^ title of command
            -> String   -- ^ footer of command help
            -> (a -> c -> (b,c)) -- ^ constructor to wrap up command in common data type
            -> Parser c -- ^ common parser
            -> Parser a -- ^ command parser
            -> ExceptT b (Writer (Mod CommandFields (b,c))) ()
addCommand' :: String
-> String
-> String
-> (a -> c -> (b, c))
-> Parser c
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
addCommand' String
cmd String
title String
footerStr a -> c -> (b, c)
constr Parser c
commonParser Parser a
inner =
  WriterT (Mod CommandFields (b, c)) Identity ()
-> ExceptT b (Writer (Mod CommandFields (b, c))) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Mod CommandFields (b, c)
-> WriterT (Mod CommandFields (b, c)) Identity ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (String -> ParserInfo (b, c) -> Mod CommandFields (b, c)
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
cmd
                      (Parser (b, c) -> InfoMod (b, c) -> ParserInfo (b, c)
forall a. Parser a -> InfoMod a -> ParserInfo a
info (a -> c -> (b, c)
constr (a -> c -> (b, c)) -> Parser a -> Parser (c -> (b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
inner Parser (c -> (b, c)) -> Parser c -> Parser (b, c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser c
commonParser)
                            (String -> InfoMod (b, c)
forall a. String -> InfoMod a
progDesc String
title InfoMod (b, c) -> InfoMod (b, c) -> InfoMod (b, c)
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod (b, c)
forall a. String -> InfoMod a
footer String
footerStr))))

-- | Generate a complicated options parser.
complicatedParser
  :: Monoid a
  => String
  -- ^ metavar for the sub-command
  -> Parser a
  -- ^ common settings
  -> ExceptT b (Writer (Mod CommandFields (b,a))) ()
  -- ^ commands (use 'addCommand')
  -> Parser (a,(b,a))
complicatedParser :: String
-> Parser a
-> ExceptT b (Writer (Mod CommandFields (b, a))) ()
-> Parser (a, (b, a))
complicatedParser String
commandMetavar Parser a
commonParser ExceptT b (Writer (Mod CommandFields (b, a))) ()
commandParser =
   (,) (a -> (b, a) -> (a, (b, a)))
-> Parser a -> Parser ((b, a) -> (a, (b, a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
   Parser a
commonParser Parser ((b, a) -> (a, (b, a)))
-> Parser (b, a) -> Parser (a, (b, a))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
   case Writer (Mod CommandFields (b, a)) (Either b ())
-> (Either b (), Mod CommandFields (b, a))
forall w a. Writer w a -> (a, w)
runWriter (ExceptT b (Writer (Mod CommandFields (b, a))) ()
-> Writer (Mod CommandFields (b, a)) (Either b ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT b (Writer (Mod CommandFields (b, a))) ()
commandParser) of
     (Right (),Mod CommandFields (b, a)
d) -> String -> Mod CommandFields (b, a) -> Parser (b, a)
forall a. String -> Mod CommandFields a -> Parser a
hsubparser' String
commandMetavar Mod CommandFields (b, a)
d
     (Left b
b,Mod CommandFields (b, a)
_) -> (b, a) -> Parser (b, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
b,a
forall a. Monoid a => a
mempty)

-- | Subparser with @--help@ argument. Borrowed with slight modification
-- from Options.Applicative.Extra.
hsubparser' :: String -> Mod CommandFields a -> Parser a
hsubparser' :: String -> Mod CommandFields a -> Parser a
hsubparser' String
commandMetavar Mod CommandFields a
m = DefaultProp a
-> (OptProperties -> OptProperties) -> OptReader a -> Parser a
forall a.
DefaultProp a
-> (OptProperties -> OptProperties) -> OptReader a -> Parser a
mkParser DefaultProp a
d OptProperties -> OptProperties
g OptReader a
rdr
  where
    Mod CommandFields a -> CommandFields a
_ DefaultProp a
d OptProperties -> OptProperties
g = String -> Mod CommandFields a
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
commandMetavar Mod CommandFields a -> Mod CommandFields a -> Mod CommandFields a
forall a. Monoid a => a -> a -> a
`mappend` Mod CommandFields a
m
    (Maybe String
groupName, [String]
cmds, String -> Maybe (ParserInfo a)
subs) = Mod CommandFields a
-> (Maybe String, [String], String -> Maybe (ParserInfo a))
forall a.
Mod CommandFields a
-> (Maybe String, [String], String -> Maybe (ParserInfo a))
mkCommand Mod CommandFields a
m
    rdr :: OptReader a
rdr = Maybe String
-> [String] -> (String -> Maybe (ParserInfo a)) -> OptReader a
forall a.
Maybe String
-> [String] -> (String -> Maybe (ParserInfo a)) -> OptReader a
CmdReader Maybe String
groupName [String]
cmds ((ParserInfo a -> ParserInfo a)
-> Maybe (ParserInfo a) -> Maybe (ParserInfo a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParserInfo a -> ParserInfo a
forall a. ParserInfo a -> ParserInfo a
add_helper (Maybe (ParserInfo a) -> Maybe (ParserInfo a))
-> (String -> Maybe (ParserInfo a))
-> String
-> Maybe (ParserInfo a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe (ParserInfo a)
subs)
    add_helper :: ParserInfo a -> ParserInfo a
add_helper ParserInfo a
pinfo = ParserInfo a
pinfo
      { infoParser :: Parser a
infoParser = ParserInfo a -> Parser a
forall a. ParserInfo a -> Parser a
infoParser ParserInfo a
pinfo Parser a -> Parser (a -> a) -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (a -> a)
forall a. Parser (a -> a)
helpOption }

-- | Non-hidden help option.
helpOption :: Parser (a -> a)
helpOption :: Parser (a -> a)
helpOption =
    ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a.
ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
abortOption ParseError
showHelpText (Mod OptionFields (a -> a) -> Parser (a -> a))
-> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a b. (a -> b) -> a -> b
$
    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"