Main.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Main
-- Copyright   :  (c) David Himmelstrup 2005
-- License     :  BSD-like
--
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-- Entry point to the default cabal-install front-end.
--
-- @since 3.10.0.0
-----------------------------------------------------------------------------

module Distribution.Client.Main (main) where

import Distribution.Client.Setup
         ( GlobalFlags(..), globalCommand, withRepoContext
         , ConfigFlags(..)
         , ConfigExFlags(..), defaultConfigExFlags, configureExCommand
         , reconfigureCommand
         , configCompilerAux', configPackageDB'
         , BuildFlags(..)
         , buildCommand, replCommand, testCommand, benchmarkCommand
         , InstallFlags(..), defaultInstallFlags
         , installCommand
         , FetchFlags(..), fetchCommand
         , FreezeFlags(..), freezeCommand
         , genBoundsCommand
         , GetFlags(..), getCommand, unpackCommand
         , checkCommand
         , formatCommand
         , ListFlags(..), listCommand, listNeedsCompiler
         , InfoFlags(..), infoCommand
         , UploadFlags(..), uploadCommand
         , ReportFlags(..), reportCommand
         , runCommand
         , InitFlags(initVerbosity, initHcPath), initCommand
         , ActAsSetupFlags(..), actAsSetupCommand
         , UserConfigFlags(..), userConfigCommand
         , reportCommand
         , manpageCommand
         , haddockCommand
         , cleanCommand
         , copyCommand
         , registerCommand
         )
import Distribution.Simple.Setup
         ( HaddockTarget(..)
         , HaddockFlags(..), defaultHaddockFlags
         , HscolourFlags(..), hscolourCommand
         , ReplFlags(..)
         , CopyFlags(..)
         , RegisterFlags(..)
         , CleanFlags(..)
         , TestFlags(..), BenchmarkFlags(..)
         , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag
         , configAbsolutePaths
         )

import Prelude ()
import Distribution.Client.Compat.Prelude hiding (get)

import Distribution.Client.SetupWrapper
         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
import Distribution.Client.Config
         ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff
         , userConfigUpdate, createDefaultConfigFile, getConfigFilePath )
import Distribution.Client.Targets
         ( readUserTargets )
import qualified Distribution.Client.List as List
         ( list, info )

import qualified Distribution.Client.CmdConfigure as CmdConfigure
import qualified Distribution.Client.CmdUpdate    as CmdUpdate
import qualified Distribution.Client.CmdBuild     as CmdBuild
import qualified Distribution.Client.CmdRepl      as CmdRepl
import qualified Distribution.Client.CmdFreeze    as CmdFreeze
import qualified Distribution.Client.CmdHaddock   as CmdHaddock
import qualified Distribution.Client.CmdHaddockProject as CmdHaddockProject
import qualified Distribution.Client.CmdInstall   as CmdInstall
import qualified Distribution.Client.CmdRun       as CmdRun
import qualified Distribution.Client.CmdTest      as CmdTest
import qualified Distribution.Client.CmdBench     as CmdBench
import qualified Distribution.Client.CmdExec      as CmdExec
import qualified Distribution.Client.CmdClean     as CmdClean
import qualified Distribution.Client.CmdSdist     as CmdSdist
import qualified Distribution.Client.CmdListBin   as CmdListBin
import qualified Distribution.Client.CmdOutdated  as CmdOutdated
import           Distribution.Client.CmdLegacy

import Distribution.Client.Install            (install)
import Distribution.Client.Configure          (configure, writeConfigFlags)
import Distribution.Client.Fetch              (fetch)
import Distribution.Client.Freeze             (freeze)
import Distribution.Client.GenBounds          (genBounds)
import Distribution.Client.Check as Check     (check)
--import Distribution.Client.Clean            (clean)
import qualified Distribution.Client.Upload as Upload
import Distribution.Client.Run                (run, splitRunArgs)
import Distribution.Client.Get                (get)
import Distribution.Client.Reconfigure        (Check(..), reconfigure)
import Distribution.Client.Nix                (nixInstantiate
                                              ,nixShell
                                              )
import Distribution.Client.Sandbox            (loadConfigOrSandboxConfig
                                              ,findSavedDistPref
                                              ,updateInstallDirs)
import Distribution.Client.Tar                (createTarGzFile)
import Distribution.Client.Types.Credentials  (Password (..))
import Distribution.Client.Init               (initCmd)
import Distribution.Client.Manpage            (manpageCmd)
import Distribution.Client.ManpageFlags       (ManpageFlags (..))
import Distribution.Client.Utils
         ( determineNumJobs, relaxEncodingErrors )
import Distribution.Client.Signal
         ( installTerminationHandler )
import Distribution.Client.Version
         ( cabalInstallVersion )

import Distribution.Package (packageId)
import Distribution.PackageDescription
         ( BuildType(..), Executable(..), buildable )

import Distribution.PackageDescription.PrettyPrint
         ( writeGenericPackageDescription )
import qualified Distribution.Simple as Simple
import qualified Distribution.Make as Make
import qualified Distribution.Types.UnqualComponentName as Make
import Distribution.Simple.Build
         ( startInterpreter )
import Distribution.Simple.Command
         ( CommandParse(..), CommandUI(..), Command, CommandSpec(..)
         , CommandType(..), commandsRun, commandAddAction, hiddenCommand
         , commandFromSpec, commandShowOptions )
import Distribution.Simple.Compiler (PackageDBStack)
import Distribution.Simple.Configure
         ( configCompilerAuxEx, ConfigStateFileError(..)
         , getPersistBuildConfig, interpretPackageDbFlags
         , tryGetPersistBuildConfig )
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.PackageDescription ( readGenericPackageDescription )
import Distribution.Simple.Program (defaultProgramDb
                                   ,configureAllKnownPrograms
                                   ,simpleProgramInvocation
                                   ,getProgramInvocationOutput)
import Distribution.Simple.Program.Db (reconfigurePrograms)
import qualified Distribution.Simple.Setup as Cabal
import Distribution.Simple.Utils
         ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler
         , findPackageDesc, tryFindPackageDesc, createDirectoryIfMissingVerbose )
import Distribution.Text
         ( display )
import Distribution.Verbosity as Verbosity
         ( normal )
import Distribution.Version
         ( Version, mkVersion, orLaterVersion )

import Distribution.Compat.ResponseFile
import System.Environment       (getProgName)
import System.FilePath          ( dropExtension, splitExtension
                                , takeExtension, (</>), (<.>) )
import System.IO                ( BufferMode(LineBuffering), hSetBuffering
                                , hPutStrLn, stderr, stdout )
import System.Directory         ( doesFileExist, getCurrentDirectory
                                , withCurrentDirectory)
import Data.Monoid              (Any(..))
import Control.Exception        (AssertionFailed, assert, try)


-- | Entry point
--
main :: [String] -> IO ()
main args = do
  installTerminationHandler
  -- Enable line buffering so that we can get fast feedback even when piped.
  -- This is especially important for CI and build systems.
  hSetBuffering stdout LineBuffering

  -- If the locale encoding for CLI doesn't support all Unicode characters,
  -- printing to it may fail unless we relax the handling of encoding errors
  -- when writing to stderr and stdout.
  relaxEncodingErrors stdout
  relaxEncodingErrors stderr
  let (args0, args1) = break (== "--") args

  mainWorker =<< (++ args1) <$> expandResponse args0

-- | Check whether assertions are enabled and print a warning in that case.
warnIfAssertionsAreEnabled :: IO ()
warnIfAssertionsAreEnabled =
  assert False (return ()) `catch`
  (\(_e :: AssertionFailed) -> hPutStrLn stderr assertionsEnabledMsg)
    -- Andreas, 2022-12-30, issue #8654:
    -- The verbosity machinery is not in place at this point (option -v not parsed),
    -- so instead of using function @warn@, we print straight to stderr.
  where
    assertionsEnabledMsg =
      "Warning: this is a debug build of cabal-install with assertions enabled."

mainWorker :: [String] -> IO ()
mainWorker args = do
  topHandler $
    case commandsRun (globalCommand commands) commands args of
      CommandHelp   help                 -> printGlobalHelp help
      CommandList   opts                 -> printOptionsList opts
      CommandErrors errs                 -> printErrors errs
      CommandReadyToGo (globalFlags, commandParse)  ->
        case commandParse of
          _ | fromFlagOrDefault False (globalVersion globalFlags)
              -> printVersion
            | fromFlagOrDefault False (globalNumericVersion globalFlags)
              -> printNumericVersion
          CommandHelp     help           -> printCommandHelp help
          CommandList     opts           -> printOptionsList opts

          CommandErrors   errs           -> do
            -- Check whether cabal is called from a script, like #!/path/to/cabal.
            case args of
              []      -> printErrors errs
              script : scriptArgs -> CmdRun.validScript script >>= \case
                False -> printErrors errs
                True  -> do
                  -- In main operation (not help, version etc.) print warning if assertions are on.
                  warnIfAssertionsAreEnabled
                  CmdRun.handleShebang script scriptArgs

          CommandReadyToGo action        -> do
            -- In main operation (not help, version etc.) print warning if assertions are on.
            warnIfAssertionsAreEnabled
            action globalFlags

  where
    printCommandHelp help = do
      pname <- getProgName
      putStr (help pname)
    printGlobalHelp help = do
      pname <- getProgName
      configFile <- defaultConfigFile
      putStr (help pname)
      putStr $ "\nYou can edit the cabal configuration file to set defaults:\n"
            ++ "  " ++ configFile ++ "\n"
      exists <- doesFileExist configFile
      unless exists $
          putStrLn $ "This file will be generated with sensible "
                  ++ "defaults if you run 'cabal update'."
    printOptionsList = putStr . unlines
    printErrors errs = dieNoVerbosity $ intercalate "\n" errs
    printNumericVersion = putStrLn $ display cabalInstallVersion
    printVersion        = putStrLn $ "cabal-install version "
                                  ++ display cabalInstallVersion
                                  ++ "\ncompiled using version "
                                  ++ display cabalVersion
                                  ++ " of the Cabal library "

    commands = map commandFromSpec commandSpecs
    commandSpecs =
      [ regularCmd listCommand listAction
      , regularCmd infoCommand infoAction
      , regularCmd fetchCommand fetchAction
      , regularCmd getCommand getAction
      , regularCmd unpackCommand unpackAction
      , regularCmd checkCommand checkAction
      , regularCmd uploadCommand uploadAction
      , regularCmd reportCommand reportAction
      , regularCmd initCommand initAction
      , regularCmd userConfigCommand userConfigAction
      , regularCmd genBoundsCommand genBoundsAction
      , regularCmd CmdOutdated.outdatedCommand CmdOutdated.outdatedAction
      , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref
      , hiddenCmd  formatCommand formatAction
      , hiddenCmd  actAsSetupCommand actAsSetupAction
      , hiddenCmd  manpageCommand (manpageAction commandSpecs)
      , regularCmd CmdListBin.listbinCommand     CmdListBin.listbinAction

      ] ++ concat
      [ newCmd  CmdConfigure.configureCommand CmdConfigure.configureAction
      , newCmd  CmdUpdate.updateCommand       CmdUpdate.updateAction
      , newCmd  CmdBuild.buildCommand         CmdBuild.buildAction
      , newCmd  CmdRepl.replCommand           CmdRepl.replAction
      , newCmd  CmdFreeze.freezeCommand       CmdFreeze.freezeAction
      , newCmd  CmdHaddock.haddockCommand     CmdHaddock.haddockAction
      , newCmd  CmdHaddockProject.haddockProjectCommand
                                              CmdHaddockProject.haddockProjectAction
      , newCmd  CmdInstall.installCommand     CmdInstall.installAction
      , newCmd  CmdRun.runCommand             CmdRun.runAction
      , newCmd  CmdTest.testCommand           CmdTest.testAction
      , newCmd  CmdBench.benchCommand         CmdBench.benchAction
      , newCmd  CmdExec.execCommand           CmdExec.execAction
      , newCmd  CmdClean.cleanCommand         CmdClean.cleanAction
      , newCmd  CmdSdist.sdistCommand         CmdSdist.sdistAction

      , legacyCmd configureExCommand configureAction
      , legacyCmd buildCommand buildAction
      , legacyCmd replCommand replAction
      , legacyCmd freezeCommand freezeAction
      , legacyCmd haddockCommand haddockAction
      , legacyCmd installCommand installAction
      , legacyCmd runCommand runAction
      , legacyCmd testCommand testAction
      , legacyCmd benchmarkCommand benchmarkAction
      , legacyCmd cleanCommand cleanAction
      , legacyWrapperCmd copyCommand copyVerbosity copyDistPref
      , legacyWrapperCmd registerCommand regVerbosity regDistPref
      , legacyCmd reconfigureCommand reconfigureAction
      ]

type Action = GlobalFlags -> IO ()

-- Duplicated in Distribution.Client.CmdLegacy. Any changes must be
-- reflected there, as well.
regularCmd :: CommandUI flags -> (flags -> [String] -> action)
           -> CommandSpec action
regularCmd ui action =
  CommandSpec ui ((flip commandAddAction) action) NormalCommand

hiddenCmd :: CommandUI flags -> (flags -> [String] -> action)
          -> CommandSpec action
hiddenCmd ui action =
  CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action))
  HiddenCommand

wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity)
           -> (flags -> Flag String) -> CommandSpec Action
wrapperCmd ui verbosity distPref =
  CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand

wrapperAction :: Monoid flags
              => CommandUI flags
              -> (flags -> Flag Verbosity)
              -> (flags -> Flag String)
              -> Command Action
wrapperAction command verbosityFlag distPrefFlag =
  commandAddAction command
    { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do
    let verbosity = fromFlagOrDefault normal (verbosityFlag flags)
    load <- try (loadConfigOrSandboxConfig verbosity globalFlags)
    let config = either (\(SomeException _) -> mempty) id load
    distPref <- findSavedDistPref config (distPrefFlag flags)
    let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }
    setupWrapper verbosity setupScriptOptions Nothing
                 command (const flags) (const extraArgs)

configureAction :: (ConfigFlags, ConfigExFlags)
                -> [String] -> Action
configureAction (configFlags, configExFlags) extraArgs globalFlags = do
  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
  config <- updateInstallDirs (configUserInstall configFlags)
                          <$> loadConfigOrSandboxConfig verbosity globalFlags
  distPref <- findSavedDistPref config (configDistPref configFlags)
  nixInstantiate verbosity distPref True globalFlags config
  nixShell verbosity distPref globalFlags config $ do
    let configFlags'   = savedConfigureFlags   config `mappend` configFlags
        configExFlags' = savedConfigureExFlags config `mappend` configExFlags
        globalFlags'   = savedGlobalFlags      config `mappend` globalFlags
    (comp, platform, progdb) <- configCompilerAuxEx configFlags'

    writeConfigFlags verbosity distPref (configFlags', configExFlags')

    -- What package database(s) to use
    let packageDBs :: PackageDBStack
        packageDBs
          = interpretPackageDbFlags
            (fromFlag (configUserInstall configFlags'))
            (configPackageDBs configFlags')

    withRepoContext verbosity globalFlags' $ \repoContext ->
        configure verbosity packageDBs repoContext
                  comp platform progdb configFlags' configExFlags' extraArgs

reconfigureAction :: (ConfigFlags, ConfigExFlags)
                  -> [String] -> Action
reconfigureAction flags@(configFlags, _) _ globalFlags = do
  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
  config <- updateInstallDirs (configUserInstall configFlags)
                          <$> loadConfigOrSandboxConfig verbosity globalFlags
  distPref <- findSavedDistPref config (configDistPref configFlags)
  let checkFlags = Check $ \_ saved -> do
        let flags' = saved <> flags
        unless (saved == flags') $ info verbosity message
        pure (Any True, flags')
        where
          -- This message is correct, but not very specific: it will list all
          -- of the new flags, even if some have not actually changed. The
          -- *minimal* set of changes is more difficult to determine.
          message =
            "flags changed: "
            ++ unwords (commandShowOptions configureExCommand flags)
  nixInstantiate verbosity distPref True globalFlags config
  _ <-
    reconfigure configureAction
    verbosity distPref NoFlag
    checkFlags [] globalFlags config
  pure ()

buildAction :: BuildFlags -> [String] -> Action
buildAction buildFlags extraArgs globalFlags = do
  let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)
  config <- loadConfigOrSandboxConfig verbosity globalFlags
  distPref <- findSavedDistPref config (buildDistPref buildFlags)
  -- Calls 'configureAction' to do the real work, so nothing special has to be
  -- done to support sandboxes.
  config' <-
    reconfigure configureAction
    verbosity distPref (buildNumJobs buildFlags)
    mempty [] globalFlags config
  nixShell verbosity distPref globalFlags config $ do
    build verbosity config' distPref buildFlags extraArgs


-- | Actually do the work of building the package. This is separate from
-- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke
-- 'reconfigure' twice.
build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO ()
build verbosity config distPref buildFlags extraArgs =
  setupWrapper verbosity setupOptions Nothing
               (Cabal.buildCommand progDb) mkBuildFlags (const extraArgs)
  where
    progDb       = defaultProgramDb
    setupOptions = defaultSetupScriptOptions { useDistPref = distPref }

    mkBuildFlags version = filterBuildFlags version config buildFlags'
    buildFlags' = buildFlags
      { buildVerbosity = toFlag verbosity
      , buildDistPref  = toFlag distPref
      }

-- | Make sure that we don't pass new flags to setup scripts compiled against
-- old versions of Cabal.
filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags
filterBuildFlags version config buildFlags
  | version >= mkVersion [1,19,1] = buildFlags_latest
  -- Cabal < 1.19.1 doesn't support 'build -j'.
  | otherwise                      = buildFlags_pre_1_19_1
  where
    buildFlags_pre_1_19_1 = buildFlags {
      buildNumJobs = NoFlag
      }
    buildFlags_latest     = buildFlags {
      -- Take the 'jobs' setting config file into account.
      buildNumJobs = Flag . Just . determineNumJobs $
                     (numJobsConfigFlag `mappend` numJobsCmdLineFlag)
      }
    numJobsConfigFlag  = installNumJobs . savedInstallFlags $ config
    numJobsCmdLineFlag = buildNumJobs buildFlags


replAction :: ReplFlags -> [String] -> Action
replAction replFlags extraArgs globalFlags = do
  let verbosity = fromFlagOrDefault normal (replVerbosity replFlags)
  config <- loadConfigOrSandboxConfig verbosity globalFlags
  distPref <- findSavedDistPref config (replDistPref replFlags)
  cwd     <- getCurrentDirectory
  pkgDesc <- findPackageDesc cwd
  let
    -- There is a .cabal file in the current directory: start a REPL and load
    -- the project's modules.
    onPkgDesc = do
      -- Calls 'configureAction' to do the real work, so nothing special has to
      -- be done to support sandboxes.
      _ <-
        reconfigure configureAction
        verbosity distPref NoFlag
        mempty [] globalFlags config
      let progDb = defaultProgramDb
          setupOptions = defaultSetupScriptOptions
            { useCabalVersion = orLaterVersion $ mkVersion [1,18,0]
            , useDistPref     = distPref
            }
          replFlags'   = replFlags
            { replVerbosity = toFlag verbosity
            , replDistPref  = toFlag distPref
            }

      nixShell verbosity distPref globalFlags config $
        setupWrapper verbosity setupOptions Nothing (Cabal.replCommand progDb) (const replFlags') (const extraArgs)

    -- No .cabal file in the current directory: just start the REPL (possibly
    -- using the sandbox package DB).
    onNoPkgDesc = do
      let configFlags = savedConfigureFlags config
      (comp, platform, programDb) <- configCompilerAux' configFlags
      programDb' <- reconfigurePrograms verbosity
                                        (replProgramPaths replFlags)
                                        (replProgramArgs replFlags)
                                        programDb
      nixShell verbosity distPref globalFlags config $ do
        startInterpreter verbosity programDb' comp platform
                        (configPackageDB' configFlags)

  either (const onNoPkgDesc) (const onPkgDesc) pkgDesc

installAction :: ( ConfigFlags, ConfigExFlags, InstallFlags
                 , HaddockFlags, TestFlags, BenchmarkFlags )
              -> [String] -> Action
installAction (configFlags, _, installFlags, _, _, _) _ globalFlags
  | fromFlagOrDefault False (installOnly installFlags) = do
      let verb = fromFlagOrDefault normal (configVerbosity configFlags)
      config <- loadConfigOrSandboxConfig verb globalFlags
      dist <- findSavedDistPref config (configDistPref configFlags)
      let setupOpts = defaultSetupScriptOptions { useDistPref = dist }
      setupWrapper
        verb setupOpts Nothing
        installCommand (const (mempty, mempty, mempty, mempty, mempty, mempty))
                       (const [])

installAction
  ( configFlags, configExFlags, installFlags
  , haddockFlags, testFlags, benchmarkFlags )
  extraArgs globalFlags = do
  let verb = fromFlagOrDefault normal (configVerbosity configFlags)
  config <- updateInstallDirs (configUserInstall configFlags)
                          <$> loadConfigOrSandboxConfig verb globalFlags

  dist <- findSavedDistPref config (configDistPref configFlags)

  do
    targets <- readUserTargets verb extraArgs

    let configFlags'    = maybeForceTests installFlags' $
                          savedConfigureFlags   config `mappend`
                          configFlags { configDistPref = toFlag dist }
        configExFlags'  = defaultConfigExFlags         `mappend`
                          savedConfigureExFlags config `mappend` configExFlags
        installFlags'   = defaultInstallFlags          `mappend`
                          savedInstallFlags     config `mappend` installFlags
        haddockFlags'   = defaultHaddockFlags          `mappend`
                          savedHaddockFlags     config `mappend`
                          haddockFlags { haddockDistPref = toFlag dist }
        testFlags'      = Cabal.defaultTestFlags       `mappend`
                          savedTestFlags        config `mappend`
                          testFlags { testDistPref = toFlag dist }
        benchmarkFlags' = Cabal.defaultBenchmarkFlags  `mappend`
                          savedBenchmarkFlags   config `mappend`
                          benchmarkFlags { benchmarkDistPref = toFlag dist }
        globalFlags'    = savedGlobalFlags      config `mappend` globalFlags
    (comp, platform, progdb) <- configCompilerAux' configFlags'

    -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the
    -- future.
    progdb' <- configureAllKnownPrograms verb progdb

    configFlags'' <- configAbsolutePaths configFlags'

    withRepoContext verb globalFlags' $ \repoContext ->
        install verb
                (configPackageDB' configFlags'')
                repoContext
                comp platform progdb'
                globalFlags' configFlags'' configExFlags'
                installFlags' haddockFlags' testFlags' benchmarkFlags'
                targets

      where
        -- '--run-tests' implies '--enable-tests'.
        maybeForceTests installFlags' configFlags' =
          if fromFlagOrDefault False (installRunTests installFlags')
          then configFlags' { configTests = toFlag True }
          else configFlags'

testAction :: (BuildFlags, TestFlags) -> [String] -> GlobalFlags
           -> IO ()
testAction (buildFlags, testFlags) extraArgs globalFlags = do
  let verbosity      = fromFlagOrDefault normal (buildVerbosity buildFlags)
  config <- loadConfigOrSandboxConfig verbosity globalFlags
  distPref <- findSavedDistPref config (testDistPref testFlags)
  let buildFlags'    = buildFlags
                      { buildVerbosity = testVerbosity testFlags }
      checkFlags = Check $ \_ flags@(configFlags, configExFlags) ->
        if fromFlagOrDefault False (configTests configFlags)
          then pure (mempty, flags)
          else do
            info verbosity "reconfiguring to enable tests"
            let flags' = ( configFlags { configTests = toFlag True }
                        , configExFlags
                        )
            pure (Any True, flags')

  _ <-
    reconfigure configureAction
    verbosity distPref (buildNumJobs buildFlags')
    checkFlags [] globalFlags config
  nixShell verbosity distPref globalFlags config $ do
    let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }
        testFlags'     = testFlags { testDistPref = toFlag distPref }

    -- The package was just configured, so the LBI must be available.
    names <- componentNamesFromLBI verbosity distPref "test suites"
              (\c -> case c of { LBI.CTest{} -> True; _ -> False })
    let extraArgs'
          | null extraArgs = case names of
            ComponentNamesUnknown -> []
            ComponentNames names' -> [ Make.unUnqualComponentName name
                                    | LBI.CTestName name <- names' ]
          | otherwise      = extraArgs

    build verbosity config distPref buildFlags' extraArgs'
    setupWrapper verbosity setupOptions Nothing Cabal.testCommand (const testFlags') (const extraArgs')

data ComponentNames = ComponentNamesUnknown
                    | ComponentNames [LBI.ComponentName]

-- | Return the names of all buildable components matching a given predicate.
componentNamesFromLBI :: Verbosity -> FilePath -> String
                         -> (LBI.Component -> Bool)
                         -> IO ComponentNames
componentNamesFromLBI verbosity distPref targetsDescr compPred = do
  eLBI <- tryGetPersistBuildConfig distPref
  case eLBI of
    Left err -> case err of
      -- Note: the build config could have been generated by a custom setup
      -- script built against a different Cabal version, so it's crucial that
      -- we ignore the bad version error here.
      ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown
      _                               -> die' verbosity (show err)
    Right lbi -> do
      let pkgDescr = LBI.localPkgDescr lbi
          names    = map LBI.componentName
                     . filter (buildable . LBI.componentBuildInfo)
                     . filter compPred $
                     LBI.pkgComponents pkgDescr
      if null names
        then do notice verbosity $ "Package has no buildable "
                  ++ targetsDescr ++ "."
                exitSuccess -- See #3215.

        else return $! (ComponentNames names)

benchmarkAction :: (BuildFlags, BenchmarkFlags)
                   -> [String] -> GlobalFlags
                   -> IO ()
benchmarkAction
  (buildFlags, benchmarkFlags)
  extraArgs globalFlags = do
  let verbosity      = fromFlagOrDefault normal
                       (buildVerbosity buildFlags)

  config <- loadConfigOrSandboxConfig verbosity globalFlags
  distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags)
  let buildFlags'    = buildFlags
                      { buildVerbosity = benchmarkVerbosity benchmarkFlags }

  let checkFlags = Check $ \_ flags@(configFlags, configExFlags) ->
        if fromFlagOrDefault False (configBenchmarks configFlags)
          then pure (mempty, flags)
          else do
            info verbosity "reconfiguring to enable benchmarks"
            let flags' = ( configFlags { configBenchmarks = toFlag True }
                        , configExFlags
                        )
            pure (Any True, flags')

  config' <-
    reconfigure configureAction
    verbosity distPref (buildNumJobs buildFlags')
    checkFlags [] globalFlags config
  nixShell verbosity distPref globalFlags config $ do
    let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }
        benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref }

    -- The package was just configured, so the LBI must be available.
    names <- componentNamesFromLBI verbosity distPref "benchmarks"
            (\c -> case c of { LBI.CBench{} -> True; _ -> False; })
    let extraArgs'
          | null extraArgs = case names of
            ComponentNamesUnknown -> []
            ComponentNames names' -> [ Make.unUnqualComponentName name
                                    | LBI.CBenchName name <- names']
          | otherwise      = extraArgs

    build verbosity config' distPref buildFlags' extraArgs'
    setupWrapper verbosity setupOptions Nothing Cabal.benchmarkCommand (const benchmarkFlags') (const extraArgs')

haddockAction :: HaddockFlags -> [String] -> Action
haddockAction haddockFlags extraArgs globalFlags = do
  let verbosity = fromFlag (haddockVerbosity haddockFlags)
  config <- loadConfigOrSandboxConfig verbosity globalFlags
  distPref <- findSavedDistPref config (haddockDistPref haddockFlags)
  config' <-
    reconfigure configureAction
    verbosity distPref NoFlag
    mempty [] globalFlags config
  nixShell verbosity distPref globalFlags config $ do
    let haddockFlags' = defaultHaddockFlags      `mappend`
                        savedHaddockFlags config' `mappend`
                        haddockFlags { haddockDistPref = toFlag distPref }
        setupScriptOptions = defaultSetupScriptOptions
                             { useDistPref = distPref }
    setupWrapper verbosity setupScriptOptions Nothing
      haddockCommand (const haddockFlags') (const extraArgs)
    when (haddockForHackage haddockFlags == Flag ForHackage) $ do
      pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)
      let dest = distPref </> name <.> "tar.gz"
          name = display (packageId pkg) ++ "-docs"
          docDir = distPref </> "doc" </> "html"
      createTarGzFile dest docDir name
      notice verbosity $ "Documentation tarball created: " ++ dest

cleanAction :: CleanFlags -> [String] -> Action
cleanAction cleanFlags extraArgs globalFlags = do
  load <- try (loadConfigOrSandboxConfig verbosity globalFlags)
  let config = either (\(SomeException _) -> mempty) id load
  distPref <- findSavedDistPref config (cleanDistPref cleanFlags)
  let setupScriptOptions = defaultSetupScriptOptions
                           { useDistPref = distPref
                           , useWin32CleanHack = True
                           }
      cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref }
  setupWrapper verbosity setupScriptOptions Nothing
               cleanCommand (const cleanFlags') (const extraArgs)
  where
    verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags)

listAction :: ListFlags -> [String] -> Action
listAction listFlags extraArgs globalFlags = do
  let verbosity = fromFlag (listVerbosity listFlags)
  config <- loadConfigOrSandboxConfig verbosity globalFlags
  let configFlags' = savedConfigureFlags config
      configFlags  = configFlags'
        { configPackageDBs = configPackageDBs configFlags'
                           `mappend` listPackageDBs listFlags
        , configHcPath     = listHcPath listFlags
        }
      globalFlags' = savedGlobalFlags    config `mappend` globalFlags
  compProgdb <- if listNeedsCompiler listFlags
      then do
          (comp, _, progdb) <- configCompilerAux' configFlags
          return (Just (comp, progdb))
      else return Nothing
  withRepoContext verbosity globalFlags' $ \repoContext ->
    List.list verbosity
       (configPackageDB' configFlags)
       repoContext
       compProgdb
       listFlags
       extraArgs

infoAction :: InfoFlags -> [String] -> Action
infoAction infoFlags extraArgs globalFlags = do
  let verbosity = fromFlag (infoVerbosity infoFlags)
  targets <- readUserTargets verbosity extraArgs
  config <- loadConfigOrSandboxConfig verbosity globalFlags
  let configFlags' = savedConfigureFlags config
      configFlags  = configFlags' {
        configPackageDBs = configPackageDBs configFlags'
                           `mappend` infoPackageDBs infoFlags
        }
      globalFlags' = savedGlobalFlags    config `mappend` globalFlags
  (comp, _, progdb) <- configCompilerAuxEx configFlags
  withRepoContext verbosity globalFlags' $ \repoContext ->
    List.info verbosity
       (configPackageDB' configFlags)
       repoContext
       comp
       progdb
       globalFlags'
       infoFlags
       targets

fetchAction :: FetchFlags -> [String] -> Action
fetchAction fetchFlags extraArgs globalFlags = do
  let verbosity = fromFlag (fetchVerbosity fetchFlags)
  targets <- readUserTargets verbosity extraArgs
  config <- loadConfig verbosity (globalConfigFile globalFlags)
  let configFlags  = savedConfigureFlags config
      globalFlags' = savedGlobalFlags config `mappend` globalFlags
  (comp, platform, progdb) <- configCompilerAux' configFlags
  withRepoContext verbosity globalFlags' $ \repoContext ->
    fetch verbosity
        (configPackageDB' configFlags)
        repoContext
        comp platform progdb globalFlags' fetchFlags
        targets

freezeAction :: FreezeFlags -> [String] -> Action
freezeAction freezeFlags _extraArgs globalFlags = do
  let verbosity = fromFlag (freezeVerbosity freezeFlags)
  config <- loadConfigOrSandboxConfig verbosity globalFlags
  distPref <- findSavedDistPref config NoFlag
  nixShell verbosity distPref globalFlags config $ do
    let configFlags  = savedConfigureFlags config
        globalFlags' = savedGlobalFlags config `mappend` globalFlags
    (comp, platform, progdb) <- configCompilerAux' configFlags

    withRepoContext verbosity globalFlags' $ \repoContext ->
        freeze verbosity
            (configPackageDB' configFlags)
            repoContext
            comp platform progdb
            globalFlags' freezeFlags

genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO ()
genBoundsAction freezeFlags _extraArgs globalFlags = do
  let verbosity = fromFlag (freezeVerbosity freezeFlags)
  config <- loadConfigOrSandboxConfig verbosity globalFlags
  distPref <- findSavedDistPref config NoFlag
  nixShell verbosity distPref globalFlags config $ do
    let configFlags  = savedConfigureFlags config
        globalFlags' = savedGlobalFlags config `mappend` globalFlags
    (comp, platform, progdb) <- configCompilerAux' configFlags

    withRepoContext verbosity globalFlags' $ \repoContext ->
        genBounds verbosity
                (configPackageDB' configFlags)
                repoContext
                comp platform progdb
                globalFlags' freezeFlags

uploadAction :: UploadFlags -> [String] -> Action
uploadAction uploadFlags extraArgs globalFlags = do
  config <- loadConfig verbosity (globalConfigFile globalFlags)
  let uploadFlags' = savedUploadFlags config `mappend` uploadFlags
      globalFlags' = savedGlobalFlags config `mappend` globalFlags
      tarfiles     = extraArgs
  when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $
    die' verbosity "the 'upload' command expects at least one .tar.gz archive."
  checkTarFiles extraArgs
  maybe_password <-
    case uploadPasswordCmd uploadFlags'
    of Flag (xs:xss) -> Just . Password <$>
                        getProgramInvocationOutput verbosity
                        (simpleProgramInvocation xs xss)
       _             -> pure $ flagToMaybe $ uploadPassword uploadFlags'
  withRepoContext verbosity globalFlags' $ \repoContext -> do
    if fromFlag (uploadDoc uploadFlags')
    then do
      when (length tarfiles > 1) $
       die' verbosity $ "the 'upload' command can only upload documentation "
             ++ "for one package at a time."
      tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles
      Upload.uploadDoc verbosity
                       repoContext
                       (flagToMaybe $ uploadUsername uploadFlags')
                       maybe_password
                       (fromFlag (uploadCandidate uploadFlags'))
                       tarfile
    else do
      Upload.upload verbosity
                    repoContext
                    (flagToMaybe $ uploadUsername uploadFlags')
                    maybe_password
                    (fromFlag (uploadCandidate uploadFlags'))
                    tarfiles
    where
    verbosity = fromFlag (uploadVerbosity uploadFlags)
    checkTarFiles tarfiles
      | not (null otherFiles)
      = die' verbosity $ "the 'upload' command expects only .tar.gz archives: "
           ++ intercalate ", " otherFiles
      | otherwise = sequence_
                      [ do exists <- doesFileExist tarfile
                           unless exists $ die' verbosity $ "file not found: " ++ tarfile
                      | tarfile <- tarfiles ]

      where otherFiles = filter (not . isTarGzFile) tarfiles
            isTarGzFile file = case splitExtension file of
              (file', ".gz") -> takeExtension file' == ".tar"
              _              -> False
    generateDocTarball config = do
      notice verbosity $
        "No documentation tarball specified. "
        ++ "Building a documentation tarball with default settings...\n"
        ++ "If you need to customise Haddock options, "
        ++ "run 'haddock --for-hackage' first "
        ++ "to generate a documentation tarball."
      haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage })
                    [] globalFlags
      distPref <- findSavedDistPref config NoFlag
      pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)
      return $ distPref </> display (packageId pkg) ++ "-docs" <.> "tar.gz"

checkAction :: Flag Verbosity -> [String] -> Action
checkAction verbosityFlag extraArgs _globalFlags = do
  let verbosity = fromFlag verbosityFlag
  unless (null extraArgs) $
    die' verbosity $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs
  allOk <- Check.check (fromFlag verbosityFlag)
  unless allOk exitFailure

formatAction :: Flag Verbosity -> [String] -> Action
formatAction verbosityFlag extraArgs _globalFlags = do
  let verbosity = fromFlag verbosityFlag
  path <- case extraArgs of
    [] -> do cwd <- getCurrentDirectory
             tryFindPackageDesc verbosity cwd
    (p:_) -> return p
  pkgDesc <- readGenericPackageDescription verbosity path
  -- Uses 'writeFileAtomic' under the hood.
  writeGenericPackageDescription path pkgDesc

reportAction :: ReportFlags -> [String] -> Action
reportAction reportFlags extraArgs globalFlags = do
  let verbosity = fromFlag (reportVerbosity reportFlags)
  unless (null extraArgs) $
    die' verbosity $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs
  config <- loadConfig verbosity (globalConfigFile globalFlags)
  let globalFlags' = savedGlobalFlags config `mappend` globalFlags
      reportFlags' = savedReportFlags config `mappend` reportFlags

  withRepoContext verbosity globalFlags' $ \repoContext ->
   Upload.report verbosity repoContext
    (flagToMaybe $ reportUsername reportFlags')
    (flagToMaybe $ reportPassword reportFlags')

runAction :: BuildFlags -> [String] -> Action
runAction buildFlags extraArgs globalFlags = do
  let verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)
  config <- loadConfigOrSandboxConfig verbosity globalFlags
  distPref <- findSavedDistPref config (buildDistPref buildFlags)
  config' <-
    reconfigure configureAction
    verbosity distPref (buildNumJobs buildFlags)
    mempty [] globalFlags config
  nixShell verbosity distPref globalFlags config $ do
    lbi <- getPersistBuildConfig distPref
    (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs

    build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)]
    run verbosity lbi exe exeArgs

getAction :: GetFlags -> [String] -> Action
getAction getFlags extraArgs globalFlags = do
  let verbosity = fromFlag (getVerbosity getFlags)
  targets <- readUserTargets verbosity extraArgs
  config <- loadConfigOrSandboxConfig verbosity globalFlags
  let globalFlags' = savedGlobalFlags config `mappend` globalFlags
  withRepoContext verbosity (savedGlobalFlags config) $ \repoContext ->
   get verbosity
    repoContext
    globalFlags'
    getFlags
    targets

unpackAction :: GetFlags -> [String] -> Action
unpackAction getFlags extraArgs globalFlags = do
  getAction getFlags extraArgs globalFlags

initAction :: InitFlags -> [String] -> Action
initAction initFlags extraArgs globalFlags = do
  -- it takes the first value within extraArgs (if there's one)
  -- and uses it as the root directory for the new project
  case extraArgs of
    [] -> initAction'
    [projectDir] -> do
      createDirectoryIfMissingVerbose verbosity True projectDir
      withCurrentDirectory projectDir initAction'
    _ -> die' verbosity $
      "'init' only takes a single, optional, extra " ++
      "argument for the project root directory"
  where
    initAction' = do
      confFlags <- loadConfigOrSandboxConfig verbosity globalFlags
      -- override with `--with-compiler` from CLI if available
      let confFlags' = savedConfigureFlags confFlags `mappend` compFlags
          initFlags' = savedInitFlags confFlags `mappend` initFlags
          globalFlags' = savedGlobalFlags confFlags `mappend` globalFlags

      (comp, _, progdb) <- configCompilerAux' confFlags'

      withRepoContext verbosity globalFlags' $ \repoContext ->
        initCmd verbosity (configPackageDB' confFlags')
          repoContext comp progdb initFlags'

    verbosity = fromFlag (initVerbosity initFlags)
    compFlags = mempty { configHcPath = initHcPath initFlags }

userConfigAction :: UserConfigFlags -> [String] -> Action
userConfigAction ucflags extraArgs globalFlags = do
  let verbosity  = fromFlag (userConfigVerbosity ucflags)
      frc        = fromFlag (userConfigForce ucflags)
      extraLines = fromFlag (userConfigAppendLines ucflags)
  case extraArgs of
    ("init":_) -> do
      path       <- configFile
      fileExists <- doesFileExist path
      if (not fileExists || (fileExists && frc))
      then void $ createDefaultConfigFile verbosity extraLines path
      else die' verbosity $ path ++ " already exists."
    ("diff":_) -> traverse_ putStrLn =<< userConfigDiff verbosity globalFlags extraLines
    ("update":_) -> userConfigUpdate verbosity globalFlags extraLines
    -- Error handling.
    [] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')"
    _  -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs
  where configFile = getConfigFilePath (globalConfigFile globalFlags)

-- | Used as an entry point when cabal-install needs to invoke itself
-- as a setup script. This can happen e.g. when doing parallel builds.
--
actAsSetupAction :: ActAsSetupFlags -> [String] -> Action
actAsSetupAction actAsSetupFlags args _globalFlags =
  let bt = fromFlag (actAsSetupBuildType actAsSetupFlags)
  in case bt of
    Simple    -> Simple.defaultMainArgs args
    Configure -> Simple.defaultMainWithHooksArgs
                  Simple.autoconfUserHooks args
    Make      -> Make.defaultMainArgs args
    Custom    -> error "actAsSetupAction Custom"

manpageAction :: [CommandSpec action] -> ManpageFlags -> [String] -> Action
manpageAction commands flags extraArgs _ = do
  let verbosity = fromFlag (manpageVerbosity flags)
  unless (null extraArgs) $
    die' verbosity $ "'man' doesn't take any extra arguments: " ++ unwords extraArgs
  pname <- getProgName
  let cabalCmd = if takeExtension pname == ".exe"
                 then dropExtension pname
                 else pname
  manpageCmd cabalCmd commands flags