{-# 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
                   ( Parser, ParserFailure, ParserHelp, ParserResult (..)
                   , abortOption, command, execParserPure, footer, fullDesc
                   , handleParseResult, header, help, info, infoOption, long
                   , metavar, noBacktrack, prefs, progDesc, showHelpOnEmpty
                   , hsubparser
                   )
import           Options.Applicative.Builder.Extra ( showHelpText )
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 (PrefsMod -> ParserPrefs) -> PrefsMod -> ParserPrefs
forall a b. (a -> b) -> a -> b
$ PrefsMod
noBacktrack PrefsMod -> PrefsMod -> PrefsMod
forall a. Semigroup a => a -> a -> a
<> PrefsMod
showHelpOnEmpty
                   in  case ParserPrefs
-> ParserInfo (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
-> [String]
-> ParserResult
     (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
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 -> ParserResult (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
-> IO (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
forall a. ParserResult a -> IO a
handleParseResult ParserResult (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
parseResult
    (GlobalOptsMonoid, RIO Runner ())
-> IO (GlobalOptsMonoid, RIO Runner ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GlobalOptsMonoid -> GlobalOptsMonoid -> GlobalOptsMonoid
forall a. Monoid a => a -> a -> a
mappend GlobalOptsMonoid
c GlobalOptsMonoid
a, RIO Runner ()
b)
 where
  parser :: ParserInfo (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
parser = Parser (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
-> InfoMod (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
-> ParserInfo (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
forall a. Parser a -> InfoMod a -> ParserInfo a
info
    (   Parser
  (((GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
    -> (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid)))
   -> (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
   -> (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid)))
forall a. Parser (a -> a)
helpOption
    Parser
  (((GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
    -> (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid)))
   -> (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
   -> (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid)))
-> Parser
     ((GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
      -> (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid)))
-> Parser
     ((GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
      -> (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid)))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser
  ((GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
   -> (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid)))
forall a. Parser (a -> a)
versionOptions
    Parser
  ((GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
   -> (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid)))
-> Parser (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
-> Parser (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
forall a b. Parser (a -> b) -> Parser a -> Parser b
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
    )
    InfoMod (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
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 a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser (a -> b) -> Parser a -> Parser b
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

  -> (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 =
  String
-> String
-> String
-> (opts -> GlobalOptsMonoid -> (RIO Runner (), GlobalOptsMonoid))
-> Parser GlobalOptsMonoid
-> Parser opts
-> AddCommand
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 =
  String
-> String
-> String
-> ((GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
    -> GlobalOptsMonoid -> (RIO Runner (), GlobalOptsMonoid))
-> Parser GlobalOptsMonoid
-> Parser (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
-> AddCommand
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, [GlobalOptsMonoid] -> GlobalOptsMonoid
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 =
  Writer (Mod CommandFields (RIO Runner (), GlobalOptsMonoid)) ()
-> AddCommand
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (RIO Runner ()) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Writer (Mod CommandFields (RIO Runner (), GlobalOptsMonoid)) ()
 -> AddCommand)
-> Writer (Mod CommandFields (RIO Runner (), GlobalOptsMonoid)) ()
-> AddCommand
forall a b. (a -> b) -> a -> b
$ Mod CommandFields (RIO Runner (), GlobalOptsMonoid)
-> Writer (Mod CommandFields (RIO Runner (), GlobalOptsMonoid)) ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (Mod CommandFields (RIO Runner (), GlobalOptsMonoid)
 -> Writer (Mod CommandFields (RIO Runner (), GlobalOptsMonoid)) ())
-> Mod CommandFields (RIO Runner (), GlobalOptsMonoid)
-> Writer (Mod CommandFields (RIO Runner (), GlobalOptsMonoid)) ()
forall a b. (a -> b) -> a -> b
$
    String
-> ParserInfo (RIO Runner (), GlobalOptsMonoid)
-> Mod CommandFields (RIO Runner (), GlobalOptsMonoid)
forall a. String -> ParserInfo a -> Mod CommandFields a
command
      String
cmd
      ( Parser (RIO Runner (), GlobalOptsMonoid)
-> InfoMod (RIO Runner (), GlobalOptsMonoid)
-> ParserInfo (RIO Runner (), GlobalOptsMonoid)
forall a. Parser a -> InfoMod a -> ParserInfo a
info
          (opts -> GlobalOptsMonoid -> (RIO Runner (), GlobalOptsMonoid)
constr (opts -> GlobalOptsMonoid -> (RIO Runner (), GlobalOptsMonoid))
-> Parser opts
-> Parser (GlobalOptsMonoid -> (RIO Runner (), GlobalOptsMonoid))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser opts
inner Parser (GlobalOptsMonoid -> (RIO Runner (), GlobalOptsMonoid))
-> Parser GlobalOptsMonoid
-> Parser (RIO Runner (), GlobalOptsMonoid)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser GlobalOptsMonoid
commonParser)
          (String -> InfoMod (RIO Runner (), GlobalOptsMonoid)
forall a. String -> InfoMod a
progDesc String
title InfoMod (RIO Runner (), GlobalOptsMonoid)
-> InfoMod (RIO Runner (), GlobalOptsMonoid)
-> InfoMod (RIO Runner (), GlobalOptsMonoid)
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod (RIO Runner (), GlobalOptsMonoid)
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 =
  (,)
    (GlobalOptsMonoid
 -> (RIO Runner (), GlobalOptsMonoid)
 -> (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid)))
-> Parser GlobalOptsMonoid
-> Parser
     ((RIO Runner (), GlobalOptsMonoid)
      -> (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser GlobalOptsMonoid
commonParser
    Parser
  ((RIO Runner (), GlobalOptsMonoid)
   -> (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid)))
-> Parser (RIO Runner (), GlobalOptsMonoid)
-> Parser (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> case Writer
  (Mod CommandFields (RIO Runner (), GlobalOptsMonoid))
  (Either (RIO Runner ()) ())
-> (Either (RIO Runner ()) (),
    Mod CommandFields (RIO Runner (), GlobalOptsMonoid))
forall w a. Writer w a -> (a, w)
runWriter (AddCommand
-> Writer
     (Mod CommandFields (RIO Runner (), GlobalOptsMonoid))
     (Either (RIO Runner ()) ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT AddCommand
commandParser) of
          (Right (), Mod CommandFields (RIO Runner (), GlobalOptsMonoid)
m) -> Mod CommandFields (RIO Runner (), GlobalOptsMonoid)
-> Parser (RIO Runner (), GlobalOptsMonoid)
forall a. Mod CommandFields a -> Parser a
hsubparser (Mod CommandFields (RIO Runner (), GlobalOptsMonoid)
m Mod CommandFields (RIO Runner (), GlobalOptsMonoid)
-> Mod CommandFields (RIO Runner (), GlobalOptsMonoid)
-> Mod CommandFields (RIO Runner (), GlobalOptsMonoid)
forall a. Semigroup a => a -> a -> a
<> String -> Mod CommandFields (RIO Runner (), GlobalOptsMonoid)
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
commandMetavar)
          (Left RIO Runner ()
b, Mod CommandFields (RIO Runner (), GlobalOptsMonoid)
_) -> (RIO Runner (), GlobalOptsMonoid)
-> Parser (RIO Runner (), GlobalOptsMonoid)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RIO Runner ()
b, GlobalOptsMonoid
forall a. Monoid a => a
mempty)

-- | Non-hidden help option.

helpOption :: Parser (a -> a)
helpOption :: forall a. 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."