CLI.hs

{-# 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 currentDir progName 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.
  first (<> defaultGlobalOpts) <$> complicatedOptions
    stackVersion
    (Just versionString')
    hpackVersion
    "stack - The Haskell Tool Stack"
    ""
    ("Stack's documentation is available at https://docs.haskellstack.org/. \
    \Command '" <> progName <> " COMMAND --help' for help about a Stack command. Stack also \
    \supports the Haskell Error Index at https://errors.haskell.org/.")
    (globalOpts OuterGlobalOpts)
    (Just failureCallback)
    addCommands
 where
  defaultGlobalOpts = if isInterpreter
    then
      -- Silent except when errors occur - see #2879
      mempty { globalMonoidLogLevel = First (Just LevelError) }
    else mempty
  failureCallback f args =
    case L.stripPrefix "Invalid argument" (fst (renderFailure f "")) of
      Just _ -> if isInterpreter
                  then parseResultHandler args f
                  else secondaryCommandHandler args f
                      >>= interpreterHandler currentDir args
      Nothing -> parseResultHandler args f

  parseResultHandler args f =
    if isInterpreter
    then do
      let hlp = errorHelp $ stringChunk
            (unwords ["Error executing interpreter command:"
                      , progName
                      , unwords args])
      handleParseResult (overFailure (vcatErrorHelp hlp) (Failure f))
    else handleParseResult (Failure f)

  -- The order of commands below determines the order in which they are listed
  -- in `stack --help`.
  addCommands = do
    unless isInterpreter $ do
      build
      install
      uninstall
      test
      bench
      haddock
      new
      templates
      init
      setup
      path
      ls
      unpack
      update
      upgrade
      upload
      sdist
      dot
      ghc
      hoogle
    -- These are the only commands allowed in interpreter mode as well
    exec
    run
    ghci
    repl
    runghc
    runhaskell
    script
    unless isInterpreter $ do
      eval
      clean
      purge
      query
      list
      ide
      docker
      config
      hpc

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

  bench = addBuildCommand'
    "bench"
    "Shortcut for 'build --bench'."
    buildCmd
    (buildOptsParser Bench)

  build = addBuildCommand'
    "build"
    "Build the package(s) in this directory/configuration."
    buildCmd
    (buildOptsParser Build)

  clean = addCommand'
    "clean"
    "Delete build artefacts for the project packages."
    cleanCmd
    (cleanOptsParser Clean)

  config = addSubCommands'
      ConfigCmd.cfgCmdName
        "Subcommands for accessing and modifying configuration values."
        ( do
            addCommand'
              ConfigCmd.cfgCmdSetName
              "Sets a key in YAML configuration file to value."
              (withConfig NoReexec . cfgCmdSet)
              configCmdSetParser
            addCommand'
              ConfigCmd.cfgCmdEnvName
              "Print environment variables for use in a shell."
              (withConfig YesReexec . withDefaultEnvConfig . cfgCmdEnv)
              configCmdEnvParser
        )

  docker = addSubCommands'
    dockerCmdName
    "Subcommands specific to Docker use."
    ( do
        addCommand'
          dockerPullCmdName
          "Pull latest version of Docker image from registry."
          dockerPullCmd
          (pure ())
        addCommand'
          "reset"
          "Reset the Docker sandbox."
          dockerResetCmd
          ( switch
              (  long "keep-home"
              <> help "Do not delete sandbox's home directory."
              )
          )
    )

  dot = addCommand'
    "dot"
    "Visualize your project's dependency graph using Graphviz dot."
    Stack.Dot.dot
    (dotOptsParser False) -- Default for --external is False.

  eval = addCommand'
    "eval"
    "Evaluate some Haskell code inline. Shortcut for \
    \'stack exec ghc -- -e CODE'."
    evalCmd
    (evalOptsParser "CODE")

  exec = addCommand'
    "exec"
    "Execute a command. If the command is absent, the first of any arguments \
    \is taken as the command."
    execCmd
    (execOptsParser Nothing)

  ghc = addCommand'
    "ghc"
    "Run ghc."
    execCmd
    (execOptsParser $ Just ExecGhc)

  ghci = addGhciCommand'
    "ghci"
    "Run ghci in the context of package(s)."
    ghciCmd
    ghciOptsParser

  haddock = addBuildCommand'
    "haddock"
    "Shortcut for 'build --haddock'."
    buildCmd
    (buildOptsParser Haddock)

  hoogle = addCommand'
    "hoogle"
    "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'."
    hoogleCmd
    ( (,,,)
        <$> many (strArgument
              ( metavar "-- ARGUMENT(S) (e.g. 'stack hoogle -- server --local')"
              ))
        <*> boolFlags
              True
              "setup"
              "If needed: install Hoogle, build Haddock documentation and \
              \generate a Hoogle database."
              idm
        <*> switch
              (  long "rebuild"
              <> help "Rebuild the Hoogle database."
              )
        <*> switch
              (  long "server"
              <> help "Start local Hoogle server."
              )
      )

  hpc = addSubCommands'
    "hpc"
    "Subcommands specific to Haskell Program Coverage."
    ( addCommand'
        "report"
        "Generate unified HPC coverage report from tix files and project \
        \targets."
        hpcReportCmd
        hpcReportOptsParser
    )

  ide = addSubCommands'
    "ide"
    "IDE-specific commands."
    ( let outputFlag = flag
            OutputLogInfo
            OutputStdout
            (  long "stdout"
            <> help "Send output to the standard output stream instead of the \
                    \default, the standard error stream."
            )
          cabalFileFlag = flag
            ListPackageNames
            ListPackageCabalFiles
            (  long "cabal-files"
            <> help "Print paths to package Cabal files instead of package \
                    \names."
            )
          exeFlag = switch
            (  long "exes"
            <> help "Include executables."
            )
          testFlag = switch
            (  long "tests"
            <> help "Include test suites."
            )
          benchFlag = switch
            (  long "benchmarks"
            <> help "Include benchmarks."
            )
       in  do
             addCommand'
               "packages"
               "List all available local loadable packages."
               idePackagesCmd
               ((,) <$> outputFlag <*> cabalFileFlag)
             addCommand'
               "targets"
               "List all targets or pick component types to list."
               ideTargetsCmd
                 (   (,)
                 <$> ((,,) <$> exeFlag <*> testFlag <*> benchFlag)
                 <*> outputFlag
                 )
    )

  init = addCommand'
    "init"
    "Create Stack project configuration from Cabal or Hpack package \
    \specifications."
    initCmd
    initOptsParser

  install = addBuildCommand'
    "install"
    "Shortcut for 'build --copy-bins'."
    buildCmd
    (buildOptsParser Install)

  list = addCommand'
    "list"
    "List package id's in snapshot (experimental)."
    listCmd
    (many $ strArgument $ metavar "PACKAGE")

  ls = addCommand'
    "ls"
    "List command. (Supports snapshots, dependencies, Stack's styles and \
    \installed tools.)"
    lsCmd
    lsOptsParser

  new = addCommand'
    "new"
    "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."
    newCmd
    newOptsParser

  path = addCommand'
    "path"
    "Print out handy path information."
    Stack.Path.path
    pathParser

  purge = addCommand'
    "purge"
    "Delete the project Stack working directories (.stack-work by \
    \default). Shortcut for 'stack clean --full'."
    cleanCmd
    (cleanOptsParser Purge)

  query = addCommand'
    "query"
    "Query general build information (experimental)."
    queryCmd
    (many $ strArgument $ metavar "SELECTOR...")

  repl = addGhciCommand'
    "repl"
    "Run ghci in the context of package(s) (alias for 'ghci')."
    ghciCmd
    ghciOptsParser

  run = addCommand'
    "run"
    "Build and run an executable. Defaults to the first available \
    \executable if none is provided as the first argument."
    execCmd
    (execOptsParser $ Just ExecRun)

  runghc = addCommand'
    "runghc"
    "Run runghc."
    execCmd
    (execOptsParser $ Just ExecRunGhc)

  runhaskell = addCommand'
    "runhaskell"
    "Run runghc (alias for 'runghc')."
    execCmd
    (execOptsParser $ Just ExecRunGhc)

  script = addCommand
    "script"
    "Run a Stack script."
    globalFooter
    scriptCmd
    ( \so gom ->
        gom
          { globalMonoidResolverRoot =
              First $ Just $ takeDirectory $ soFile so
          }
    )
    (globalOpts OtherCmdGlobalOpts)
    scriptOptsParser

  sdist = addCommand'
    "sdist"
    "Create source distribution tarballs."
    sdistCmd
    sdistOptsParser

  setup = addCommand'
    "setup"
    "Get the appropriate GHC for your project."
    setupCmd
    setupOptsParser

  templates = addCommand'
    "templates"
    "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."
    templatesCmd
    (pure ())

  test = addBuildCommand'
    "test"
    "Shortcut for 'build --test'."
    buildCmd
    (buildOptsParser Test)

  uninstall = addCommand'
    "uninstall"
    "Show how to uninstall Stack or a Stack-supplied tool. This command does \
    \not itself uninstall Stack or a Stack-supplied tool."
    uninstallCmd
    (pure ())

  unpack = addCommand'
    "unpack"
    "Unpack one or more packages locally."
    unpackCmd
    ( (,)
        <$> some (strArgument $ metavar "PACKAGE")
        <*> optional (textOption
              (  long "to"
              <> help "Optional path to unpack the package into (will \
                      \unpack into subdirectory)."
              ))
    )

  update = addCommand'
    "update"
    "Update the package index."
    updateCmd
    (pure ())

  upgrade = addCommand''
    "upgrade"
    "Upgrade Stack, installing to Stack's local-bin directory and, if \
    \different and permitted, the directory of the current Stack \
    \executable."
    upgradeCmd
    "Warning: if you use GHCup to install Stack, use only GHCup to \
    \upgrade Stack."
    (upgradeOptsParser onlyLocalBins)
   where
    onlyLocalBins =
         (lowercase progName /= lowercase stackProgName)
      && not ( osIsWindows
             && lowercase progName == lowercase (stackProgName <> ".EXE")
             )
    lowercase = map toLower

  upload = addCommand'
    "upload"
    "Upload a package to Hackage."
    uploadCmd
    uploadOptsParser

  -- addCommand hiding global options
  addCommand' ::
       String
    -> String
    -> (a -> RIO Runner ())
    -> Parser a
    -> AddCommand
  addCommand' cmd title constr =
    addCommand
      cmd
      title
      globalFooter
      constr
      (\_ gom -> gom)
      (globalOpts OtherCmdGlobalOpts)

  -- addCommand with custom footer hiding global options
  addCommand'' ::
       String
    -> String
    -> (a -> RIO Runner ())
    -> String
    -> Parser a
    -> AddCommand
  addCommand'' cmd title constr cmdFooter =
    addCommand
      cmd
      title
      (globalFooter <> " " <> cmdFooter)
      constr
      (\_ gom -> gom)
      (globalOpts OtherCmdGlobalOpts)

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

  -- Additional helper that hides global options and shows build options
  addBuildCommand' ::
       String
    -> String
    -> (a -> RIO Runner ())
    -> Parser a
    -> AddCommand
  addBuildCommand' cmd title constr =
      addCommand
        cmd
        title
        globalFooter
        constr
        (\_ gom -> gom)
        (globalOpts BuildCmdGlobalOpts)

  -- Additional helper that hides global options and shows some ghci options
  addGhciCommand' ::
       String
    -> String
    -> (a -> RIO Runner ())
    -> Parser a
    -> AddCommand
  addGhciCommand' cmd title constr =
      addCommand
        cmd
        title
        globalFooter
        constr
        (\_ gom -> gom)
        (globalOpts GhciCmdGlobalOpts)

  globalOpts :: GlobalOptsContext -> Parser GlobalOptsMonoid
  globalOpts kind =
        extraHelpOption
          hide
          progName
          (dockerCmdName ++ "*")
          dockerHelpOptName
    <*> extraHelpOption
          hide
          progName
          (Nix.nixCmdName ++ "*")
          Nix.nixHelpOptName
    <*> globalOptsParser currentDir kind
   where
    hide = kind /= 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 args f =
  -- don't even try when the argument looks like a path or flag
  if elem pathSeparator cmd || "-" `L.isPrefixOf` L.head args
     then pure f
  else do
    mExternalExec <- D.findExecutable cmd
    case mExternalExec of
      Just ex -> withProcessContextNoLogging $ do
        -- TODO show the command in verbose mode
        -- hPutStrLn stderr $ unwords $
        --   ["Running", "[" ++ ex, unwords (tail args) ++ "]"]
        _ <- RIO.Process.exec ex (L.tail args)
        pure f
      Nothing -> pure $ fmap (vcatErrorHelp (noSuchCmd cmd)) f
 where
  -- FIXME this is broken when any options are specified before the command
  -- e.g. stack --verbosity silent cmd
  cmd = stackProgName ++ "-" ++ L.head args
  noSuchCmd name = errorHelp $ stringChunk
    ("Auxiliary command not found in path '" ++ name ++ "'.")

interpreterHandler ::
     Monoid t
  => FilePath
  -> [String]
  -> ParserFailure ParserHelp
  -> IO (GlobalOptsMonoid, (RIO Runner (), t))
interpreterHandler currentDir args 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
  (stackArgs, fileArgs) <- spanM (fmap not . D.doesFileExist) args
  case fileArgs of
    (file:fileArgs') -> runInterpreterCommand file stackArgs fileArgs'
    [] -> parseResultHandler (errorCombine (noSuchFile firstArg))
 where
  firstArg = L.head args

  spanM _ [] = pure ([], [])
  spanM p xs@(x:xs') = do
    r <- p x
    if r
    then do
      (ys, zs) <- spanM p xs'
      pure (x:ys, zs)
    else
      pure ([], 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 =
    if pathSeparator `elem` firstArg
    then overrideErrorHelp
    else vcatErrorHelp

  overrideErrorHelp h1 h2 = h2 { helpError = helpError h1 }

  parseResultHandler fn = handleParseResult (overFailure fn (Failure f))
  noSuchFile name = errorHelp $ stringChunk
    ("File does not exist or is not a regular file '" ++ name ++ "'.")

  runInterpreterCommand path stackArgs fileArgs = do
    progName <- getProgName
    iargs <- getInterpreterArgs path
    let parseCmdLine = commandLineHandler currentDir progName True
        -- Implicit file arguments are put before other arguments that
        -- occur after "--". See #3658
        cmdArgs = stackArgs ++ case break (== "--") iargs of
          (beforeSep, []) -> beforeSep ++ ["--"] ++ [path] ++ fileArgs
          (beforeSep, optSep : afterSep) ->
            beforeSep ++ [optSep] ++ [path] ++ fileArgs ++ afterSep
     -- TODO show the command in verbose mode
     -- hPutStrLn stderr $ unwords $
     --   ["Running", "[" ++ progName, unwords cmdArgs ++ "]"]
    (a,b) <- withArgs cmdArgs parseCmdLine
    pure (a,(b,mempty))

-- Vertically combine only the error component of the first argument with the
-- error component of the second.
vcatErrorHelp :: ParserHelp -> ParserHelp -> ParserHelp
vcatErrorHelp h1 h2 = h2 { helpError = vcatChunks [helpError h2, helpError h1] }