{-# LANGUAGE NoImplicitPrelude #-}

module Stack.CLI
  ( commandLineHandler
  ) where

import           Data.Attoparsec.Interpreter ( getInterpreterArgs )
import           Data.Char ( toLower )
import qualified Data.List as L
import           Options.Applicative
                   ( Parser, ParserFailure, ParserHelp, ParserResult (..), flag, switch
                   , handleParseResult, help, helpError, idm, long, metavar
                   , overFailure, renderFailure, strArgument, switch )
import           Options.Applicative.Help ( errorHelp, stringChunk, vcatChunks )
import           Options.Applicative.Builder.Extra
                   ( boolFlags, extraHelpOption, textOption )
import           Options.Applicative.Complicated
                   ( addCommand, addSubCommands, complicatedOptions )
import qualified RIO.Process ( exec )
import           RIO.Process ( withProcessContextNoLogging )
import           Stack.Build ( buildCmd )
import           Stack.BuildInfo ( hpackVersion, versionString' )
import           Stack.Clean ( CleanCommand (..), cleanCmd )
import           Stack.ConfigCmd as ConfigCmd
import           Stack.Constants ( globalFooter, osIsWindows, stackProgName )
import           Stack.Coverage ( hpcReportCmd )
import           Stack.Docker
                   ( dockerCmdName, dockerHelpOptName, dockerPullCmdName )
import           Stack.DockerCmd ( dockerPullCmd, dockerResetCmd )
import qualified Stack.Dot ( dot )
import           Stack.Exec ( SpecialExecCmd (..), execCmd )
import           Stack.Eval ( evalCmd )
import           Stack.Ghci ( ghciCmd )
import           Stack.Hoogle ( hoogleCmd )
import           Stack.IDE
                   ( ListPackagesCmd (..), OutputStream (..), idePackagesCmd
                   , ideTargetsCmd
                   )
import           Stack.Init ( initCmd )
import           Stack.List ( listCmd )
import           Stack.Ls ( lsCmd )
import           Stack.New ( newCmd )
import qualified Stack.Nix as Nix
import           Stack.Options.BuildParser ( buildOptsParser )
import           Stack.Options.CleanParser ( cleanOptsParser )
import           Stack.Options.DotParser ( dotOptsParser )
import           Stack.Options.EvalParser ( evalOptsParser )
import           Stack.Options.ExecParser ( execOptsParser )
import           Stack.Options.GhciParser ( ghciOptsParser )
import           Stack.Options.GlobalParser ( globalOptsParser )
import           Stack.Options.HpcReportParser ( hpcReportOptsParser )
import           Stack.Options.InitParser ( initOptsParser )
import           Stack.Options.LsParser ( lsOptsParser )
import           Stack.Options.NewParser ( newOptsParser )
import           Stack.Options.PathParser ( pathParser )
import           Stack.Options.SDistParser ( sdistOptsParser )
import           Stack.Options.ScriptParser ( scriptOptsParser )
import           Stack.Options.SetupParser ( setupOptsParser )
import           Stack.Options.UpgradeParser ( upgradeOptsParser )
import           Stack.Options.UploadParser ( uploadOptsParser )
import           Stack.Options.Utils ( GlobalOptsContext (..) )
import qualified Stack.Path ( path )
import           Stack.Prelude
import           Stack.Query ( queryCmd )
import           Stack.Runners
                   ( ShouldReexec (..), withConfig, withDefaultEnvConfig )
import           Stack.SDist ( sdistCmd )
import           Stack.Script ( ScriptOpts (..), scriptCmd )
import           Stack.SetupCmd ( setupCmd )
import           Stack.Templates ( templatesCmd )
import           Stack.Types.AddCommand ( AddCommand )
import           Stack.Types.BuildOpts ( BuildCommand (..) )
import           Stack.Types.GlobalOptsMonoid ( GlobalOptsMonoid (..) )
import           Stack.Types.Runner ( Runner )
import           Stack.Types.Version ( stackVersion )
import           Stack.Uninstall ( uninstallCmd )
import           Stack.Unpack ( unpackCmd )
import           Stack.Update ( updateCmd )
import           Stack.Upgrade ( upgradeCmd )
import           Stack.Upload ( uploadCmd )
import qualified System.Directory as D
import           System.Environment ( getProgName, withArgs )
import           System.FilePath ( pathSeparator, takeDirectory )

-- | Stack's command line handler.

commandLineHandler ::
     FilePath
  -> String
  -> Bool
  -> IO (GlobalOptsMonoid, RIO Runner ())
commandLineHandler :: String -> String -> Bool -> IO (GlobalOptsMonoid, RIO Runner ())
commandLineHandler String
currentDir String
progName Bool
isInterpreter =
  -- Append the relevant default (potentially affecting the LogLevel) *after*

  -- appending the global options of the `stack` command to the global options

  -- of the subcommand - see #5326.

  (GlobalOptsMonoid -> GlobalOptsMonoid)
-> (GlobalOptsMonoid, RIO Runner ())
-> (GlobalOptsMonoid, RIO Runner ())
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (GlobalOptsMonoid -> GlobalOptsMonoid -> GlobalOptsMonoid
forall a. Semigroup a => a -> a -> a
<> GlobalOptsMonoid
defaultGlobalOpts) ((GlobalOptsMonoid, RIO Runner ())
 -> (GlobalOptsMonoid, RIO Runner ()))
-> IO (GlobalOptsMonoid, RIO Runner ())
-> IO (GlobalOptsMonoid, RIO Runner ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
stackVersion
    (String -> Maybe String
forall a. a -> Maybe a
Just String
versionString')
    String
hpackVersion
    String
"stack - The Haskell Tool Stack"
    String
""
    (String
"Stack's documentation is available at https://docs.haskellstack.org/. \
    \Command '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
progName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" COMMAND --help' for help about a Stack command. Stack also \
    \supports the Haskell Error Index at https://errors.haskell.org/.")
    (GlobalOptsContext -> Parser GlobalOptsMonoid
globalOpts GlobalOptsContext
OuterGlobalOpts)
    ((ParserFailure ParserHelp
 -> [String]
 -> IO (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid)))
-> Maybe
     (ParserFailure ParserHelp
      -> [String]
      -> IO (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid)))
forall a. a -> Maybe a
Just ParserFailure ParserHelp
-> [String]
-> IO (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
forall {t}.
Monoid t =>
ParserFailure ParserHelp
-> [String] -> IO (GlobalOptsMonoid, (RIO Runner (), t))
failureCallback)
    AddCommand
addCommands
 where
  defaultGlobalOpts :: GlobalOptsMonoid
defaultGlobalOpts = if Bool
isInterpreter
    then
      -- Silent except when errors occur - see #2879

      GlobalOptsMonoid
forall a. Monoid a => a
mempty { globalMonoidLogLevel :: First LogLevel
globalMonoidLogLevel = Maybe LogLevel -> First LogLevel
forall a. Maybe a -> First a
First (LogLevel -> Maybe LogLevel
forall a. a -> Maybe a
Just LogLevel
LevelError) }
    else GlobalOptsMonoid
forall a. Monoid a => a
mempty
  failureCallback :: ParserFailure ParserHelp
-> [String] -> IO (GlobalOptsMonoid, (RIO Runner (), t))
failureCallback ParserFailure ParserHelp
f [String]
args =
    case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
L.stripPrefix String
"Invalid argument" ((String, ExitCode) -> String
forall a b. (a, b) -> a
fst (ParserFailure ParserHelp -> String -> (String, ExitCode)
renderFailure ParserFailure ParserHelp
f String
"")) of
      Just String
_ -> if Bool
isInterpreter
                  then [String]
-> ParserFailure ParserHelp
-> IO (GlobalOptsMonoid, (RIO Runner (), t))
forall {a}. [String] -> ParserFailure ParserHelp -> IO a
parseResultHandler [String]
args ParserFailure ParserHelp
f
                  else [String]
-> ParserFailure ParserHelp -> IO (ParserFailure ParserHelp)
secondaryCommandHandler [String]
args ParserFailure ParserHelp
f
                      IO (ParserFailure ParserHelp)
-> (ParserFailure ParserHelp
    -> IO (GlobalOptsMonoid, (RIO Runner (), t)))
-> IO (GlobalOptsMonoid, (RIO Runner (), t))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String
-> [String]
-> ParserFailure ParserHelp
-> IO (GlobalOptsMonoid, (RIO Runner (), t))
forall t.
Monoid t =>
String
-> [String]
-> ParserFailure ParserHelp
-> IO (GlobalOptsMonoid, (RIO Runner (), t))
interpreterHandler String
currentDir [String]
args
      Maybe String
Nothing -> [String]
-> ParserFailure ParserHelp
-> IO (GlobalOptsMonoid, (RIO Runner (), t))
forall {a}. [String] -> ParserFailure ParserHelp -> IO a
parseResultHandler [String]
args ParserFailure ParserHelp
f

  parseResultHandler :: [String] -> ParserFailure ParserHelp -> IO a
parseResultHandler [String]
args ParserFailure ParserHelp
f =
    if Bool
isInterpreter
    then do
      let hlp :: ParserHelp
hlp = Chunk Doc -> ParserHelp
errorHelp (Chunk Doc -> ParserHelp) -> Chunk Doc -> ParserHelp
forall a b. (a -> b) -> a -> b
$ String -> Chunk Doc
stringChunk
            ([String] -> String
unwords [String
"Error executing interpreter command:"
                      , String
progName
                      , [String] -> String
unwords [String]
args])
      ParserResult a -> IO a
forall a. ParserResult a -> IO a
handleParseResult ((ParserHelp -> ParserHelp) -> ParserResult a -> ParserResult a
forall a.
(ParserHelp -> ParserHelp) -> ParserResult a -> ParserResult a
overFailure (ParserHelp -> ParserHelp -> ParserHelp
vcatErrorHelp ParserHelp
hlp) (ParserFailure ParserHelp -> ParserResult a
forall a. ParserFailure ParserHelp -> ParserResult a
Failure ParserFailure ParserHelp
f))
    else ParserResult a -> IO a
forall a. ParserResult a -> IO a
handleParseResult (ParserFailure ParserHelp -> ParserResult a
forall a. ParserFailure ParserHelp -> ParserResult a
Failure ParserFailure ParserHelp
f)

  -- The order of commands below determines the order in which they are listed

  -- in `stack --help`.

  addCommands :: AddCommand
addCommands = do
    Bool -> AddCommand -> AddCommand
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isInterpreter (AddCommand -> AddCommand) -> AddCommand -> AddCommand
forall a b. (a -> b) -> a -> b
$ do
      AddCommand
build
      AddCommand
install
      AddCommand
uninstall
      AddCommand
test
      AddCommand
bench
      AddCommand
haddock
      AddCommand
new
      AddCommand
templates
      AddCommand
init
      AddCommand
setup
      AddCommand
path
      AddCommand
ls
      AddCommand
unpack
      AddCommand
update
      AddCommand
upgrade
      AddCommand
upload
      AddCommand
sdist
      AddCommand
dot
      AddCommand
ghc
      AddCommand
hoogle
    -- These are the only commands allowed in interpreter mode as well

    AddCommand
exec
    AddCommand
run
    AddCommand
ghci
    AddCommand
repl
    AddCommand
runghc
    AddCommand
runhaskell
    AddCommand
script
    Bool -> AddCommand -> AddCommand
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isInterpreter (AddCommand -> AddCommand) -> AddCommand -> AddCommand
forall a b. (a -> b) -> a -> b
$ do
      AddCommand
eval
      AddCommand
clean
      AddCommand
purge
      AddCommand
query
      AddCommand
list
      AddCommand
ide
      AddCommand
docker
      AddCommand
config
      AddCommand
hpc

  -- Stack's subcommands are listed below in alphabetical order


  bench :: AddCommand
bench = String
-> String
-> (BuildOptsCLI -> RIO Runner ())
-> Parser BuildOptsCLI
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addBuildCommand'
    String
"bench"
    String
"Shortcut for 'build --bench'."
    BuildOptsCLI -> RIO Runner ()
buildCmd
    (BuildCommand -> Parser BuildOptsCLI
buildOptsParser BuildCommand
Bench)

  build :: AddCommand
build = String
-> String
-> (BuildOptsCLI -> RIO Runner ())
-> Parser BuildOptsCLI
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addBuildCommand'
    String
"build"
    String
"Build the package(s) in this directory/configuration."
    BuildOptsCLI -> RIO Runner ()
buildCmd
    (BuildCommand -> Parser BuildOptsCLI
buildOptsParser BuildCommand
Build)

  clean :: AddCommand
clean = String
-> String
-> (CleanOpts -> RIO Runner ())
-> Parser CleanOpts
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"clean"
    String
"Delete build artefacts for the project packages."
    CleanOpts -> RIO Runner ()
cleanCmd
    (CleanCommand -> Parser CleanOpts
cleanOptsParser CleanCommand
Clean)

  config :: AddCommand
config = String -> String -> AddCommand -> AddCommand
addSubCommands'
      String
ConfigCmd.cfgCmdName
        String
"Subcommands for accessing and modifying configuration values."
        ( do
            String
-> String
-> (ConfigCmdSet -> RIO Runner ())
-> Parser ConfigCmdSet
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
              String
ConfigCmd.cfgCmdSetName
              String
"Sets a key in YAML configuration file to value."
              (ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec (RIO Config () -> RIO Runner ())
-> (ConfigCmdSet -> RIO Config ()) -> ConfigCmdSet -> RIO Runner ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigCmdSet -> RIO Config ()
forall env.
(HasConfig env, HasGHCVariant env) =>
ConfigCmdSet -> RIO env ()
cfgCmdSet)
              Parser ConfigCmdSet
configCmdSetParser
            String
-> String
-> (EnvSettings -> RIO Runner ())
-> Parser EnvSettings
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
              String
ConfigCmd.cfgCmdEnvName
              String
"Print environment variables for use in a shell."
              (ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec (RIO Config () -> RIO Runner ())
-> (EnvSettings -> RIO Config ()) -> EnvSettings -> RIO Runner ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RIO EnvConfig () -> RIO Config ()
forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig (RIO EnvConfig () -> RIO Config ())
-> (EnvSettings -> RIO EnvConfig ())
-> EnvSettings
-> RIO Config ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvSettings -> RIO EnvConfig ()
cfgCmdEnv)
              Parser EnvSettings
configCmdEnvParser
        )

  docker :: AddCommand
docker = String -> String -> AddCommand -> AddCommand
addSubCommands'
    String
dockerCmdName
    String
"Subcommands specific to Docker use."
    ( do
        String
-> String -> (() -> RIO Runner ()) -> Parser () -> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
          String
dockerPullCmdName
          String
"Pull latest version of Docker image from registry."
          () -> RIO Runner ()
dockerPullCmd
          (() -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        String
-> String -> (Bool -> RIO Runner ()) -> Parser Bool -> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
          String
"reset"
          String
"Reset the Docker sandbox."
          Bool -> RIO Runner ()
dockerResetCmd
          ( Mod FlagFields Bool -> Parser Bool
switch
              (  String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"keep-home"
              Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Do not delete sandbox's home directory."
              )
          )
    )

  dot :: AddCommand
dot = String
-> String
-> (DotOpts -> RIO Runner ())
-> Parser DotOpts
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"dot"
    String
"Visualize your project's dependency graph using Graphviz dot."
    DotOpts -> RIO Runner ()
Stack.Dot.dot
    (Bool -> Parser DotOpts
dotOptsParser Bool
False) -- Default for --external is False.


  eval :: AddCommand
eval = String
-> String
-> (EvalOpts -> RIO Runner ())
-> Parser EvalOpts
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"eval"
    String
"Evaluate some Haskell code inline. Shortcut for \
    \'stack exec ghc -- -e CODE'."
    EvalOpts -> RIO Runner ()
evalCmd
    (String -> Parser EvalOpts
evalOptsParser String
"CODE")

  exec :: AddCommand
exec = String
-> String
-> (ExecOpts -> RIO Runner ())
-> Parser ExecOpts
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"exec"
    String
"Execute a command. If the command is absent, the first of any arguments \
    \is taken as the command."
    ExecOpts -> RIO Runner ()
execCmd
    (Maybe SpecialExecCmd -> Parser ExecOpts
execOptsParser Maybe SpecialExecCmd
forall a. Maybe a
Nothing)

  ghc :: AddCommand
ghc = String
-> String
-> (ExecOpts -> RIO Runner ())
-> Parser ExecOpts
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"ghc"
    String
"Run ghc."
    ExecOpts -> RIO Runner ()
execCmd
    (Maybe SpecialExecCmd -> Parser ExecOpts
execOptsParser (Maybe SpecialExecCmd -> Parser ExecOpts)
-> Maybe SpecialExecCmd -> Parser ExecOpts
forall a b. (a -> b) -> a -> b
$ SpecialExecCmd -> Maybe SpecialExecCmd
forall a. a -> Maybe a
Just SpecialExecCmd
ExecGhc)

  ghci :: AddCommand
ghci = String
-> String
-> (GhciOpts -> RIO Runner ())
-> Parser GhciOpts
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addGhciCommand'
    String
"ghci"
    String
"Run ghci in the context of package(s)."
    GhciOpts -> RIO Runner ()
ghciCmd
    Parser GhciOpts
ghciOptsParser

  haddock :: AddCommand
haddock = String
-> String
-> (BuildOptsCLI -> RIO Runner ())
-> Parser BuildOptsCLI
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addBuildCommand'
    String
"haddock"
    String
"Shortcut for 'build --haddock'."
    BuildOptsCLI -> RIO Runner ()
buildCmd
    (BuildCommand -> Parser BuildOptsCLI
buildOptsParser BuildCommand
Haddock)

  hoogle :: AddCommand
hoogle = String
-> String
-> (([String], Bool, Bool, Bool) -> RIO Runner ())
-> Parser ([String], Bool, Bool, Bool)
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"hoogle"
    String
"Run hoogle, the Haskell API search engine. Use the '-- ARGUMENT(S)' \
    \syntax to pass Hoogle arguments, e.g. 'stack hoogle -- --count=20', \
    \or 'stack hoogle -- server --local'."
    ([String], Bool, Bool, Bool) -> RIO Runner ()
hoogleCmd
    ( (,,,)
        ([String] -> Bool -> Bool -> Bool -> ([String], Bool, Bool, Bool))
-> Parser [String]
-> Parser (Bool -> Bool -> Bool -> ([String], Bool, Bool, Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String -> Parser [String]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Mod ArgumentFields String -> Parser String
forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument
              ( String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"-- ARGUMENT(S) (e.g. 'stack hoogle -- server --local')"
              ))
        Parser (Bool -> Bool -> Bool -> ([String], Bool, Bool, Bool))
-> Parser Bool
-> Parser (Bool -> Bool -> ([String], Bool, Bool, Bool))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags
              Bool
True
              String
"setup"
              String
"If needed: install Hoogle, build Haddock documentation and \
              \generate a Hoogle database."
              Mod FlagFields Bool
forall a. Monoid a => a
idm
        Parser (Bool -> Bool -> ([String], Bool, Bool, Bool))
-> Parser Bool -> Parser (Bool -> ([String], Bool, Bool, Bool))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
              (  String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"rebuild"
              Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Rebuild the Hoogle database."
              )
        Parser (Bool -> ([String], Bool, Bool, Bool))
-> Parser Bool -> Parser ([String], Bool, Bool, Bool)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
              (  String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"server"
              Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Start local Hoogle server."
              )
      )

  hpc :: AddCommand
hpc = String -> String -> AddCommand -> AddCommand
addSubCommands'
    String
"hpc"
    String
"Subcommands specific to Haskell Program Coverage."
    ( String
-> String
-> (HpcReportOpts -> RIO Runner ())
-> Parser HpcReportOpts
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
        String
"report"
        String
"Generate unified HPC coverage report from tix files and project \
        \targets."
        HpcReportOpts -> RIO Runner ()
hpcReportCmd
        Parser HpcReportOpts
hpcReportOptsParser
    )

  ide :: AddCommand
ide = String -> String -> AddCommand -> AddCommand
addSubCommands'
    String
"ide"
    String
"IDE-specific commands."
    ( let outputFlag :: Parser OutputStream
outputFlag = OutputStream
-> OutputStream
-> Mod FlagFields OutputStream
-> Parser OutputStream
forall a. a -> a -> Mod FlagFields a -> Parser a
flag
            OutputStream
OutputLogInfo
            OutputStream
OutputStdout
            (  String -> Mod FlagFields OutputStream
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"stdout"
            Mod FlagFields OutputStream
-> Mod FlagFields OutputStream -> Mod FlagFields OutputStream
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields OutputStream
forall (f :: * -> *) a. String -> Mod f a
help String
"Send output to the standard output stream instead of the \
                    \default, the standard error stream."
            )
          cabalFileFlag :: Parser ListPackagesCmd
cabalFileFlag = ListPackagesCmd
-> ListPackagesCmd
-> Mod FlagFields ListPackagesCmd
-> Parser ListPackagesCmd
forall a. a -> a -> Mod FlagFields a -> Parser a
flag
            ListPackagesCmd
ListPackageNames
            ListPackagesCmd
ListPackageCabalFiles
            (  String -> Mod FlagFields ListPackagesCmd
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"cabal-files"
            Mod FlagFields ListPackagesCmd
-> Mod FlagFields ListPackagesCmd -> Mod FlagFields ListPackagesCmd
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields ListPackagesCmd
forall (f :: * -> *) a. String -> Mod f a
help String
"Print paths to package Cabal files instead of package \
                    \names."
            )
          exeFlag :: Parser Bool
exeFlag = Mod FlagFields Bool -> Parser Bool
switch
            (  String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"exes"
            Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Include executables."
            )
          testFlag :: Parser Bool
testFlag = Mod FlagFields Bool -> Parser Bool
switch
            (  String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"tests"
            Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Include test suites."
            )
          benchFlag :: Parser Bool
benchFlag = Mod FlagFields Bool -> Parser Bool
switch
            (  String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"benchmarks"
            Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Include benchmarks."
            )
       in  do
             String
-> String
-> ((OutputStream, ListPackagesCmd) -> RIO Runner ())
-> Parser (OutputStream, ListPackagesCmd)
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
               String
"packages"
               String
"List all available local loadable packages."
               (OutputStream, ListPackagesCmd) -> RIO Runner ()
idePackagesCmd
               ((,) (OutputStream
 -> ListPackagesCmd -> (OutputStream, ListPackagesCmd))
-> Parser OutputStream
-> Parser (ListPackagesCmd -> (OutputStream, ListPackagesCmd))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser OutputStream
outputFlag Parser (ListPackagesCmd -> (OutputStream, ListPackagesCmd))
-> Parser ListPackagesCmd -> Parser (OutputStream, ListPackagesCmd)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ListPackagesCmd
cabalFileFlag)
             String
-> String
-> (((Bool, Bool, Bool), OutputStream) -> RIO Runner ())
-> Parser ((Bool, Bool, Bool), OutputStream)
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
               String
"targets"
               String
"List all targets or pick component types to list."
               ((Bool, Bool, Bool), OutputStream) -> RIO Runner ()
ideTargetsCmd
                 (   (,)
                 ((Bool, Bool, Bool)
 -> OutputStream -> ((Bool, Bool, Bool), OutputStream))
-> Parser (Bool, Bool, Bool)
-> Parser (OutputStream -> ((Bool, Bool, Bool), OutputStream))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,,) (Bool -> Bool -> Bool -> (Bool, Bool, Bool))
-> Parser Bool -> Parser (Bool -> Bool -> (Bool, Bool, Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Bool
exeFlag Parser (Bool -> Bool -> (Bool, Bool, Bool))
-> Parser Bool -> Parser (Bool -> (Bool, Bool, Bool))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
testFlag Parser (Bool -> (Bool, Bool, Bool))
-> Parser Bool -> Parser (Bool, Bool, Bool)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
benchFlag)
                 Parser (OutputStream -> ((Bool, Bool, Bool), OutputStream))
-> Parser OutputStream -> Parser ((Bool, Bool, Bool), OutputStream)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser OutputStream
outputFlag
                 )
    )

  init :: AddCommand
init = String
-> String
-> (InitOpts -> RIO Runner ())
-> Parser InitOpts
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"init"
    String
"Create Stack project configuration from Cabal or Hpack package \
    \specifications."
    InitOpts -> RIO Runner ()
initCmd
    Parser InitOpts
initOptsParser

  install :: AddCommand
install = String
-> String
-> (BuildOptsCLI -> RIO Runner ())
-> Parser BuildOptsCLI
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addBuildCommand'
    String
"install"
    String
"Shortcut for 'build --copy-bins'."
    BuildOptsCLI -> RIO Runner ()
buildCmd
    (BuildCommand -> Parser BuildOptsCLI
buildOptsParser BuildCommand
Install)

  list :: AddCommand
list = String
-> String
-> ([String] -> RIO Runner ())
-> Parser [String]
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"list"
    String
"List package id's in snapshot (experimental)."
    [String] -> RIO Runner ()
listCmd
    (Parser String -> Parser [String]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser String -> Parser [String])
-> Parser String -> Parser [String]
forall a b. (a -> b) -> a -> b
$ Mod ArgumentFields String -> Parser String
forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument (Mod ArgumentFields String -> Parser String)
-> Mod ArgumentFields String -> Parser String
forall a b. (a -> b) -> a -> b
$ String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"PACKAGE")

  ls :: AddCommand
ls = String
-> String
-> (LsCmdOpts -> RIO Runner ())
-> Parser LsCmdOpts
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"ls"
    String
"List command. (Supports snapshots, dependencies, Stack's styles and \
    \installed tools.)"
    LsCmdOpts -> RIO Runner ()
lsCmd
    Parser LsCmdOpts
lsOptsParser

  new :: AddCommand
new = String
-> String
-> ((NewOpts, InitOpts) -> RIO Runner ())
-> Parser (NewOpts, InitOpts)
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"new"
    String
"Create a new project from a template. Run 'stack templates' to see \
    \available templates. Will also initialise if there is no stack.yaml \
    \file. Note: you can also specify a local file or a remote URL as a \
    \template; or force an initialisation."
    (NewOpts, InitOpts) -> RIO Runner ()
newCmd
    Parser (NewOpts, InitOpts)
newOptsParser

  path :: AddCommand
path = String
-> String
-> ([Text] -> RIO Runner ())
-> Parser [Text]
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"path"
    String
"Print out handy path information."
    [Text] -> RIO Runner ()
Stack.Path.path
    Parser [Text]
pathParser

  purge :: AddCommand
purge = String
-> String
-> (CleanOpts -> RIO Runner ())
-> Parser CleanOpts
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"purge"
    String
"Delete the project Stack working directories (.stack-work by \
    \default). Shortcut for 'stack clean --full'."
    CleanOpts -> RIO Runner ()
cleanCmd
    (CleanCommand -> Parser CleanOpts
cleanOptsParser CleanCommand
Purge)

  query :: AddCommand
query = String
-> String
-> ([String] -> RIO Runner ())
-> Parser [String]
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"query"
    String
"Query general build information (experimental)."
    [String] -> RIO Runner ()
queryCmd
    (Parser String -> Parser [String]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser String -> Parser [String])
-> Parser String -> Parser [String]
forall a b. (a -> b) -> a -> b
$ Mod ArgumentFields String -> Parser String
forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument (Mod ArgumentFields String -> Parser String)
-> Mod ArgumentFields String -> Parser String
forall a b. (a -> b) -> a -> b
$ String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"SELECTOR...")

  repl :: AddCommand
repl = String
-> String
-> (GhciOpts -> RIO Runner ())
-> Parser GhciOpts
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addGhciCommand'
    String
"repl"
    String
"Run ghci in the context of package(s) (alias for 'ghci')."
    GhciOpts -> RIO Runner ()
ghciCmd
    Parser GhciOpts
ghciOptsParser

  run :: AddCommand
run = String
-> String
-> (ExecOpts -> RIO Runner ())
-> Parser ExecOpts
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"run"
    String
"Build and run an executable. Defaults to the first available \
    \executable if none is provided as the first argument."
    ExecOpts -> RIO Runner ()
execCmd
    (Maybe SpecialExecCmd -> Parser ExecOpts
execOptsParser (Maybe SpecialExecCmd -> Parser ExecOpts)
-> Maybe SpecialExecCmd -> Parser ExecOpts
forall a b. (a -> b) -> a -> b
$ SpecialExecCmd -> Maybe SpecialExecCmd
forall a. a -> Maybe a
Just SpecialExecCmd
ExecRun)

  runghc :: AddCommand
runghc = String
-> String
-> (ExecOpts -> RIO Runner ())
-> Parser ExecOpts
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"runghc"
    String
"Run runghc."
    ExecOpts -> RIO Runner ()
execCmd
    (Maybe SpecialExecCmd -> Parser ExecOpts
execOptsParser (Maybe SpecialExecCmd -> Parser ExecOpts)
-> Maybe SpecialExecCmd -> Parser ExecOpts
forall a b. (a -> b) -> a -> b
$ SpecialExecCmd -> Maybe SpecialExecCmd
forall a. a -> Maybe a
Just SpecialExecCmd
ExecRunGhc)

  runhaskell :: AddCommand
runhaskell = String
-> String
-> (ExecOpts -> RIO Runner ())
-> Parser ExecOpts
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"runhaskell"
    String
"Run runghc (alias for 'runghc')."
    ExecOpts -> RIO Runner ()
execCmd
    (Maybe SpecialExecCmd -> Parser ExecOpts
execOptsParser (Maybe SpecialExecCmd -> Parser ExecOpts)
-> Maybe SpecialExecCmd -> Parser ExecOpts
forall a b. (a -> b) -> a -> b
$ SpecialExecCmd -> Maybe SpecialExecCmd
forall a. a -> Maybe a
Just SpecialExecCmd
ExecRunGhc)

  script :: AddCommand
script = String
-> String
-> String
-> (ScriptOpts -> RIO Runner ())
-> (ScriptOpts -> GlobalOptsMonoid -> GlobalOptsMonoid)
-> Parser GlobalOptsMonoid
-> Parser ScriptOpts
-> AddCommand
forall opts.
String
-> String
-> String
-> (opts -> RIO Runner ())
-> (opts -> GlobalOptsMonoid -> GlobalOptsMonoid)
-> Parser GlobalOptsMonoid
-> Parser opts
-> AddCommand
addCommand
    String
"script"
    String
"Run a Stack script."
    String
globalFooter
    ScriptOpts -> RIO Runner ()
scriptCmd
    ( \ScriptOpts
so GlobalOptsMonoid
gom ->
        GlobalOptsMonoid
gom
          { globalMonoidResolverRoot :: First String
globalMonoidResolverRoot =
              Maybe String -> First String
forall a. Maybe a -> First a
First (Maybe String -> First String) -> Maybe String -> First String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ScriptOpts -> String
soFile ScriptOpts
so
          }
    )
    (GlobalOptsContext -> Parser GlobalOptsMonoid
globalOpts GlobalOptsContext
OtherCmdGlobalOpts)
    Parser ScriptOpts
scriptOptsParser

  sdist :: AddCommand
sdist = String
-> String
-> (SDistOpts -> RIO Runner ())
-> Parser SDistOpts
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"sdist"
    String
"Create source distribution tarballs."
    SDistOpts -> RIO Runner ()
sdistCmd
    Parser SDistOpts
sdistOptsParser

  setup :: AddCommand
setup = String
-> String
-> (SetupCmdOpts -> RIO Runner ())
-> Parser SetupCmdOpts
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"setup"
    String
"Get the appropriate GHC for your project."
    SetupCmdOpts -> RIO Runner ()
setupCmd
    Parser SetupCmdOpts
setupOptsParser

  templates :: AddCommand
templates = String
-> String -> (() -> RIO Runner ()) -> Parser () -> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"templates"
    String
"Show how to find templates available for 'stack new'. 'stack new' \
    \can accept a template from a remote repository (default: github), \
    \local file or remote URL. Note: this downloads the help file."
    () -> RIO Runner ()
templatesCmd
    (() -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

  test :: AddCommand
test = String
-> String
-> (BuildOptsCLI -> RIO Runner ())
-> Parser BuildOptsCLI
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addBuildCommand'
    String
"test"
    String
"Shortcut for 'build --test'."
    BuildOptsCLI -> RIO Runner ()
buildCmd
    (BuildCommand -> Parser BuildOptsCLI
buildOptsParser BuildCommand
Test)

  uninstall :: AddCommand
uninstall = String
-> String -> (() -> RIO Runner ()) -> Parser () -> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"uninstall"
    String
"Show how to uninstall Stack or a Stack-supplied tool. This command does \
    \not itself uninstall Stack or a Stack-supplied tool."
    () -> RIO Runner ()
uninstallCmd
    (() -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

  unpack :: AddCommand
unpack = String
-> String
-> (([String], Maybe Text) -> RIO Runner ())
-> Parser ([String], Maybe Text)
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"unpack"
    String
"Unpack one or more packages locally."
    ([String], Maybe Text) -> RIO Runner ()
unpackCmd
    ( (,)
        ([String] -> Maybe Text -> ([String], Maybe Text))
-> Parser [String] -> Parser (Maybe Text -> ([String], Maybe Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String -> Parser [String]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Mod ArgumentFields String -> Parser String
forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument (Mod ArgumentFields String -> Parser String)
-> Mod ArgumentFields String -> Parser String
forall a b. (a -> b) -> a -> b
$ String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"PACKAGE")
        Parser (Maybe Text -> ([String], Maybe Text))
-> Parser (Maybe Text) -> Parser ([String], Maybe Text)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text -> Parser (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Mod OptionFields Text -> Parser Text
textOption
              (  String -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"to"
              Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Text
forall (f :: * -> *) a. String -> Mod f a
help String
"Optional path to unpack the package into (will \
                      \unpack into subdirectory)."
              ))
    )

  update :: AddCommand
update = String
-> String -> (() -> RIO Runner ()) -> Parser () -> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"update"
    String
"Update the package index."
    () -> RIO Runner ()
updateCmd
    (() -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

  upgrade :: AddCommand
upgrade = String
-> String
-> (UpgradeOpts -> RIO Runner ())
-> String
-> Parser UpgradeOpts
-> AddCommand
forall a.
String
-> String
-> (a -> RIO Runner ())
-> String
-> Parser a
-> AddCommand
addCommand''
    String
"upgrade"
    String
"Upgrade Stack, installing to Stack's local-bin directory and, if \
    \different and permitted, the directory of the current Stack \
    \executable."
    UpgradeOpts -> RIO Runner ()
upgradeCmd
    String
"Warning: if you use GHCup to install Stack, use only GHCup to \
    \upgrade Stack."
    (Bool -> Parser UpgradeOpts
upgradeOptsParser Bool
onlyLocalBins)
   where
    onlyLocalBins :: Bool
onlyLocalBins =
         (String -> String
lowercase String
progName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> String
lowercase String
stackProgName)
      Bool -> Bool -> Bool
&& Bool -> Bool
not ( Bool
osIsWindows
             Bool -> Bool -> Bool
&& String -> String
lowercase String
progName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String
lowercase (String
stackProgName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".EXE")
             )
    lowercase :: String -> String
lowercase = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower

  upload :: AddCommand
upload = String
-> String
-> (UploadOpts -> RIO Runner ())
-> Parser UploadOpts
-> AddCommand
forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand'
    String
"upload"
    String
"Upload one or more packages, or documentation for one or more packages, \
    \to Hackage."
    UploadOpts -> RIO Runner ()
uploadCmd
    Parser UploadOpts
uploadOptsParser

  -- addCommand hiding global options

  addCommand' ::
       String
    -> String
    -> (a -> RIO Runner ())
    -> Parser a
    -> AddCommand
  addCommand' :: forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addCommand' String
cmd String
title a -> RIO Runner ()
constr =
    String
-> String
-> String
-> (a -> RIO Runner ())
-> (a -> GlobalOptsMonoid -> GlobalOptsMonoid)
-> Parser GlobalOptsMonoid
-> Parser a
-> AddCommand
forall opts.
String
-> String
-> String
-> (opts -> RIO Runner ())
-> (opts -> GlobalOptsMonoid -> GlobalOptsMonoid)
-> Parser GlobalOptsMonoid
-> Parser opts
-> AddCommand
addCommand
      String
cmd
      String
title
      String
globalFooter
      a -> RIO Runner ()
constr
      (\a
_ GlobalOptsMonoid
gom -> GlobalOptsMonoid
gom)
      (GlobalOptsContext -> Parser GlobalOptsMonoid
globalOpts GlobalOptsContext
OtherCmdGlobalOpts)

  -- addCommand with custom footer hiding global options

  addCommand'' ::
       String
    -> String
    -> (a -> RIO Runner ())
    -> String
    -> Parser a
    -> AddCommand
  addCommand'' :: forall a.
String
-> String
-> (a -> RIO Runner ())
-> String
-> Parser a
-> AddCommand
addCommand'' String
cmd String
title a -> RIO Runner ()
constr String
cmdFooter =
    String
-> String
-> String
-> (a -> RIO Runner ())
-> (a -> GlobalOptsMonoid -> GlobalOptsMonoid)
-> Parser GlobalOptsMonoid
-> Parser a
-> AddCommand
forall opts.
String
-> String
-> String
-> (opts -> RIO Runner ())
-> (opts -> GlobalOptsMonoid -> GlobalOptsMonoid)
-> Parser GlobalOptsMonoid
-> Parser opts
-> AddCommand
addCommand
      String
cmd
      String
title
      (String
globalFooter String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cmdFooter)
      a -> RIO Runner ()
constr
      (\a
_ GlobalOptsMonoid
gom -> GlobalOptsMonoid
gom)
      (GlobalOptsContext -> Parser GlobalOptsMonoid
globalOpts GlobalOptsContext
OtherCmdGlobalOpts)

  addSubCommands' ::
       String
    -> String
    -> AddCommand
    -> AddCommand
  addSubCommands' :: String -> String -> AddCommand -> AddCommand
addSubCommands' String
cmd String
title =
    String
-> String
-> String
-> Parser GlobalOptsMonoid
-> AddCommand
-> AddCommand
addSubCommands
      String
cmd
      String
title
      String
globalFooter
      (GlobalOptsContext -> Parser GlobalOptsMonoid
globalOpts GlobalOptsContext
OtherCmdGlobalOpts)

  -- Additional helper that hides global options and shows build options

  addBuildCommand' ::
       String
    -> String
    -> (a -> RIO Runner ())
    -> Parser a
    -> AddCommand
  addBuildCommand' :: forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addBuildCommand' String
cmd String
title a -> RIO Runner ()
constr =
      String
-> String
-> String
-> (a -> RIO Runner ())
-> (a -> GlobalOptsMonoid -> GlobalOptsMonoid)
-> Parser GlobalOptsMonoid
-> Parser a
-> AddCommand
forall opts.
String
-> String
-> String
-> (opts -> RIO Runner ())
-> (opts -> GlobalOptsMonoid -> GlobalOptsMonoid)
-> Parser GlobalOptsMonoid
-> Parser opts
-> AddCommand
addCommand
        String
cmd
        String
title
        String
globalFooter
        a -> RIO Runner ()
constr
        (\a
_ GlobalOptsMonoid
gom -> GlobalOptsMonoid
gom)
        (GlobalOptsContext -> Parser GlobalOptsMonoid
globalOpts GlobalOptsContext
BuildCmdGlobalOpts)

  -- Additional helper that hides global options and shows some ghci options

  addGhciCommand' ::
       String
    -> String
    -> (a -> RIO Runner ())
    -> Parser a
    -> AddCommand
  addGhciCommand' :: forall a.
String -> String -> (a -> RIO Runner ()) -> Parser a -> AddCommand
addGhciCommand' String
cmd String
title a -> RIO Runner ()
constr =
      String
-> String
-> String
-> (a -> RIO Runner ())
-> (a -> GlobalOptsMonoid -> GlobalOptsMonoid)
-> Parser GlobalOptsMonoid
-> Parser a
-> AddCommand
forall opts.
String
-> String
-> String
-> (opts -> RIO Runner ())
-> (opts -> GlobalOptsMonoid -> GlobalOptsMonoid)
-> Parser GlobalOptsMonoid
-> Parser opts
-> AddCommand
addCommand
        String
cmd
        String
title
        String
globalFooter
        a -> RIO Runner ()
constr
        (\a
_ GlobalOptsMonoid
gom -> GlobalOptsMonoid
gom)
        (GlobalOptsContext -> Parser GlobalOptsMonoid
globalOpts GlobalOptsContext
GhciCmdGlobalOpts)

  globalOpts :: GlobalOptsContext -> Parser GlobalOptsMonoid
  globalOpts :: GlobalOptsContext -> Parser GlobalOptsMonoid
globalOpts GlobalOptsContext
kind =
        Bool
-> String
-> String
-> String
-> Parser
     ((GlobalOptsMonoid -> GlobalOptsMonoid)
      -> GlobalOptsMonoid -> GlobalOptsMonoid)
forall a. Bool -> String -> String -> String -> Parser (a -> a)
extraHelpOption
          Bool
hide
          String
progName
          (String
dockerCmdName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"*")
          String
dockerHelpOptName
    Parser
  ((GlobalOptsMonoid -> GlobalOptsMonoid)
   -> GlobalOptsMonoid -> GlobalOptsMonoid)
-> Parser (GlobalOptsMonoid -> GlobalOptsMonoid)
-> Parser (GlobalOptsMonoid -> GlobalOptsMonoid)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool
-> String
-> String
-> String
-> Parser (GlobalOptsMonoid -> GlobalOptsMonoid)
forall a. Bool -> String -> String -> String -> Parser (a -> a)
extraHelpOption
          Bool
hide
          String
progName
          (String
Nix.nixCmdName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"*")
          String
Nix.nixHelpOptName
    Parser (GlobalOptsMonoid -> GlobalOptsMonoid)
-> Parser GlobalOptsMonoid -> Parser 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 -> GlobalOptsContext -> Parser GlobalOptsMonoid
globalOptsParser String
currentDir GlobalOptsContext
kind
   where
    hide :: Bool
hide = GlobalOptsContext
kind GlobalOptsContext -> GlobalOptsContext -> Bool
forall a. Eq a => a -> a -> Bool
/= GlobalOptsContext
OuterGlobalOpts

-- | fall-through to external executables in `git` style if they exist

-- (i.e. `stack something` looks for `stack-something` before

-- failing with "Invalid argument `something'")

secondaryCommandHandler ::
     [String]
  -> ParserFailure ParserHelp
  -> IO (ParserFailure ParserHelp)
secondaryCommandHandler :: [String]
-> ParserFailure ParserHelp -> IO (ParserFailure ParserHelp)
secondaryCommandHandler [String]
args ParserFailure ParserHelp
f =
  -- don't even try when the argument looks like a path or flag

  if Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
pathSeparator String
cmd Bool -> Bool -> Bool
|| String
"-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` [String] -> String
forall a. HasCallStack => [a] -> a
L.head [String]
args
     then ParserFailure ParserHelp -> IO (ParserFailure ParserHelp)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParserFailure ParserHelp
f
  else do
    Maybe String
mExternalExec <- String -> IO (Maybe String)
D.findExecutable String
cmd
    case Maybe String
mExternalExec of
      Just String
ex -> RIO LoggedProcessContext (ParserFailure ParserHelp)
-> IO (ParserFailure ParserHelp)
forall (m :: * -> *) a.
MonadIO m =>
RIO LoggedProcessContext a -> m a
withProcessContextNoLogging (RIO LoggedProcessContext (ParserFailure ParserHelp)
 -> IO (ParserFailure ParserHelp))
-> RIO LoggedProcessContext (ParserFailure ParserHelp)
-> IO (ParserFailure ParserHelp)
forall a b. (a -> b) -> a -> b
$ do
        -- TODO show the command in verbose mode

        -- hPutStrLn stderr $ unwords $

        --   ["Running", "[" ++ ex, unwords (tail args) ++ "]"]

        Any
_ <- String -> [String] -> RIO LoggedProcessContext Any
forall env b.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env b
RIO.Process.exec String
ex ([String] -> [String]
forall a. HasCallStack => [a] -> [a]
L.tail [String]
args)
        ParserFailure ParserHelp
-> RIO LoggedProcessContext (ParserFailure ParserHelp)
forall a. a -> RIO LoggedProcessContext a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParserFailure ParserHelp
f
      Maybe String
Nothing -> ParserFailure ParserHelp -> IO (ParserFailure ParserHelp)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserFailure ParserHelp -> IO (ParserFailure ParserHelp))
-> ParserFailure ParserHelp -> IO (ParserFailure ParserHelp)
forall a b. (a -> b) -> a -> b
$ (ParserHelp -> ParserHelp)
-> ParserFailure ParserHelp -> ParserFailure ParserHelp
forall a b. (a -> b) -> ParserFailure a -> ParserFailure b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ParserHelp -> ParserHelp -> ParserHelp
vcatErrorHelp (String -> ParserHelp
noSuchCmd String
cmd)) ParserFailure ParserHelp
f
 where
  -- FIXME this is broken when any options are specified before the command

  -- e.g. stack --verbosity silent cmd

  cmd :: String
cmd = String
stackProgName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. HasCallStack => [a] -> a
L.head [String]
args
  noSuchCmd :: String -> ParserHelp
noSuchCmd String
name = Chunk Doc -> ParserHelp
errorHelp (Chunk Doc -> ParserHelp) -> Chunk Doc -> ParserHelp
forall a b. (a -> b) -> a -> b
$ String -> Chunk Doc
stringChunk
    (String
"Auxiliary command not found in path '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'.")

interpreterHandler ::
     Monoid t
  => FilePath
  -> [String]
  -> ParserFailure ParserHelp
  -> IO (GlobalOptsMonoid, (RIO Runner (), t))
interpreterHandler :: forall t.
Monoid t =>
String
-> [String]
-> ParserFailure ParserHelp
-> IO (GlobalOptsMonoid, (RIO Runner (), t))
interpreterHandler String
currentDir [String]
args ParserFailure ParserHelp
f = do
  -- args can include top-level config such as --extra-lib-dirs=... (set by

  -- nix-shell) - we need to find the first argument which is a file, everything

  -- afterwards is an argument to the script, everything before is an argument

  -- to Stack

  ([String]
stackArgs, [String]
fileArgs) <- (String -> IO Bool) -> [String] -> IO ([String], [String])
forall {f :: * -> *} {a}.
Monad f =>
(a -> f Bool) -> [a] -> f ([a], [a])
spanM ((Bool -> Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (IO Bool -> IO Bool) -> (String -> IO Bool) -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Bool
D.doesFileExist) [String]
args
  case [String]
fileArgs of
    (String
file:[String]
fileArgs') -> String
-> [String]
-> [String]
-> IO (GlobalOptsMonoid, (RIO Runner (), t))
forall {b}.
Monoid b =>
String
-> [String]
-> [String]
-> IO (GlobalOptsMonoid, (RIO Runner (), b))
runInterpreterCommand String
file [String]
stackArgs [String]
fileArgs'
    [] -> (ParserHelp -> ParserHelp)
-> IO (GlobalOptsMonoid, (RIO Runner (), t))
forall {a}. (ParserHelp -> ParserHelp) -> IO a
parseResultHandler (ParserHelp -> ParserHelp -> ParserHelp
errorCombine (String -> ParserHelp
noSuchFile String
firstArg))
 where
  firstArg :: String
firstArg = [String] -> String
forall a. HasCallStack => [a] -> a
L.head [String]
args

  spanM :: (a -> f Bool) -> [a] -> f ([a], [a])
spanM a -> f Bool
_ [] = ([a], [a]) -> f ([a], [a])
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
  spanM a -> f Bool
p xs :: [a]
xs@(a
x:[a]
xs') = do
    Bool
r <- a -> f Bool
p a
x
    if Bool
r
    then do
      ([a]
ys, [a]
zs) <- (a -> f Bool) -> [a] -> f ([a], [a])
spanM a -> f Bool
p [a]
xs'
      ([a], [a]) -> f ([a], [a])
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys, [a]
zs)
    else
      ([a], [a]) -> f ([a], [a])
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [a]
xs)

  -- if the first argument contains a path separator then it might be a file,

  -- or a Stack option referencing a file. In that case we only show the

  -- interpreter error message and exclude the command related error messages.

  errorCombine :: ParserHelp -> ParserHelp -> ParserHelp
errorCombine =
    if Char
pathSeparator Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
firstArg
    then ParserHelp -> ParserHelp -> ParserHelp
overrideErrorHelp
    else ParserHelp -> ParserHelp -> ParserHelp
vcatErrorHelp

  overrideErrorHelp :: ParserHelp -> ParserHelp -> ParserHelp
overrideErrorHelp ParserHelp
h1 ParserHelp
h2 = ParserHelp
h2 { helpError :: Chunk Doc
helpError = ParserHelp -> Chunk Doc
helpError ParserHelp
h1 }

  parseResultHandler :: (ParserHelp -> ParserHelp) -> IO a
parseResultHandler ParserHelp -> ParserHelp
fn = ParserResult a -> IO a
forall a. ParserResult a -> IO a
handleParseResult ((ParserHelp -> ParserHelp) -> ParserResult a -> ParserResult a
forall a.
(ParserHelp -> ParserHelp) -> ParserResult a -> ParserResult a
overFailure ParserHelp -> ParserHelp
fn (ParserFailure ParserHelp -> ParserResult a
forall a. ParserFailure ParserHelp -> ParserResult a
Failure ParserFailure ParserHelp
f))
  noSuchFile :: String -> ParserHelp
noSuchFile String
name = Chunk Doc -> ParserHelp
errorHelp (Chunk Doc -> ParserHelp) -> Chunk Doc -> ParserHelp
forall a b. (a -> b) -> a -> b
$ String -> Chunk Doc
stringChunk
    (String
"File does not exist or is not a regular file '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'.")

  runInterpreterCommand :: String
-> [String]
-> [String]
-> IO (GlobalOptsMonoid, (RIO Runner (), b))
runInterpreterCommand String
path [String]
stackArgs [String]
fileArgs = do
    String
progName <- IO String
getProgName
    [String]
iargs <- String -> IO [String]
getInterpreterArgs String
path
    let parseCmdLine :: IO (GlobalOptsMonoid, RIO Runner ())
parseCmdLine = String -> String -> Bool -> IO (GlobalOptsMonoid, RIO Runner ())
commandLineHandler String
currentDir String
progName Bool
True
        -- Implicit file arguments are put before other arguments that

        -- occur after "--". See #3658

        cmdArgs :: [String]
cmdArgs = [String]
stackArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ case (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"--") [String]
iargs of
          ([String]
beforeSep, []) -> [String]
beforeSep [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
path] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
fileArgs
          ([String]
beforeSep, String
optSep : [String]
afterSep) ->
            [String]
beforeSep [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
optSep] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
path] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
fileArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
afterSep
     -- TODO show the command in verbose mode

     -- hPutStrLn stderr $ unwords $

     --   ["Running", "[" ++ progName, unwords cmdArgs ++ "]"]

    (GlobalOptsMonoid
a,RIO Runner ()
b) <- [String]
-> IO (GlobalOptsMonoid, RIO Runner ())
-> IO (GlobalOptsMonoid, RIO Runner ())
forall a. [String] -> IO a -> IO a
withArgs [String]
cmdArgs IO (GlobalOptsMonoid, RIO Runner ())
parseCmdLine
    (GlobalOptsMonoid, (RIO Runner (), b))
-> IO (GlobalOptsMonoid, (RIO Runner (), b))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GlobalOptsMonoid
a,(RIO Runner ()
b,b
forall a. Monoid a => a
mempty))

-- Vertically combine only the error component of the first argument with the

-- error component of the second.

vcatErrorHelp :: ParserHelp -> ParserHelp -> ParserHelp
vcatErrorHelp :: ParserHelp -> ParserHelp -> ParserHelp
vcatErrorHelp ParserHelp
h1 ParserHelp
h2 = ParserHelp
h2 { helpError :: Chunk Doc
helpError = [Chunk Doc] -> Chunk Doc
vcatChunks [ParserHelp -> Chunk Doc
helpError ParserHelp
h2, ParserHelp -> Chunk Doc
helpError ParserHelp
h1] }