{-# 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           Stack.Types.Config
import           System.Environment

-- | Generate and execute a complicated options parser.

complicatedOptions
  :: 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 GlobalOptsMonoid
  -- ^ common settings

  -> Maybe (ParserFailure ParserHelp -> [String] -> IO (GlobalOptsMonoid,(RIO Runner (),GlobalOptsMonoid)))
  -- ^ optional handler for parser failure; 'handleParseResult' is called by

  -- default

  -> AddCommand
  -- ^ commands (use 'addCommand')

  -> IO (GlobalOptsMonoid, RIO Runner ())
complicatedOptions :: Version
-> Maybe String
-> String
-> String
-> String
-> String
-> Parser GlobalOptsMonoid
-> Maybe
     (ParserFailure ParserHelp
      -> [String]
      -> IO (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid)))
-> AddCommand
-> IO (GlobalOptsMonoid, RIO Runner ())
complicatedOptions Version
numericVersion Maybe String
stringVersion String
numericHpackVersion String
h String
pd String
footerStr Parser GlobalOptsMonoid
commonParser Maybe
  (ParserFailure ParserHelp
   -> [String]
   -> IO (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid)))
mOnFailure AddCommand
commandParser =
  do [String]
args <- IO [String]
getArgs
     (GlobalOptsMonoid
a,(RIO Runner ()
b,GlobalOptsMonoid
c)) <- let parserPrefs :: ParserPrefs
parserPrefs = PrefsMod -> ParserPrefs
prefs forall a b. (a -> b) -> a -> b
$ PrefsMod
noBacktrack forall a. Semigroup a => a -> a -> a
<> PrefsMod
showHelpOnEmpty
                  in  case forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
execParserPure ParserPrefs
parserPrefs ParserInfo (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
parser [String]
args of
       -- call onFailure handler if it's present and parsing options failed

       Failure ParserFailure ParserHelp
f | Just ParserFailure ParserHelp
-> [String]
-> IO (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
onFailure <- Maybe
  (ParserFailure ParserHelp
   -> [String]
   -> IO (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid)))
mOnFailure -> ParserFailure ParserHelp
-> [String]
-> IO (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
onFailure ParserFailure ParserHelp
f [String]
args
       ParserResult (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
parseResult -> forall a. ParserResult a -> IO a
handleParseResult ParserResult (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
parseResult
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a -> a -> a
mappend GlobalOptsMonoid
c GlobalOptsMonoid
a,RIO Runner ()
b)
  where parser :: ParserInfo (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
parser = forall a. Parser a -> InfoMod a -> ParserInfo a
info (forall a. Parser (a -> a)
helpOption forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Parser (a -> a)
versionOptions forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String
-> Parser GlobalOptsMonoid
-> AddCommand
-> Parser (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
complicatedParser String
"COMMAND|FILE" Parser GlobalOptsMonoid
commonParser AddCommand
commandParser) forall {a}. InfoMod a
desc
        desc :: InfoMod a
desc = forall {a}. InfoMod a
fullDesc forall a. Semigroup a => a -> a -> a
<> forall a. String -> InfoMod a
header String
h forall a. Semigroup a => a -> a -> a
<> forall a. String -> InfoMod a
progDesc String
pd forall a. Semigroup a => a -> a -> a
<> forall a. String -> InfoMod a
footer String
footerStr
        versionOptions :: Parser (a -> a)
versionOptions =
          case Maybe String
stringVersion of
            Maybe String
Nothing -> forall {a}. String -> Parser (a -> a)
versionOption (Version -> String
versionString Version
numericVersion)
            Just String
s -> forall {a}. String -> Parser (a -> a)
versionOption String
s forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Parser (a -> a)
numericVersionOption forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Parser (a -> a)
numericHpackVersionOption
        versionOption :: String -> Parser (a -> a)
versionOption String
s =
          forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption
            String
s
            (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"version" forall a. Semigroup a => a -> a -> a
<>
             forall (f :: * -> *) a. String -> Mod f a
help String
"Show version")
        numericVersionOption :: Parser (a -> a)
numericVersionOption =
          forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption
            (Version -> String
versionString Version
numericVersion)
            (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"numeric-version" forall a. Semigroup a => a -> a -> a
<>
             forall (f :: * -> *) a. String -> Mod f a
help String
"Show only version number")
        numericHpackVersionOption :: Parser (a -> a)
numericHpackVersionOption =
          forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption
            String
numericHpackVersion
            (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"hpack-numeric-version" forall a. Semigroup a => a -> 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

           -> (opts -> RIO Runner ()) -- ^ constructor to wrap up command in common data type

           -> (opts -> GlobalOptsMonoid -> GlobalOptsMonoid) -- ^ extend common settings from local settings

           -> Parser GlobalOptsMonoid -- ^ common parser

           -> Parser opts -- ^ command parser

           -> AddCommand
addCommand :: forall opts.
String
-> String
-> String
-> (opts -> RIO Runner ())
-> (opts -> GlobalOptsMonoid -> GlobalOptsMonoid)
-> Parser GlobalOptsMonoid
-> Parser opts
-> AddCommand
addCommand String
cmd String
title String
footerStr opts -> RIO Runner ()
constr opts -> GlobalOptsMonoid -> GlobalOptsMonoid
extendCommon =
  forall opts.
String
-> String
-> String
-> (opts -> GlobalOptsMonoid -> (RIO Runner (), GlobalOptsMonoid))
-> Parser GlobalOptsMonoid
-> Parser opts
-> AddCommand
addCommand' String
cmd String
title String
footerStr (\opts
a GlobalOptsMonoid
c -> (opts -> RIO Runner ()
constr opts
a,opts -> GlobalOptsMonoid -> GlobalOptsMonoid
extendCommon opts
a GlobalOptsMonoid
c))

-- | Add a command that takes sub-commands to the options dispatcher.

addSubCommands
  :: String
  -- ^ command string

  -> String
  -- ^ title of command

  -> String
  -- ^ footer of command help

  -> Parser GlobalOptsMonoid
  -- ^ common parser

  -> AddCommand
  -- ^ sub-commands (use 'addCommand')

  -> AddCommand
addSubCommands :: String
-> String
-> String
-> Parser GlobalOptsMonoid
-> AddCommand
-> AddCommand
addSubCommands String
cmd String
title String
footerStr Parser GlobalOptsMonoid
commonParser AddCommand
commandParser =
  forall opts.
String
-> String
-> String
-> (opts -> GlobalOptsMonoid -> (RIO Runner (), GlobalOptsMonoid))
-> Parser GlobalOptsMonoid
-> Parser opts
-> AddCommand
addCommand' String
cmd
              String
title
              String
footerStr
              (\(GlobalOptsMonoid
c1,(RIO Runner ()
a,GlobalOptsMonoid
c2)) GlobalOptsMonoid
c3 -> (RIO Runner ()
a,forall a. Monoid a => [a] -> a
mconcat [GlobalOptsMonoid
c3, GlobalOptsMonoid
c2, GlobalOptsMonoid
c1]))
              Parser GlobalOptsMonoid
commonParser
              (String
-> Parser GlobalOptsMonoid
-> AddCommand
-> Parser (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
complicatedParser String
"COMMAND" Parser GlobalOptsMonoid
commonParser AddCommand
commandParser)

-- | Add a command to the options dispatcher.

addCommand' :: String   -- ^ command string

            -> String   -- ^ title of command

            -> String   -- ^ footer of command help

            -> (opts -> GlobalOptsMonoid -> (RIO Runner (),GlobalOptsMonoid)) -- ^ constructor to wrap up command in common data type

            -> Parser GlobalOptsMonoid -- ^ common parser

            -> Parser opts -- ^ command parser

            -> AddCommand
addCommand' :: forall opts.
String
-> String
-> String
-> (opts -> GlobalOptsMonoid -> (RIO Runner (), GlobalOptsMonoid))
-> Parser GlobalOptsMonoid
-> Parser opts
-> AddCommand
addCommand' String
cmd String
title String
footerStr opts -> GlobalOptsMonoid -> (RIO Runner (), GlobalOptsMonoid)
constr Parser GlobalOptsMonoid
commonParser Parser opts
inner =
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (forall a. String -> ParserInfo a -> Mod CommandFields a
command String
cmd
                      (forall a. Parser a -> InfoMod a -> ParserInfo a
info (opts -> GlobalOptsMonoid -> (RIO Runner (), GlobalOptsMonoid)
constr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser opts
inner forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser GlobalOptsMonoid
commonParser)
                            (forall a. String -> InfoMod a
progDesc String
title forall a. Semigroup a => a -> a -> a
<> forall a. String -> InfoMod a
footer String
footerStr))))

-- | Generate a complicated options parser.

complicatedParser
  :: String
  -- ^ metavar for the sub-command

  -> Parser GlobalOptsMonoid
  -- ^ common settings

  -> AddCommand
  -- ^ commands (use 'addCommand')

  -> Parser (GlobalOptsMonoid,(RIO Runner (),GlobalOptsMonoid))
complicatedParser :: String
-> Parser GlobalOptsMonoid
-> AddCommand
-> Parser (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
complicatedParser String
commandMetavar Parser GlobalOptsMonoid
commonParser AddCommand
commandParser =
   (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
   Parser GlobalOptsMonoid
commonParser forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
   case forall w a. Writer w a -> (a, w)
runWriter (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT AddCommand
commandParser) of
     (Right (),Mod CommandFields (RIO Runner (), GlobalOptsMonoid)
d) -> forall a. String -> Mod CommandFields a -> Parser a
hsubparser' String
commandMetavar Mod CommandFields (RIO Runner (), GlobalOptsMonoid)
d
     (Left RIO Runner ()
b,Mod CommandFields (RIO Runner (), GlobalOptsMonoid)
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (RIO Runner ()
b,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' :: forall a. String -> Mod CommandFields a -> Parser a
hsubparser' String
commandMetavar Mod CommandFields a
m = 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 = forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
commandMetavar forall a. Monoid a => a -> a -> a
`mappend` Mod CommandFields a
m
    (Maybe String
groupName, [String]
cmds, String -> Maybe (ParserInfo a)
subs) = forall a.
Mod CommandFields a
-> (Maybe String, [String], String -> Maybe (ParserInfo a))
mkCommand Mod CommandFields a
m
    rdr :: OptReader a
rdr = forall a.
Maybe String
-> [String] -> (String -> Maybe (ParserInfo a)) -> OptReader a
CmdReader Maybe String
groupName [String]
cmds (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}. ParserInfo a -> ParserInfo a
add_helper 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 = forall a. ParserInfo a -> Parser a
infoParser ParserInfo a
pinfo forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> forall a. Parser (a -> a)
helpOption }

-- | Non-hidden help option.

helpOption :: Parser (a -> a)
helpOption :: forall a. Parser (a -> a)
helpOption =
    forall a.
ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
abortOption ParseError
showHelpText forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"help" forall a. Semigroup a => a -> a -> a
<>
    forall (f :: * -> *) a. String -> Mod f a
help String
"Show this help text"