{-# 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 ( runExceptT )
import           Control.Monad.Trans.Writer ( runWriter, tell )
import           Options.Applicative
                   ( CommandFields, Parser, ParserFailure, ParserHelp
                   , ParserInfo (..), ParserResult (..), (<**>), abortOption
                   , command, execParserPure, footer, fullDesc
                   , handleParseResult, header, help, info, infoOption, long
                   , metavar, noBacktrack, prefs, progDesc, showHelpOnEmpty
                   )
import           Options.Applicative.Builder.Extra ( showHelpText )
import           Options.Applicative.Builder.Internal
                   ( Mod (..), mkCommand, mkParser )
import           Options.Applicative.Types ( OptReader (..) )
import           Stack.Prelude
import           Stack.Types.AddCommand ( AddCommand )
import           Stack.Types.GlobalOptsMonoid ( GlobalOptsMonoid )
import           Stack.Types.Runner ( Runner )
import           System.Environment ( getArgs )

-- | 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 (f :: * -> *) a. Applicative f => a -> f a
pure (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 a b. (a -> b) -> a -> b
$ forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell forall a b. (a -> b) -> a -> b
$
    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."