{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

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

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

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

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

import Distribution.Client.Check as Check (check)
import Distribution.Client.Configure (configure, writeConfigFlags)
import Distribution.Client.Fetch (fetch)
import Distribution.Client.Freeze (freeze)
import Distribution.Client.GenBounds (genBounds)
import Distribution.Client.Install (install)

-- import Distribution.Client.Clean            (clean)

import Distribution.Client.Get (get)
import Distribution.Client.Init (initCmd)
import Distribution.Client.Manpage (manpageCmd)
import Distribution.Client.ManpageFlags (ManpageFlags (..))
import Distribution.Client.Reconfigure (Check (..), reconfigure)
import Distribution.Client.Run (run, splitRunArgs)
import Distribution.Client.Sandbox
  ( findSavedDistPref
  , loadConfigOrSandboxConfig
  , updateInstallDirs
  )
import Distribution.Client.Signal
  ( installTerminationHandler
  )
import Distribution.Client.Tar (createTarGzFile)
import Distribution.Client.Types.Credentials (Password (..))
import qualified Distribution.Client.Upload as Upload
import Distribution.Client.Utils
  ( determineNumJobs
  , relaxEncodingErrors
  )
import Distribution.Client.Version
  ( cabalInstallGitInfo
  , cabalInstallVersion
  )

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

import Distribution.Client.Errors
import Distribution.Compat.ResponseFile
import Distribution.PackageDescription.PrettyPrint
  ( writeGenericPackageDescription
  )
import qualified Distribution.Simple as Simple
import Distribution.Simple.Build
  ( startInterpreter
  )
import Distribution.Simple.Command
  ( Command
  , CommandParse (..)
  , CommandSpec (..)
  , CommandType (..)
  , CommandUI (..)
  , commandAddAction
  , commandFromSpec
  , commandShowOptions
  , commandsRunWithFallback
  , defaultCommandFallback
  , hiddenCommand
  )
import Distribution.Simple.Compiler (PackageDBStack, interpretPackageDBStack)
import Distribution.Simple.Configure
  ( ConfigStateFileError (..)
  , configCompilerAuxEx
  , getPersistBuildConfig
  , interpretPackageDbFlags
  , tryGetPersistBuildConfig
  )
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.PackageDescription (readGenericPackageDescription)
import Distribution.Simple.Program
  ( configureAllKnownPrograms
  , defaultProgramDb
  , defaultProgramSearchPath
  , findProgramOnSearchPath
  , getProgramInvocationOutput
  , simpleProgramInvocation
  )
import Distribution.Simple.Program.Db (reconfigurePrograms)
import qualified Distribution.Simple.Setup as Cabal
import Distribution.Simple.Utils
  ( VerboseException
  , cabalCompilerInfo
  , cabalGitInfo
  , cabalVersion
  , createDirectoryIfMissingVerbose
  , die'
  , dieNoVerbosity
  , dieWithException
  , findPackageDesc
  , info
  , isUserException
  , notice
  , topHandler
  , tryFindPackageDesc
  , warn
  )
import Distribution.Text
  ( display
  )
import qualified Distribution.Types.UnqualComponentName as Make
import Distribution.Utils.Path hiding
  ( (<.>)
  , (</>)
  )
import Distribution.Verbosity as Verbosity
  ( VerbosityFlags
  , defaultVerbosityHandles
  , mkVerbosity
  , normal
  , verbosityFlags
  , verbosityHandles
  )
import Distribution.Version
  ( Version
  , mkVersion
  , orLaterVersion
  )

import Control.Exception (AssertionFailed, assert, try)
import Data.Monoid (Any (..))
import Distribution.Client.Types
import System.Directory
  ( doesFileExist
  , withCurrentDirectory
  )
import System.Environment (getEnvironment, getExecutablePath, getProgName)
import System.FilePath
  ( dropExtension
  , splitExtension
  , takeExtension
  , (<.>)
  , (</>)
  )
import System.IO
  ( BufferMode (LineBuffering)
  , hPutStrLn
  , hSetBuffering
  , stderr
  , stdout
  )
import System.Process (createProcess, env, proc, waitForProcess)

-- | Entry point
--
-- This does three things.
--
-- One, it initializes the program, providing support for termination
-- signals, preparing console linebuffering, and relaxing encoding errors.
--
-- Two, it processes (via an IO action) response
-- files, calling 'expandResponse' in Cabal/Distribution.Compat.ResponseFile
--
-- Note that here, it splits the arguments on a strict match to
-- "--", and won't parse response files after the split.
--
-- Three, it calls the 'mainWorker', which calls the argument parser,
-- producing 'CommandParse' data, which mainWorker pattern-matches
-- into IO actions for execution.
main :: [String] -> IO ()
main :: [String] -> IO ()
main [String]
args = do
  IO ()
installTerminationHandler
  -- Enable line buffering so that we can get fast feedback even when piped.
  -- This is especially important for CI and build systems.
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
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.
  Handle -> IO ()
relaxEncodingErrors Handle
stdout
  Handle -> IO ()
relaxEncodingErrors Handle
stderr

  -- Response files support.
  -- See 'expandResponse' documentation in Cabal/Distribution.Compat.ResponseFile
  -- for more information.
  let ([String]
args0, [String]
args1) = (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]
args

  [String] -> IO ()
mainWorker ([String] -> IO ()) -> ([String] -> [String]) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args1) ([String] -> IO ()) -> IO [String] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [String] -> IO [String]
expandResponse [String]
args0

-- | Check whether assertions are enabled and print a warning in that case.
warnIfAssertionsAreEnabled :: IO ()
warnIfAssertionsAreEnabled :: IO ()
warnIfAssertionsAreEnabled =
  Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert Bool
False (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    IO () -> (AssertionFailed -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(AssertionFailed
_e :: AssertionFailed) -> Handle -> String -> IO ()
hPutStrLn Handle
stderr String
assertionsEnabledMsg)
  where
    -- 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.

    assertionsEnabledMsg :: String
assertionsEnabledMsg =
      String
"Warning: this is a debug build of cabal-install with assertions enabled."

-- | Core worker, similar to 'defaultMainHelper' in Cabal/Distribution.Simple
--
-- With an exception-handler @topHandler@, mainWorker calls commandsRun
-- to parse arguments, then pattern-matches the CommandParse data
-- into IO actions for execution.
mainWorker :: [String] -> IO ()
mainWorker :: [String] -> IO ()
mainWorker [String]
args = do
  (SomeException -> Bool) -> IO () -> IO ()
forall a. (SomeException -> Bool) -> IO a -> IO a
topHandler (Proxy (VerboseException CabalInstallException)
-> SomeException -> Bool
forall user_err.
Typeable user_err =>
Proxy user_err -> SomeException -> Bool
isUserException (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(VerboseException CabalInstallException))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    command <- CommandUI GlobalFlags
-> [Command Action]
-> ([Command Action]
    -> String -> [String] -> IO (CommandParse Action))
-> [String]
-> IO (CommandParse (GlobalFlags, CommandParse Action))
forall a action.
CommandUI a
-> [Command action]
-> ([Command action]
    -> String -> [String] -> IO (CommandParse action))
-> [String]
-> IO (CommandParse (a, CommandParse action))
commandsRunWithFallback ([Command Action] -> CommandUI GlobalFlags
forall action. [Command action] -> CommandUI GlobalFlags
globalCommand [Command Action]
commands) [Command Action]
commands [Command Action] -> String -> [String] -> IO (CommandParse Action)
delegateToExternal [String]
args
    case command of
      CommandHelp String -> String
help -> (String -> String) -> IO ()
printGlobalHelp String -> String
help
      CommandList [String]
opts -> [String] -> IO ()
printOptionsList [String]
opts
      CommandErrors [String]
errs -> [String] -> IO ()
forall {a}. [String] -> IO a
printErrors [String]
errs
      CommandReadyToGo (GlobalFlags
globalFlags, CommandParse Action
commandParse) ->
        case CommandParse Action
commandParse of
          CommandParse Action
_
            | Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (GlobalFlags -> Flag Bool
globalVersion GlobalFlags
globalFlags) ->
                IO ()
printVersion
            | Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (GlobalFlags -> Flag Bool
globalFullVersion GlobalFlags
globalFlags) ->
                IO ()
printFullVersion
            | Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (GlobalFlags -> Flag Bool
globalNumericVersion GlobalFlags
globalFlags) ->
                IO ()
printNumericVersion
          CommandHelp String -> String
help -> (String -> String) -> IO ()
printCommandHelp String -> String
help
          CommandList [String]
opts -> [String] -> IO ()
printOptionsList [String]
opts
          CommandErrors [String]
errs -> do
            -- Check whether cabal is called from a script, like #!/path/to/cabal.
            case [String]
args of
              [] -> [String] -> IO ()
forall {a}. [String] -> IO a
printErrors [String]
errs
              String
script : [String]
scriptArgs ->
                String -> IO Bool
CmdRun.validScript String
script IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Bool
False -> [String] -> IO ()
forall {a}. [String] -> IO a
printErrors [String]
errs
                  Bool
True -> do
                    -- In main operation (not help, version etc.) print warning if assertions are on.
                    IO ()
warnIfAssertionsAreEnabled
                    String -> [String] -> IO ()
CmdRun.handleShebang String
script [String]
scriptArgs
          CommandReadyToGo Action
action -> do
            -- In main operation (not help, version etc.) print warning if assertions are on.
            IO ()
warnIfAssertionsAreEnabled
            Action
action GlobalFlags
globalFlags
  where
    delegateToExternal
      :: [Command Action]
      -> String
      -> [String]
      -> IO (CommandParse Action)
    delegateToExternal :: [Command Action] -> String -> [String] -> IO (CommandParse Action)
delegateToExternal [Command Action]
commands' String
name [String]
cmdArgs = do
      -- we rely on cabal's implementation of findProgramOnSearchPath not following
      -- symlinks here. If that ever happens, then the argv[0] of the called executable
      -- will be different from the intended one and will break tools that work by reading it.
      let verb :: Verbosity
verb = VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles VerbosityFlags
normal
      mCommand <- Verbosity
-> ProgramSearchPath -> String -> IO (Maybe (String, [String]))
findProgramOnSearchPath Verbosity
verb ProgramSearchPath
defaultProgramSearchPath (String
"cabal-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name)
      case mCommand of
        Just (String
exec, [String]
_) -> CommandParse Action -> IO (CommandParse Action)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Action -> CommandParse Action
forall flags. flags -> CommandParse flags
CommandReadyToGo (Action -> CommandParse Action) -> Action -> CommandParse Action
forall a b. (a -> b) -> a -> b
$ \GlobalFlags
_ -> String -> [String] -> IO ()
callExternal String
exec [String]
cmdArgs)
        Maybe (String, [String])
Nothing -> [Command Action] -> String -> [String] -> IO (CommandParse Action)
forall action.
[Command action] -> String -> [String] -> IO (CommandParse action)
defaultCommandFallback [Command Action]
commands' String
name [String]
cmdArgs

    callExternal :: String -> [String] -> IO ()
    callExternal :: String -> [String] -> IO ()
callExternal String
exec [String]
cmdArgs = do
      cur_env <- IO [(String, String)]
getEnvironment
      cabal_exe <- getExecutablePath
      let new_env = (String
"CABAL_EXTERNAL_CABAL_PATH", String
cabal_exe) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: [(String, String)]
cur_env
      result <- try $ createProcess ((proc exec cmdArgs){env = Just new_env})
      case result of
        Left SomeException
ex -> [String] -> IO ()
forall {a}. [String] -> IO a
printErrors [String
"Error executing external command: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show (SomeException
ex :: SomeException)]
        Right (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
ph) -> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph IO ExitCode -> (ExitCode -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith

    printCommandHelp :: (String -> String) -> IO ()
printCommandHelp String -> String
help = do
      pname <- IO String
getProgName
      putStr (help pname)
    printGlobalHelp :: (String -> String) -> IO ()
printGlobalHelp String -> String
help = do
      pname <- IO String
getProgName
      configFile <- defaultConfigFile
      putStr (help pname)
      -- Andreas Abel, 2024-01-28: https://github.com/haskell/cabal/pull/9614
      -- See cabal-testsuite/PackageTests/Help/HelpPrintsConfigFile/
      -- Third-party tools may rely on the specific wording
      -- to find the config file in the help text, so do not change!
      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 :: [String] -> IO ()
printOptionsList = String -> IO ()
putStr (String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines
    printErrors :: [String] -> IO a
printErrors [String]
errs = String -> IO a
forall a. String -> IO a
dieNoVerbosity (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [String]
errs
    printNumericVersion :: IO ()
printNumericVersion = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Version -> String
forall a. Pretty a => a -> String
display Version
cabalInstallVersion
    printVersion :: IO ()
printVersion =
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"cabal-install version "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
display Version
cabalInstallVersion
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\ncompiled using version "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
display Version
cabalVersion
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of the Cabal library "
    printFullVersion :: IO ()
printFullVersion =
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"cabal-install version "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
display Version
cabalInstallVersion
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cabalInstallGitInfo'
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\ncompiled using version "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
display Version
cabalVersion
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of the Cabal library "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cabalGitInfo'
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nwith "
          -- it's impossible for cabal-install to have been built with a different compiler
          -- from Cabal, so just reuse its info
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cabalCompilerInfo
      where
        cabalInstallGitInfo' :: String
cabalInstallGitInfo'
          | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
cabalInstallGitInfo = String
""
          | Bool
otherwise = Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: String
cabalInstallGitInfo
        cabalGitInfo' :: String
cabalGitInfo'
          | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
cabalGitInfo Bool -> Bool -> Bool
&& String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
cabalInstallGitInfo = String
""
          | String
cabalGitInfo String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
cabalInstallGitInfo = String
"(in-tree)"
          | Bool
otherwise = String
cabalGitInfo

    commands :: [Command Action]
commands = (CommandSpec Action -> Command Action)
-> [CommandSpec Action] -> [Command Action]
forall a b. (a -> b) -> [a] -> [b]
map CommandSpec Action -> Command Action
forall a. CommandSpec a -> Command a
commandFromSpec [CommandSpec Action]
commandSpecs
    commandSpecs :: [CommandSpec Action]
commandSpecs =
      [ CommandUI ListFlags
-> (ListFlags -> [String] -> Action) -> CommandSpec Action
forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI ListFlags
listCommand ListFlags -> [String] -> Action
listAction
      , CommandUI InfoFlags
-> (InfoFlags -> [String] -> Action) -> CommandSpec Action
forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI InfoFlags
infoCommand InfoFlags -> [String] -> Action
infoAction
      , CommandUI FetchFlags
-> (FetchFlags -> [String] -> Action) -> CommandSpec Action
forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI FetchFlags
fetchCommand FetchFlags -> [String] -> Action
fetchAction
      , CommandUI GetFlags
-> (GetFlags -> [String] -> Action) -> CommandSpec Action
forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI GetFlags
getCommand GetFlags -> [String] -> Action
getAction
      , CommandUI GetFlags
-> (GetFlags -> [String] -> Action) -> CommandSpec Action
forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI GetFlags
unpackCommand GetFlags -> [String] -> Action
unpackAction
      , CommandUI CheckFlags
-> (CheckFlags -> [String] -> Action) -> CommandSpec Action
forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI CheckFlags
checkCommand CheckFlags -> [String] -> Action
checkAction
      , CommandUI UploadFlags
-> (UploadFlags -> [String] -> Action) -> CommandSpec Action
forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI UploadFlags
uploadCommand UploadFlags -> [String] -> Action
uploadAction
      , CommandUI ReportFlags
-> (ReportFlags -> [String] -> Action) -> CommandSpec Action
forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI ReportFlags
reportCommand ReportFlags -> [String] -> Action
reportAction
      , CommandUI InitFlags
-> (InitFlags -> [String] -> Action) -> CommandSpec Action
forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI InitFlags
initCommand InitFlags -> [String] -> Action
initAction
      , CommandUI UserConfigFlags
-> (UserConfigFlags -> [String] -> Action) -> CommandSpec Action
forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI UserConfigFlags
userConfigCommand UserConfigFlags -> [String] -> Action
userConfigAction
      , CommandUI (NixStyleFlags PathFlags)
-> (NixStyleFlags PathFlags -> [String] -> Action)
-> CommandSpec Action
forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI (NixStyleFlags PathFlags)
CmdPath.pathCommand NixStyleFlags PathFlags -> [String] -> Action
CmdPath.pathAction
      , CommandUI HscolourFlags
-> (HscolourFlags -> CommonSetupFlags) -> CommandSpec Action
forall flags.
Monoid flags =>
CommandUI flags
-> (flags -> CommonSetupFlags) -> CommandSpec Action
wrapperCmd CommandUI HscolourFlags
hscolourCommand HscolourFlags -> CommonSetupFlags
hscolourCommonFlags
      , CommandUI (Flag VerbosityFlags)
-> (Flag VerbosityFlags -> [String] -> Action)
-> CommandSpec Action
forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
hiddenCmd CommandUI (Flag VerbosityFlags)
formatCommand Flag VerbosityFlags -> [String] -> Action
formatAction
      , CommandUI ActAsSetupFlags
-> (ActAsSetupFlags -> [String] -> Action) -> CommandSpec Action
forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
hiddenCmd CommandUI ActAsSetupFlags
actAsSetupCommand ActAsSetupFlags -> [String] -> Action
actAsSetupAction
      , CommandUI ManpageFlags
-> (ManpageFlags -> [String] -> Action) -> CommandSpec Action
forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
hiddenCmd CommandUI ManpageFlags
manpageCommand ([CommandSpec Action] -> ManpageFlags -> [String] -> Action
forall action.
[CommandSpec action] -> ManpageFlags -> [String] -> Action
manpageAction [CommandSpec Action]
commandSpecs)
      , CommandUI (NixStyleFlags ())
-> (NixStyleFlags () -> [String] -> Action) -> CommandSpec Action
forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI (NixStyleFlags ())
CmdListBin.listbinCommand NixStyleFlags () -> [String] -> Action
CmdListBin.listbinAction
      ]
        [CommandSpec Action]
-> [CommandSpec Action] -> [CommandSpec Action]
forall a. [a] -> [a] -> [a]
++ [[CommandSpec Action]] -> [CommandSpec Action]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ CommandUI (NixStyleFlags ())
-> (NixStyleFlags () -> [String] -> Action) -> [CommandSpec Action]
forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd CommandUI (NixStyleFlags ())
CmdConfigure.configureCommand NixStyleFlags () -> [String] -> Action
CmdConfigure.configureAction
          , CommandUI (NixStyleFlags ())
-> (NixStyleFlags () -> [String] -> Action) -> [CommandSpec Action]
forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd CommandUI (NixStyleFlags ())
CmdUpdate.updateCommand NixStyleFlags () -> [String] -> Action
CmdUpdate.updateAction
          , CommandUI (NixStyleFlags BuildFlags)
-> (NixStyleFlags BuildFlags -> [String] -> Action)
-> [CommandSpec Action]
forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd CommandUI (NixStyleFlags BuildFlags)
CmdBuild.buildCommand NixStyleFlags BuildFlags -> [String] -> Action
CmdBuild.buildAction
          , CommandUI (NixStyleFlags ReplFlags)
-> (NixStyleFlags ReplFlags -> [String] -> Action)
-> [CommandSpec Action]
forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd CommandUI (NixStyleFlags ReplFlags)
CmdRepl.replCommand NixStyleFlags ReplFlags -> [String] -> Action
CmdRepl.replAction
          , CommandUI (NixStyleFlags ())
-> (NixStyleFlags () -> [String] -> Action) -> [CommandSpec Action]
forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd CommandUI (NixStyleFlags ())
CmdFreeze.freezeCommand NixStyleFlags () -> [String] -> Action
CmdFreeze.freezeAction
          , CommandUI (NixStyleFlags ClientHaddockFlags)
-> (NixStyleFlags ClientHaddockFlags -> [String] -> Action)
-> [CommandSpec Action]
forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd CommandUI (NixStyleFlags ClientHaddockFlags)
CmdHaddock.haddockCommand NixStyleFlags ClientHaddockFlags -> [String] -> Action
CmdHaddock.haddockAction
          , CommandUI HaddockProjectFlags
-> (HaddockProjectFlags -> [String] -> Action)
-> [CommandSpec Action]
forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd
              CommandUI HaddockProjectFlags
CmdHaddockProject.haddockProjectCommand
              HaddockProjectFlags -> [String] -> Action
CmdHaddockProject.haddockProjectAction
          , CommandUI (NixStyleFlags ClientInstallFlags)
-> (NixStyleFlags ClientInstallFlags -> [String] -> Action)
-> [CommandSpec Action]
forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd CommandUI (NixStyleFlags ClientInstallFlags)
CmdInstall.installCommand NixStyleFlags ClientInstallFlags -> [String] -> Action
CmdInstall.installAction
          , CommandUI (NixStyleFlags ())
-> (NixStyleFlags () -> [String] -> Action) -> [CommandSpec Action]
forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd CommandUI (NixStyleFlags ())
CmdRun.runCommand NixStyleFlags () -> [String] -> Action
CmdRun.runAction
          , CommandUI (NixStyleFlags ())
-> (NixStyleFlags () -> [String] -> Action) -> [CommandSpec Action]
forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd CommandUI (NixStyleFlags ())
CmdTest.testCommand NixStyleFlags () -> [String] -> Action
CmdTest.testAction
          , CommandUI (NixStyleFlags ())
-> (NixStyleFlags () -> [String] -> Action) -> [CommandSpec Action]
forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd CommandUI (NixStyleFlags ())
CmdBench.benchCommand NixStyleFlags () -> [String] -> Action
CmdBench.benchAction
          , CommandUI (NixStyleFlags ())
-> (NixStyleFlags () -> [String] -> Action) -> [CommandSpec Action]
forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd CommandUI (NixStyleFlags ())
CmdExec.execCommand NixStyleFlags () -> [String] -> Action
CmdExec.execAction
          , CommandUI (ProjectFlags, CleanFlags)
-> ((ProjectFlags, CleanFlags) -> [String] -> Action)
-> [CommandSpec Action]
forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd CommandUI (ProjectFlags, CleanFlags)
CmdClean.cleanCommand (ProjectFlags, CleanFlags) -> [String] -> Action
CmdClean.cleanAction
          , CommandUI (ProjectFlags, SdistFlags)
-> ((ProjectFlags, SdistFlags) -> [String] -> Action)
-> [CommandSpec Action]
forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd CommandUI (ProjectFlags, SdistFlags)
CmdSdist.sdistCommand (ProjectFlags, SdistFlags) -> [String] -> Action
CmdSdist.sdistAction
          , CommandUI (NixStyleFlags ())
-> (NixStyleFlags () -> [String] -> Action) -> [CommandSpec Action]
forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd CommandUI (NixStyleFlags ())
CmdTarget.targetCommand NixStyleFlags () -> [String] -> Action
CmdTarget.targetAction
          , CommandUI (NixStyleFlags GenBoundsFlags)
-> (NixStyleFlags GenBoundsFlags -> [String] -> Action)
-> [CommandSpec Action]
forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd CommandUI (NixStyleFlags GenBoundsFlags)
CmdGenBounds.genBoundsCommand NixStyleFlags GenBoundsFlags -> [String] -> Action
CmdGenBounds.genBoundsAction
          , CommandUI (NixStyleFlags OutdatedFlags)
-> (NixStyleFlags OutdatedFlags -> [String] -> Action)
-> [CommandSpec Action]
forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd CommandUI (NixStyleFlags OutdatedFlags)
CmdOutdated.outdatedCommand NixStyleFlags OutdatedFlags -> [String] -> Action
CmdOutdated.outdatedAction
          , CommandUI (ConfigFlags, ConfigExFlags)
-> ((ConfigFlags, ConfigExFlags) -> [String] -> Action)
-> [CommandSpec Action]
forall flags globals action.
HasVerbosity flags =>
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
legacyCmd CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand (ConfigFlags, ConfigExFlags) -> [String] -> Action
configureAction
          , CommandUI FreezeFlags
-> (FreezeFlags -> [String] -> Action) -> [CommandSpec Action]
forall flags globals action.
HasVerbosity flags =>
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
legacyCmd CommandUI FreezeFlags
genBoundsCommand FreezeFlags -> [String] -> Action
genBoundsAction
          , CommandUI BuildFlags
-> (BuildFlags -> [String] -> Action) -> [CommandSpec Action]
forall flags globals action.
HasVerbosity flags =>
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
legacyCmd CommandUI BuildFlags
buildCommand BuildFlags -> [String] -> Action
buildAction
          , CommandUI ReplFlags
-> (ReplFlags -> [String] -> Action) -> [CommandSpec Action]
forall flags globals action.
HasVerbosity flags =>
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
legacyCmd CommandUI ReplFlags
replCommand ReplFlags -> [String] -> Action
replAction
          , CommandUI FreezeFlags
-> (FreezeFlags -> [String] -> Action) -> [CommandSpec Action]
forall flags globals action.
HasVerbosity flags =>
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
legacyCmd CommandUI FreezeFlags
freezeCommand FreezeFlags -> [String] -> Action
freezeAction
          , CommandUI HaddockFlags
-> (HaddockFlags -> [String] -> Action) -> [CommandSpec Action]
forall flags globals action.
HasVerbosity flags =>
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
legacyCmd CommandUI HaddockFlags
haddockCommand HaddockFlags -> [String] -> Action
haddockAction
          , CommandUI
  (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags,
   BenchmarkFlags)
-> ((ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags,
     TestFlags, BenchmarkFlags)
    -> [String] -> Action)
-> [CommandSpec Action]
forall flags globals action.
HasVerbosity flags =>
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
legacyCmd CommandUI
  (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags,
   BenchmarkFlags)
installCommand (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags,
 BenchmarkFlags)
-> [String] -> Action
installAction
          , CommandUI BuildFlags
-> (BuildFlags -> [String] -> Action) -> [CommandSpec Action]
forall flags globals action.
HasVerbosity flags =>
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
legacyCmd CommandUI BuildFlags
runCommand BuildFlags -> [String] -> Action
runAction
          , CommandUI (BuildFlags, TestFlags)
-> ((BuildFlags, TestFlags) -> [String] -> Action)
-> [CommandSpec Action]
forall flags globals action.
HasVerbosity flags =>
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
legacyCmd CommandUI (BuildFlags, TestFlags)
testCommand (BuildFlags, TestFlags) -> [String] -> Action
testAction
          , CommandUI (BuildFlags, BenchmarkFlags)
-> ((BuildFlags, BenchmarkFlags) -> [String] -> Action)
-> [CommandSpec Action]
forall flags globals action.
HasVerbosity flags =>
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
legacyCmd CommandUI (BuildFlags, BenchmarkFlags)
benchmarkCommand (BuildFlags, BenchmarkFlags) -> [String] -> Action
benchmarkAction
          , CommandUI CleanFlags
-> (CleanFlags -> [String] -> Action) -> [CommandSpec Action]
forall flags globals action.
HasVerbosity flags =>
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
legacyCmd CommandUI CleanFlags
cleanCommand CleanFlags -> [String] -> Action
cleanAction
          , CommandUI CopyFlags
-> (CopyFlags -> CommonSetupFlags) -> [CommandSpec Action]
forall flags.
Monoid flags =>
CommandUI flags
-> (flags -> CommonSetupFlags) -> [CommandSpec Action]
legacyWrapperCmd CommandUI CopyFlags
copyCommand CopyFlags -> CommonSetupFlags
copyCommonFlags
          , CommandUI RegisterFlags
-> (RegisterFlags -> CommonSetupFlags) -> [CommandSpec Action]
forall flags.
Monoid flags =>
CommandUI flags
-> (flags -> CommonSetupFlags) -> [CommandSpec Action]
legacyWrapperCmd CommandUI RegisterFlags
registerCommand RegisterFlags -> CommonSetupFlags
registerCommonFlags
          , CommandUI (ConfigFlags, ConfigExFlags)
-> ((ConfigFlags, ConfigExFlags) -> [String] -> Action)
-> [CommandSpec Action]
forall flags globals action.
HasVerbosity flags =>
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
legacyCmd CommandUI (ConfigFlags, ConfigExFlags)
reconfigureCommand (ConfigFlags, ConfigExFlags) -> [String] -> Action
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 :: forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI flags
ui flags -> [String] -> action
action =
  CommandUI flags
-> (CommandUI flags -> Command action)
-> CommandType
-> CommandSpec action
forall action flags.
CommandUI flags
-> (CommandUI flags -> Command action)
-> CommandType
-> CommandSpec action
CommandSpec CommandUI flags
ui (CommandUI flags -> (flags -> [String] -> action) -> Command action
forall flags action.
CommandUI flags -> (flags -> [String] -> action) -> Command action
`commandAddAction` flags -> [String] -> action
action) CommandType
NormalCommand

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

wrapperCmd
  :: Monoid flags
  => CommandUI flags
  -> (flags -> CommonSetupFlags)
  -> CommandSpec Action
wrapperCmd :: forall flags.
Monoid flags =>
CommandUI flags
-> (flags -> CommonSetupFlags) -> CommandSpec Action
wrapperCmd CommandUI flags
ui flags -> CommonSetupFlags
getCommonFlags =
  CommandUI flags
-> (CommandUI flags -> Command Action)
-> CommandType
-> CommandSpec Action
forall action flags.
CommandUI flags
-> (CommandUI flags -> Command action)
-> CommandType
-> CommandSpec action
CommandSpec CommandUI flags
ui (CommandUI flags -> (flags -> CommonSetupFlags) -> Command Action
forall flags.
Monoid flags =>
CommandUI flags -> (flags -> CommonSetupFlags) -> Command Action
`wrapperAction` flags -> CommonSetupFlags
getCommonFlags) CommandType
NormalCommand

wrapperAction
  :: Monoid flags
  => CommandUI flags
  -> (flags -> CommonSetupFlags)
  -> Command Action
wrapperAction :: forall flags.
Monoid flags =>
CommandUI flags -> (flags -> CommonSetupFlags) -> Command Action
wrapperAction CommandUI flags
command flags -> CommonSetupFlags
getCommonFlags =
  CommandUI flags -> (flags -> [String] -> Action) -> Command Action
forall flags action.
CommandUI flags -> (flags -> [String] -> action) -> Command action
commandAddAction
    CommandUI flags
command
      { commandDefaultFlags = mempty
      }
    ((flags -> [String] -> Action) -> Command Action)
-> (flags -> [String] -> Action) -> Command Action
forall a b. (a -> b) -> a -> b
$ \flags
flags [String]
extraArgs GlobalFlags
globalFlags -> do
      let common :: CommonSetupFlags
common = flags -> CommonSetupFlags
getCommonFlags flags
flags
          verbosity :: Verbosity
verbosity =
            VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
              VerbosityFlags -> Flag VerbosityFlags -> VerbosityFlags
forall a. a -> Flag a -> a
fromFlagOrDefault VerbosityFlags
normal (Flag VerbosityFlags -> VerbosityFlags)
-> Flag VerbosityFlags -> VerbosityFlags
forall a b. (a -> b) -> a -> b
$
                CommonSetupFlags -> Flag VerbosityFlags
setupVerbosity CommonSetupFlags
common
          mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Flag a -> Maybe a
flagToMaybe (Flag (SymbolicPath CWD ('Dir Pkg))
 -> Maybe (SymbolicPath CWD ('Dir Pkg)))
-> Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ CommonSetupFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
setupWorkingDir CommonSetupFlags
common
      load <- IO SavedConfig -> IO (Either SomeException SavedConfig)
forall e a. Exception e => IO a -> IO (Either e a)
try (Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags)
      let config = (SomeException -> SavedConfig)
-> (SavedConfig -> SavedConfig)
-> Either SomeException SavedConfig
-> SavedConfig
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(SomeException e
_) -> SavedConfig
forall a. Monoid a => a
mempty) SavedConfig -> SavedConfig
forall a. a -> a
id Either SomeException SavedConfig
load
      distPref <- findSavedDistPref config (setupDistPref common)
      let setupScriptOptions =
            SetupScriptOptions
defaultSetupScriptOptions
              { useDistPref = distPref
              , useWorkingDir = mbWorkDir
              }
      setupWrapper
        verbosity
        setupScriptOptions
        Nothing
        command
        getCommonFlags
        (const (return flags))
        (const extraArgs)
        NotInLibrary

configureAction
  :: (ConfigFlags, ConfigExFlags)
  -> [String]
  -> Action
configureAction :: (ConfigFlags, ConfigExFlags) -> [String] -> Action
configureAction (ConfigFlags
configFlags, ConfigExFlags
configExFlags) [String]
extraArgs GlobalFlags
globalFlags = do
  let common :: CommonSetupFlags
common = ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
configFlags
      verbosity :: Verbosity
verbosity =
        VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
          VerbosityFlags -> Flag VerbosityFlags -> VerbosityFlags
forall a. a -> Flag a -> a
fromFlagOrDefault VerbosityFlags
normal (Flag VerbosityFlags -> VerbosityFlags)
-> Flag VerbosityFlags -> VerbosityFlags
forall a b. (a -> b) -> a -> b
$
            CommonSetupFlags -> Flag VerbosityFlags
setupVerbosity CommonSetupFlags
common

  config <-
    Flag Bool -> SavedConfig -> SavedConfig
updateInstallDirs (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags)
      (SavedConfig -> SavedConfig) -> IO SavedConfig -> IO SavedConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  distPref <- getSymbolicPath <$> findSavedDistPref config (setupDistPref common)

  let configFlags' = SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config ConfigFlags -> ConfigFlags -> ConfigFlags
forall a. Monoid a => a -> a -> a
`mappend` ConfigFlags
configFlags
      configExFlags' = SavedConfig -> ConfigExFlags
savedConfigureExFlags SavedConfig
config ConfigExFlags -> ConfigExFlags -> ConfigExFlags
forall a. Monoid a => a -> a -> a
`mappend` ConfigExFlags
configExFlags
      globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config GlobalFlags -> GlobalFlags -> GlobalFlags
forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
  (comp, platform, progdb) <- configCompilerAuxEx (verbosityHandles verbosity) configFlags'

  writeConfigFlags verbosity distPref (configFlags', configExFlags')

  -- What package database(s) to use
  let packageDBs :: PackageDBStack
      packageDBs =
        Bool
-> [Maybe (PackageDBX (SymbolicPath Pkg ('Dir PkgDB)))]
-> PackageDBStack
forall fp. Bool -> [Maybe (PackageDBX fp)] -> PackageDBStackX fp
interpretPackageDbFlags
          (Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
defaultUserInstall (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags'))
          (ConfigFlags -> [Maybe (PackageDBX (SymbolicPath Pkg ('Dir PkgDB)))]
configPackageDBs ConfigFlags
configFlags')

  withRepoContext verbosity globalFlags' $ \RepoContext
repoContext ->
    Verbosity
-> PackageDBStackCWD
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> ConfigFlags
-> ConfigExFlags
-> [String]
-> IO ()
configure
      Verbosity
verbosity
      (Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack -> PackageDBStackCWD
interpretPackageDBStack Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing PackageDBStack
packageDBs)
      RepoContext
repoContext
      Compiler
comp
      Platform
platform
      ProgramDb
progdb
      ConfigFlags
configFlags'
      ConfigExFlags
configExFlags'
      [String]
extraArgs

reconfigureAction
  :: (ConfigFlags, ConfigExFlags)
  -> [String]
  -> Action
reconfigureAction :: (ConfigFlags, ConfigExFlags) -> [String] -> Action
reconfigureAction flags :: (ConfigFlags, ConfigExFlags)
flags@(ConfigFlags
configFlags, ConfigExFlags
_) [String]
_ GlobalFlags
globalFlags = do
  let common :: CommonSetupFlags
common = ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
configFlags
      verbosity :: Verbosity
verbosity =
        VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
          VerbosityFlags -> Flag VerbosityFlags -> VerbosityFlags
forall a. a -> Flag a -> a
fromFlagOrDefault VerbosityFlags
normal (CommonSetupFlags -> Flag VerbosityFlags
setupVerbosity CommonSetupFlags
common)
  config <-
    Flag Bool -> SavedConfig -> SavedConfig
updateInstallDirs (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags)
      (SavedConfig -> SavedConfig) -> IO SavedConfig -> IO SavedConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  distPref <- findSavedDistPref config (setupDistPref common)
  let checkFlags = (Any
 -> (ConfigFlags, ConfigExFlags)
 -> IO (Any, (ConfigFlags, ConfigExFlags)))
-> Check (ConfigFlags, ConfigExFlags)
forall a. (Any -> a -> IO (Any, a)) -> Check a
Check ((Any
  -> (ConfigFlags, ConfigExFlags)
  -> IO (Any, (ConfigFlags, ConfigExFlags)))
 -> Check (ConfigFlags, ConfigExFlags))
-> (Any
    -> (ConfigFlags, ConfigExFlags)
    -> IO (Any, (ConfigFlags, ConfigExFlags)))
-> Check (ConfigFlags, ConfigExFlags)
forall a b. (a -> b) -> a -> b
$ \Any
_ (ConfigFlags, ConfigExFlags)
saved -> do
        let flags' :: (ConfigFlags, ConfigExFlags)
flags' = (ConfigFlags, ConfigExFlags)
saved (ConfigFlags, ConfigExFlags)
-> (ConfigFlags, ConfigExFlags) -> (ConfigFlags, ConfigExFlags)
forall a. Semigroup a => a -> a -> a
<> (ConfigFlags, ConfigExFlags)
flags
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((ConfigFlags, ConfigExFlags)
saved (ConfigFlags, ConfigExFlags)
-> (ConfigFlags, ConfigExFlags) -> Bool
forall a. Eq a => a -> a -> Bool
== (ConfigFlags, ConfigExFlags)
flags') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
info Verbosity
verbosity String
message
        (Any, (ConfigFlags, ConfigExFlags))
-> IO (Any, (ConfigFlags, ConfigExFlags))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Any
Any Bool
True, (ConfigFlags, ConfigExFlags)
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 :: String
message =
            String
"flags changed: "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (CommandUI (ConfigFlags, ConfigExFlags)
-> (ConfigFlags, ConfigExFlags) -> [String]
forall flags. CommandUI flags -> flags -> [String]
commandShowOptions CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand (ConfigFlags, ConfigExFlags)
flags)
  _ <-
    reconfigure
      configureAction
      verbosity
      distPref
      NoFlag
      checkFlags
      []
      globalFlags
      config
  pure ()

buildAction :: BuildFlags -> [String] -> Action
buildAction :: BuildFlags -> [String] -> Action
buildAction BuildFlags
buildFlags [String]
extraArgs GlobalFlags
globalFlags = do
  let common :: CommonSetupFlags
common = BuildFlags -> CommonSetupFlags
buildCommonFlags BuildFlags
buildFlags
      verbosity :: Verbosity
verbosity =
        VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
          VerbosityFlags -> Flag VerbosityFlags -> VerbosityFlags
forall a. a -> Flag a -> a
fromFlagOrDefault VerbosityFlags
normal (Flag VerbosityFlags -> VerbosityFlags)
-> Flag VerbosityFlags -> VerbosityFlags
forall a b. (a -> b) -> a -> b
$
            CommonSetupFlags -> Flag VerbosityFlags
setupVerbosity CommonSetupFlags
common
  config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  distPref <- findSavedDistPref config (setupDistPref common)
  -- 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
  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 -> SymbolicPath Pkg (Dir Dist) -> BuildFlags -> [String] -> IO ()
build :: Verbosity
-> SavedConfig
-> SymbolicPath Pkg ('Dir Dist)
-> BuildFlags
-> [String]
-> IO ()
build Verbosity
verbosity SavedConfig
config SymbolicPath Pkg ('Dir Dist)
distPref BuildFlags
buildFlags [String]
extraArgs =
  Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI BuildFlags
-> (BuildFlags -> CommonSetupFlags)
-> (Version -> IO BuildFlags)
-> (Version -> [String])
-> SetupRunnerArgs 'UseGeneralSetup
-> IO (SetupRunnerRes 'UseGeneralSetup)
forall (setupSpec :: SetupWrapperSpec) flags.
RightFlagsForPhase flags setupSpec =>
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (flags -> CommonSetupFlags)
-> (Version -> IO flags)
-> (Version -> [String])
-> SetupRunnerArgs setupSpec
-> IO (SetupRunnerRes setupSpec)
setupWrapper
    Verbosity
verbosity
    SetupScriptOptions
setupOptions
    Maybe PackageDescription
forall a. Maybe a
Nothing
    (ProgramDb -> CommandUI BuildFlags
Cabal.buildCommand ProgramDb
progDb)
    BuildFlags -> CommonSetupFlags
buildCommonFlags
    (BuildFlags -> IO BuildFlags
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildFlags -> IO BuildFlags)
-> (Version -> BuildFlags) -> Version -> IO BuildFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> BuildFlags
mkBuildFlags)
    ([String] -> Version -> [String]
forall a b. a -> b -> a
const [String]
extraArgs)
    SetupRunnerArgs 'UseGeneralSetup
NotInLibrary
  where
    progDb :: ProgramDb
progDb = ProgramDb
defaultProgramDb
    setupOptions :: SetupScriptOptions
setupOptions = SetupScriptOptions
defaultSetupScriptOptions{useDistPref = distPref}

    mkBuildFlags :: Version -> BuildFlags
mkBuildFlags Version
version = Version -> SavedConfig -> BuildFlags -> BuildFlags
filterBuildFlags Version
version SavedConfig
config BuildFlags
buildFlags'
    commonFlags :: CommonSetupFlags
commonFlags = BuildFlags -> CommonSetupFlags
buildCommonFlags BuildFlags
buildFlags
    buildFlags' :: BuildFlags
buildFlags' =
      BuildFlags
buildFlags
        { buildCommonFlags =
            commonFlags
              { setupVerbosity = toFlag $ verbosityFlags verbosity
              , setupDistPref = 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 -> SavedConfig -> BuildFlags -> BuildFlags
filterBuildFlags Version
version SavedConfig
config BuildFlags
buildFlags =
  let flags' :: BuildFlags
flags' = Version -> SavedConfig -> BuildFlags -> BuildFlags
filterBuildFlags' Version
version SavedConfig
config BuildFlags
buildFlags
   in BuildFlags
flags'
        { buildCommonFlags =
            filterCommonFlags (buildCommonFlags flags') version
        }

filterBuildFlags' :: Version -> SavedConfig -> BuildFlags -> BuildFlags
filterBuildFlags' :: Version -> SavedConfig -> BuildFlags -> BuildFlags
filterBuildFlags' Version
version SavedConfig
config BuildFlags
buildFlags
  | Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
1, Int
19, Int
1] = BuildFlags
buildFlags_latest
  -- Cabal < 1.19.1 doesn't support 'build -j'.
  | Bool
otherwise = BuildFlags
buildFlags_pre_1_19_1
  where
    buildFlags_pre_1_19_1 :: BuildFlags
buildFlags_pre_1_19_1 =
      BuildFlags
buildFlags
        { buildNumJobs = NoFlag
        }
    buildFlags_latest :: BuildFlags
buildFlags_latest =
      BuildFlags
buildFlags
        { -- Take the 'jobs' setting config file into account.
          buildNumJobs =
            Flag . Just . determineNumJobs $
              (numJobsConfigFlag `mappend` numJobsCmdLineFlag)
        }
    numJobsConfigFlag :: Flag (Maybe Int)
numJobsConfigFlag = InstallFlags -> Flag (Maybe Int)
installNumJobs (InstallFlags -> Flag (Maybe Int))
-> (SavedConfig -> InstallFlags) -> SavedConfig -> Flag (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> InstallFlags
savedInstallFlags (SavedConfig -> Flag (Maybe Int))
-> SavedConfig -> Flag (Maybe Int)
forall a b. (a -> b) -> a -> b
$ SavedConfig
config
    numJobsCmdLineFlag :: Flag (Maybe Int)
numJobsCmdLineFlag = BuildFlags -> Flag (Maybe Int)
buildNumJobs BuildFlags
buildFlags

replAction :: ReplFlags -> [String] -> Action
replAction :: ReplFlags -> [String] -> Action
replAction ReplFlags
replFlags [String]
extraArgs GlobalFlags
globalFlags = do
  let common :: CommonSetupFlags
common = ReplFlags -> CommonSetupFlags
replCommonFlags ReplFlags
replFlags
      verbosity :: Verbosity
verbosity =
        VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
          VerbosityFlags -> Flag VerbosityFlags -> VerbosityFlags
forall a. a -> Flag a -> a
fromFlagOrDefault VerbosityFlags
normal (Flag VerbosityFlags -> VerbosityFlags)
-> Flag VerbosityFlags -> VerbosityFlags
forall a b. (a -> b) -> a -> b
$
            CommonSetupFlags -> Flag VerbosityFlags
setupVerbosity CommonSetupFlags
common
  config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  distPref <- findSavedDistPref config (setupDistPref common)
  pkgDesc <- findPackageDesc Nothing
  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.
      _ <-
        ((ConfigFlags, ConfigExFlags) -> [String] -> Action)
-> Verbosity
-> SymbolicPath Pkg ('Dir Dist)
-> Flag (Maybe Int)
-> Check (ConfigFlags, ConfigExFlags)
-> [String]
-> GlobalFlags
-> SavedConfig
-> IO SavedConfig
reconfigure
          (ConfigFlags, ConfigExFlags) -> [String] -> Action
configureAction
          Verbosity
verbosity
          SymbolicPath Pkg ('Dir Dist)
distPref
          Flag (Maybe Int)
forall a. Last a
NoFlag
          Check (ConfigFlags, ConfigExFlags)
forall a. Monoid a => a
mempty
          []
          GlobalFlags
globalFlags
          SavedConfig
config
      let progDb = ProgramDb
defaultProgramDb
          setupOptions =
            SetupScriptOptions
defaultSetupScriptOptions
              { useCabalVersion = orLaterVersion $ mkVersion [1, 18, 0]
              , useDistPref = distPref
              }
          commonFlags = ReplFlags -> CommonSetupFlags
replCommonFlags ReplFlags
replFlags
          replFlags' =
            ReplFlags
replFlags
              { replCommonFlags =
                  commonFlags
                    { setupVerbosity = toFlag $ verbosityFlags verbosity
                    , setupDistPref = toFlag distPref
                    }
              }

      setupWrapper
        verbosity
        setupOptions
        Nothing
        (Cabal.replCommand progDb)
        Cabal.replCommonFlags
        (const (return replFlags'))
        (const extraArgs)
        NotInLibrary

    -- No .cabal file in the current directory: just start the REPL (possibly
    -- using the sandbox package DB).
    onNoPkgDesc = do
      let configFlags :: ConfigFlags
configFlags = SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config
      (comp, platform, programDb) <- ConfigFlags -> IO (Compiler, Platform, ProgramDb)
configCompilerAux' ConfigFlags
configFlags
      programDb' <-
        reconfigurePrograms
          verbosity
          (replProgramPaths replFlags)
          (replProgramArgs replFlags)
          programDb

      startInterpreter
        verbosity
        programDb'
        comp
        platform
        (configPackageDB' configFlags)

  either (const onNoPkgDesc) (const onPkgDesc) pkgDesc

installAction
  :: ( ConfigFlags
     , ConfigExFlags
     , InstallFlags
     , HaddockFlags
     , TestFlags
     , BenchmarkFlags
     )
  -> [String]
  -> Action
installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags,
 BenchmarkFlags)
-> [String] -> Action
installAction (ConfigFlags
configFlags, ConfigExFlags
_, InstallFlags
installFlags, HaddockFlags
_, TestFlags
_, BenchmarkFlags
_) [String]
_ GlobalFlags
globalFlags
  | Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (InstallFlags -> Flag Bool
installOnly InstallFlags
installFlags) = do
      let common :: CommonSetupFlags
common = ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
configFlags
          verb :: Verbosity
verb =
            VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
              VerbosityFlags -> Flag VerbosityFlags -> VerbosityFlags
forall a. a -> Flag a -> a
fromFlagOrDefault VerbosityFlags
normal (CommonSetupFlags -> Flag VerbosityFlags
setupVerbosity CommonSetupFlags
common)
      config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verb GlobalFlags
globalFlags
      dist <- findSavedDistPref config (setupDistPref common)
      let setupOpts = SetupScriptOptions
defaultSetupScriptOptions{useDistPref = dist}
      setupWrapper
        verb
        setupOpts
        Nothing
        installCommand
        (const common)
        (const (return (mempty, mempty, mempty, mempty, mempty, mempty)))
        (const [])
        NotInLibrary
installAction
  ( ConfigFlags
configFlags
    , ConfigExFlags
configExFlags
    , InstallFlags
installFlags
    , HaddockFlags
haddockFlags
    , TestFlags
testFlags
    , BenchmarkFlags
benchmarkFlags
    )
  [String]
extraArgs
  GlobalFlags
globalFlags = do
    let common :: CommonSetupFlags
common = ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
configFlags
        verb :: Verbosity
verb =
          VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
            VerbosityFlags -> Flag VerbosityFlags -> VerbosityFlags
forall a. a -> Flag a -> a
fromFlagOrDefault VerbosityFlags
normal (Flag VerbosityFlags -> VerbosityFlags)
-> Flag VerbosityFlags -> VerbosityFlags
forall a b. (a -> b) -> a -> b
$
              CommonSetupFlags -> Flag VerbosityFlags
setupVerbosity CommonSetupFlags
common
    config <-
      Flag Bool -> SavedConfig -> SavedConfig
updateInstallDirs (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags)
        (SavedConfig -> SavedConfig) -> IO SavedConfig -> IO SavedConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verb GlobalFlags
globalFlags

    dist <- findSavedDistPref config $ setupDistPref common

    do
      targets <- readUserTargets verb extraArgs

      let configFlags' =
            InstallFlags -> ConfigFlags -> ConfigFlags
maybeForceTests InstallFlags
installFlags' (ConfigFlags -> ConfigFlags) -> ConfigFlags -> ConfigFlags
forall a b. (a -> b) -> a -> b
$
              SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config
                ConfigFlags -> ConfigFlags -> ConfigFlags
forall a. Monoid a => a -> a -> a
`mappend` ConfigFlags
configFlags
                  { configCommonFlags =
                      (configCommonFlags configFlags)
                        { setupDistPref = toFlag dist
                        }
                  }
          configExFlags' =
            ConfigExFlags
defaultConfigExFlags
              ConfigExFlags -> ConfigExFlags -> ConfigExFlags
forall a. Monoid a => a -> a -> a
`mappend` SavedConfig -> ConfigExFlags
savedConfigureExFlags SavedConfig
config
              ConfigExFlags -> ConfigExFlags -> ConfigExFlags
forall a. Monoid a => a -> a -> a
`mappend` ConfigExFlags
configExFlags
          installFlags' =
            InstallFlags
defaultInstallFlags
              InstallFlags -> InstallFlags -> InstallFlags
forall a. Monoid a => a -> a -> a
`mappend` SavedConfig -> InstallFlags
savedInstallFlags SavedConfig
config
              InstallFlags -> InstallFlags -> InstallFlags
forall a. Monoid a => a -> a -> a
`mappend` InstallFlags
installFlags
          haddockFlags' =
            HaddockFlags
defaultHaddockFlags
              HaddockFlags -> HaddockFlags -> HaddockFlags
forall a. Monoid a => a -> a -> a
`mappend` SavedConfig -> HaddockFlags
savedHaddockFlags SavedConfig
config
              HaddockFlags -> HaddockFlags -> HaddockFlags
forall a. Monoid a => a -> a -> a
`mappend` HaddockFlags
haddockFlags
                { haddockCommonFlags =
                    (haddockCommonFlags haddockFlags)
                      { setupDistPref = toFlag dist
                      }
                }
          testFlags' =
            TestFlags
Cabal.defaultTestFlags
              TestFlags -> TestFlags -> TestFlags
forall a. Monoid a => a -> a -> a
`mappend` SavedConfig -> TestFlags
savedTestFlags SavedConfig
config
              TestFlags -> TestFlags -> TestFlags
forall a. Monoid a => a -> a -> a
`mappend` TestFlags
testFlags
                { testCommonFlags =
                    (testCommonFlags testFlags)
                      { setupDistPref = toFlag dist
                      }
                }
          benchmarkFlags' =
            BenchmarkFlags
Cabal.defaultBenchmarkFlags
              BenchmarkFlags -> BenchmarkFlags -> BenchmarkFlags
forall a. Monoid a => a -> a -> a
`mappend` SavedConfig -> BenchmarkFlags
savedBenchmarkFlags SavedConfig
config
              BenchmarkFlags -> BenchmarkFlags -> BenchmarkFlags
forall a. Monoid a => a -> a -> a
`mappend` BenchmarkFlags
benchmarkFlags
                { benchmarkCommonFlags =
                    (benchmarkCommonFlags benchmarkFlags)
                      { setupDistPref = toFlag dist
                      }
                }
          globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config GlobalFlags -> GlobalFlags -> GlobalFlags
forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
      (comp, platform, progdb) <- configCompilerAux' configFlags'

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

      withRepoContext verb globalFlags' $ \RepoContext
repoContext ->
        Verbosity
-> PackageDBStackCWD
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> HaddockFlags
-> TestFlags
-> BenchmarkFlags
-> [UserTarget]
-> IO ()
install
          Verbosity
verb
          (Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack -> PackageDBStackCWD
interpretPackageDBStack Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing (ConfigFlags -> PackageDBStack
configPackageDB' ConfigFlags
configFlags'))
          RepoContext
repoContext
          Compiler
comp
          Platform
platform
          ProgramDb
progdb'
          GlobalFlags
globalFlags'
          ConfigFlags
configFlags'
          ConfigExFlags
configExFlags'
          InstallFlags
installFlags'
          HaddockFlags
haddockFlags'
          TestFlags
testFlags'
          BenchmarkFlags
benchmarkFlags'
          [UserTarget]
targets
    where
      -- '--run-tests' implies '--enable-tests'.
      maybeForceTests :: InstallFlags -> ConfigFlags -> ConfigFlags
maybeForceTests InstallFlags
installFlags' ConfigFlags
configFlags' =
        if Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (InstallFlags -> Flag Bool
installRunTests InstallFlags
installFlags')
          then ConfigFlags
configFlags'{configTests = toFlag True}
          else ConfigFlags
configFlags'

testAction
  :: (BuildFlags, TestFlags)
  -> [String]
  -> GlobalFlags
  -> IO ()
testAction :: (BuildFlags, TestFlags) -> [String] -> Action
testAction (BuildFlags
buildFlags, TestFlags
testFlags) [String]
extraArgs GlobalFlags
globalFlags = do
  let verbosity :: Verbosity
verbosity =
        VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
          VerbosityFlags -> Flag VerbosityFlags -> VerbosityFlags
forall a. a -> Flag a -> a
fromFlagOrDefault VerbosityFlags
normal (CommonSetupFlags -> Flag VerbosityFlags
setupVerbosity (CommonSetupFlags -> Flag VerbosityFlags)
-> CommonSetupFlags -> Flag VerbosityFlags
forall a b. (a -> b) -> a -> b
$ BuildFlags -> CommonSetupFlags
buildCommonFlags BuildFlags
buildFlags)
  config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  distPref <- findSavedDistPref config (setupDistPref $ testCommonFlags testFlags)
  let buildFlags' =
        BuildFlags
buildFlags
          { buildCommonFlags =
              (buildCommonFlags buildFlags)
                { setupVerbosity = setupVerbosity $ testCommonFlags testFlags
                }
          }
      checkFlags = (Any -> (ConfigFlags, b) -> IO (Any, (ConfigFlags, b)))
-> Check (ConfigFlags, b)
forall a. (Any -> a -> IO (Any, a)) -> Check a
Check ((Any -> (ConfigFlags, b) -> IO (Any, (ConfigFlags, b)))
 -> Check (ConfigFlags, b))
-> (Any -> (ConfigFlags, b) -> IO (Any, (ConfigFlags, b)))
-> Check (ConfigFlags, b)
forall a b. (a -> b) -> a -> b
$ \Any
_ flags :: (ConfigFlags, b)
flags@(ConfigFlags
configFlags, b
configExFlags) ->
        if Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (ConfigFlags -> Flag Bool
configTests ConfigFlags
configFlags)
          then (Any, (ConfigFlags, b)) -> IO (Any, (ConfigFlags, b))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Any
forall a. Monoid a => a
mempty, (ConfigFlags, b)
flags)
          else do
            Verbosity -> String -> IO ()
info Verbosity
verbosity String
"reconfiguring to enable tests"
            let flags' :: (ConfigFlags, b)
flags' =
                  ( ConfigFlags
configFlags{configTests = toFlag True}
                  , b
configExFlags
                  )
            (Any, (ConfigFlags, b)) -> IO (Any, (ConfigFlags, b))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Any
Any Bool
True, (ConfigFlags, b)
flags')

  _ <-
    reconfigure
      configureAction
      verbosity
      distPref
      (buildNumJobs buildFlags')
      checkFlags
      []
      globalFlags
      config

  let setupOptions = SetupScriptOptions
defaultSetupScriptOptions{useDistPref = distPref}
      testFlags' =
        TestFlags
testFlags
          { testCommonFlags =
              (testCommonFlags testFlags){setupDistPref = toFlag distPref}
          }
      mbWorkDir = Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Flag a -> Maybe a
flagToMaybe (Flag (SymbolicPath CWD ('Dir Pkg))
 -> Maybe (SymbolicPath CWD ('Dir Pkg)))
-> Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ TestFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
testWorkingDir TestFlags
testFlags

  -- The package was just configured, so the LBI must be available.
  names <-
    componentNamesFromLBI
      verbosity
      mbWorkDir
      distPref
      "test suites"
      (\case LBI.CTest{} -> Bool
True; Component
_ -> Bool
False)

  let extraArgs'
        | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
extraArgs = case ComponentNames
names of
            ComponentNames
ComponentNamesUnknown -> []
            ComponentNames [ComponentName]
names' ->
              [ UnqualComponentName -> String
Make.unUnqualComponentName UnqualComponentName
name
              | LBI.CTestName UnqualComponentName
name <- [ComponentName]
names'
              ]
        | Bool
otherwise = [String]
extraArgs

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

data ComponentNames
  = ComponentNamesUnknown
  | ComponentNames [LBI.ComponentName]

-- | Return the names of all buildable components matching a given predicate.
componentNamesFromLBI
  :: Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -- ^ working directory
  -> SymbolicPath Pkg (Dir Dist)
  -> String
  -> (LBI.Component -> Bool)
  -> IO ComponentNames
componentNamesFromLBI :: Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Dist)
-> String
-> (Component -> Bool)
-> IO ComponentNames
componentNamesFromLBI Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg ('Dir Dist)
distPref String
targetsDescr Component -> Bool
compPred = do
  eLBI <- Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Dist)
-> IO (Either ConfigStateFileError LocalBuildInfo)
tryGetPersistBuildConfig Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg ('Dir Dist)
distPref
  case eLBI of
    Left ConfigStateFileError
err -> case ConfigStateFileError
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{} -> ComponentNames -> IO ComponentNames
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ComponentNames
ComponentNamesUnknown
      ConfigStateFileError
_ -> Verbosity -> CabalInstallException -> IO ComponentNames
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ComponentNames)
-> CabalInstallException -> IO ComponentNames
forall a b. (a -> b) -> a -> b
$ String -> CabalInstallException
ConfigStateFileException (ConfigStateFileError -> String
forall a. Show a => a -> String
show ConfigStateFileError
err)
    Right LocalBuildInfo
lbi -> do
      let pkgDescr :: PackageDescription
pkgDescr = LocalBuildInfo -> PackageDescription
LBI.localPkgDescr LocalBuildInfo
lbi
          names :: [ComponentName]
names =
            (Component -> ComponentName) -> [Component] -> [ComponentName]
forall a b. (a -> b) -> [a] -> [b]
map Component -> ComponentName
LBI.componentName
              ([Component] -> [ComponentName])
-> ([Component] -> [Component]) -> [Component] -> [ComponentName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Component -> Bool) -> [Component] -> [Component]
forall a. (a -> Bool) -> [a] -> [a]
filter (BuildInfo -> Bool
buildable (BuildInfo -> Bool)
-> (Component -> BuildInfo) -> Component -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Component -> BuildInfo
LBI.componentBuildInfo)
              ([Component] -> [Component])
-> ([Component] -> [Component]) -> [Component] -> [Component]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Component -> Bool) -> [Component] -> [Component]
forall a. (a -> Bool) -> [a] -> [a]
filter Component -> Bool
compPred
              ([Component] -> [ComponentName]) -> [Component] -> [ComponentName]
forall a b. (a -> b) -> a -> b
$ PackageDescription -> [Component]
LBI.pkgComponents PackageDescription
pkgDescr
      if [ComponentName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ComponentName]
names
        then do
          Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"Package has no buildable "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
targetsDescr
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
          IO ComponentNames
forall a. IO a
exitSuccess -- See #3215.
        else ComponentNames -> IO ComponentNames
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentNames -> IO ComponentNames)
-> ComponentNames -> IO ComponentNames
forall a b. (a -> b) -> a -> b
$! [ComponentName] -> ComponentNames
ComponentNames [ComponentName]
names

benchmarkAction
  :: (BuildFlags, BenchmarkFlags)
  -> [String]
  -> GlobalFlags
  -> IO ()
benchmarkAction :: (BuildFlags, BenchmarkFlags) -> [String] -> Action
benchmarkAction
  (BuildFlags
buildFlags, BenchmarkFlags
benchmarkFlags)
  [String]
extraArgs
  GlobalFlags
globalFlags = do
    let verbosity :: Verbosity
verbosity =
          VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
            VerbosityFlags -> Flag VerbosityFlags -> VerbosityFlags
forall a. a -> Flag a -> a
fromFlagOrDefault
              VerbosityFlags
normal
              (CommonSetupFlags -> Flag VerbosityFlags
setupVerbosity (CommonSetupFlags -> Flag VerbosityFlags)
-> CommonSetupFlags -> Flag VerbosityFlags
forall a b. (a -> b) -> a -> b
$ BuildFlags -> CommonSetupFlags
buildCommonFlags BuildFlags
buildFlags)

    config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
    distPref <- findSavedDistPref config (setupDistPref $ benchmarkCommonFlags benchmarkFlags)
    let buildFlags' =
          BuildFlags
buildFlags
            { buildCommonFlags =
                (buildCommonFlags buildFlags)
                  { setupVerbosity = setupVerbosity $ benchmarkCommonFlags benchmarkFlags
                  }
            }

    let checkFlags = (Any -> (ConfigFlags, b) -> IO (Any, (ConfigFlags, b)))
-> Check (ConfigFlags, b)
forall a. (Any -> a -> IO (Any, a)) -> Check a
Check ((Any -> (ConfigFlags, b) -> IO (Any, (ConfigFlags, b)))
 -> Check (ConfigFlags, b))
-> (Any -> (ConfigFlags, b) -> IO (Any, (ConfigFlags, b)))
-> Check (ConfigFlags, b)
forall a b. (a -> b) -> a -> b
$ \Any
_ flags :: (ConfigFlags, b)
flags@(ConfigFlags
configFlags, b
configExFlags) ->
          if Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (ConfigFlags -> Flag Bool
configBenchmarks ConfigFlags
configFlags)
            then (Any, (ConfigFlags, b)) -> IO (Any, (ConfigFlags, b))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Any
forall a. Monoid a => a
mempty, (ConfigFlags, b)
flags)
            else do
              Verbosity -> String -> IO ()
info Verbosity
verbosity String
"reconfiguring to enable benchmarks"
              let flags' :: (ConfigFlags, b)
flags' =
                    ( ConfigFlags
configFlags{configBenchmarks = toFlag True}
                    , b
configExFlags
                    )
              (Any, (ConfigFlags, b)) -> IO (Any, (ConfigFlags, b))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Any
Any Bool
True, (ConfigFlags, b)
flags')

    config' <-
      reconfigure
        configureAction
        verbosity
        distPref
        (buildNumJobs buildFlags')
        checkFlags
        []
        globalFlags
        config

    let setupOptions = SetupScriptOptions
defaultSetupScriptOptions{useDistPref = distPref}
        benchmarkFlags' =
          BenchmarkFlags
benchmarkFlags
            { benchmarkCommonFlags =
                (benchmarkCommonFlags benchmarkFlags)
                  { setupDistPref = toFlag distPref
                  }
            }
        mbWorkDir = Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Flag a -> Maybe a
flagToMaybe (Flag (SymbolicPath CWD ('Dir Pkg))
 -> Maybe (SymbolicPath CWD ('Dir Pkg)))
-> Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ BenchmarkFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
benchmarkWorkingDir BenchmarkFlags
benchmarkFlags

    -- The package was just configured, so the LBI must be available.
    names <-
      componentNamesFromLBI
        verbosity
        mbWorkDir
        distPref
        "benchmarks"
        (\case LBI.CBench{} -> Bool
True; Component
_ -> Bool
False)

    let extraArgs'
          | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
extraArgs = case ComponentNames
names of
              ComponentNames
ComponentNamesUnknown -> []
              ComponentNames [ComponentName]
names' ->
                [ UnqualComponentName -> String
Make.unUnqualComponentName UnqualComponentName
name
                | LBI.CBenchName UnqualComponentName
name <- [ComponentName]
names'
                ]
          | Bool
otherwise = [String]
extraArgs

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

haddockAction :: HaddockFlags -> [String] -> Action
haddockAction :: HaddockFlags -> [String] -> Action
haddockAction HaddockFlags
haddockFlags [String]
extraArgs GlobalFlags
globalFlags = do
  let common :: CommonSetupFlags
common = HaddockFlags -> CommonSetupFlags
haddockCommonFlags HaddockFlags
haddockFlags
      verbosity :: Verbosity
verbosity =
        VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
          Flag VerbosityFlags -> VerbosityFlags
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag VerbosityFlags -> VerbosityFlags)
-> Flag VerbosityFlags -> VerbosityFlags
forall a b. (a -> b) -> a -> b
$
            CommonSetupFlags -> Flag VerbosityFlags
setupVerbosity CommonSetupFlags
common
  config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  distPref <- findSavedDistPref config (setupDistPref common)
  config' <-
    reconfigure
      configureAction
      verbosity
      distPref
      NoFlag
      mempty
      []
      globalFlags
      config

  let mbWorkDir = Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Flag a -> Maybe a
flagToMaybe (Flag (SymbolicPath CWD ('Dir Pkg))
 -> Maybe (SymbolicPath CWD ('Dir Pkg)))
-> Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ CommonSetupFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
setupWorkingDir CommonSetupFlags
common
      haddockFlags' =
        HaddockFlags
defaultHaddockFlags
          HaddockFlags -> HaddockFlags -> HaddockFlags
forall a. Monoid a => a -> a -> a
`mappend` SavedConfig -> HaddockFlags
savedHaddockFlags SavedConfig
config'
          HaddockFlags -> HaddockFlags -> HaddockFlags
forall a. Monoid a => a -> a -> a
`mappend` HaddockFlags
haddockFlags
            { haddockCommonFlags =
                (haddockCommonFlags haddockFlags)
                  { setupDistPref = toFlag distPref
                  }
            }
      setupScriptOptions =
        SetupScriptOptions
defaultSetupScriptOptions
          { useDistPref = distPref
          }

  setupWrapper
    verbosity
    setupScriptOptions
    Nothing
    haddockCommand
    haddockCommonFlags
    (const (return haddockFlags'))
    (const extraArgs)
    NotInLibrary

  when (haddockForHackage haddockFlags == Flag ForHackage) $ do
    pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig mbWorkDir distPref)
    let dest = SymbolicPath Pkg ('Dir Dist) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath Pkg ('Dir Dist)
distPref String -> String -> String
</> String
name String -> String -> String
<.> String
"tar.gz"
        name = PackageIdentifier -> String
forall a. Pretty a => a -> String
display (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-docs"
        docDir = SymbolicPath Pkg ('Dir Dist) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath Pkg ('Dir Dist)
distPref String -> String -> String
</> String
"doc" String -> String -> String
</> String
"html"
    createTarGzFile dest docDir name
    notice verbosity $ "Documentation tarball created: " ++ dest

cleanAction :: CleanFlags -> [String] -> Action
cleanAction :: CleanFlags -> [String] -> Action
cleanAction CleanFlags
cleanFlags [String]
extraArgs GlobalFlags
globalFlags = do
  let common :: CommonSetupFlags
common = CleanFlags -> CommonSetupFlags
cleanCommonFlags CleanFlags
cleanFlags
      verbosity :: Verbosity
verbosity =
        VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
          VerbosityFlags -> Flag VerbosityFlags -> VerbosityFlags
forall a. a -> Flag a -> a
fromFlagOrDefault VerbosityFlags
normal (Flag VerbosityFlags -> VerbosityFlags)
-> Flag VerbosityFlags -> VerbosityFlags
forall a b. (a -> b) -> a -> b
$
            CommonSetupFlags -> Flag VerbosityFlags
setupVerbosity CommonSetupFlags
common
  load <- IO SavedConfig -> IO (Either SomeException SavedConfig)
forall e a. Exception e => IO a -> IO (Either e a)
try (Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags)
  let config = (SomeException -> SavedConfig)
-> (SavedConfig -> SavedConfig)
-> Either SomeException SavedConfig
-> SavedConfig
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(SomeException e
_) -> SavedConfig
forall a. Monoid a => a
mempty) SavedConfig -> SavedConfig
forall a. a -> a
id Either SomeException SavedConfig
load
  distPref <- findSavedDistPref config $ setupDistPref common
  let setupScriptOptions =
        SetupScriptOptions
defaultSetupScriptOptions
          { useDistPref = distPref
          , useWin32CleanHack = True
          }
      cleanFlags' =
        CleanFlags
cleanFlags
          { cleanCommonFlags =
              (cleanCommonFlags cleanFlags)
                { setupDistPref = toFlag distPref
                }
          }
  setupWrapper
    verbosity
    setupScriptOptions
    Nothing
    cleanCommand
    cleanCommonFlags
    (const (return cleanFlags'))
    (const extraArgs)
    NotInLibrary

listAction :: ListFlags -> [String] -> Action
listAction :: ListFlags -> [String] -> Action
listAction ListFlags
listFlags [String]
extraArgs GlobalFlags
globalFlags = do
  let verbosity :: Verbosity
verbosity =
        VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
          Flag VerbosityFlags -> VerbosityFlags
forall a. WithCallStack (Flag a -> a)
fromFlag (ListFlags -> Flag VerbosityFlags
listVerbosity ListFlags
listFlags)
  config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  let configFlags' = SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config
      configFlags =
        ConfigFlags
configFlags'
          { configPackageDBs =
              configPackageDBs configFlags'
                `mappend` listPackageDBs listFlags
          , configHcPath = listHcPath listFlags
          }
      globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config GlobalFlags -> GlobalFlags -> GlobalFlags
forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
  compProgdb <-
    if listNeedsCompiler listFlags
      then do
        (comp, _, progdb) <- configCompilerAux' configFlags
        return (Just (comp, progdb))
      else return Nothing
  withRepoContext verbosity globalFlags' $ \RepoContext
repoContext ->
    Verbosity
-> PackageDBStackCWD
-> RepoContext
-> Maybe (Compiler, ProgramDb)
-> ListFlags
-> [String]
-> IO ()
List.list
      Verbosity
verbosity
      (Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack -> PackageDBStackCWD
interpretPackageDBStack Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing (ConfigFlags -> PackageDBStack
configPackageDB' ConfigFlags
configFlags))
      RepoContext
repoContext
      Maybe (Compiler, ProgramDb)
compProgdb
      ListFlags
listFlags
      [String]
extraArgs

infoAction :: InfoFlags -> [String] -> Action
infoAction :: InfoFlags -> [String] -> Action
infoAction InfoFlags
infoFlags [String]
extraArgs GlobalFlags
globalFlags = do
  let verbosity :: Verbosity
verbosity =
        VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
          Flag VerbosityFlags -> VerbosityFlags
forall a. WithCallStack (Flag a -> a)
fromFlag (InfoFlags -> Flag VerbosityFlags
infoVerbosity InfoFlags
infoFlags)
  targets <- Verbosity -> [String] -> IO [UserTarget]
readUserTargets Verbosity
verbosity [String]
extraArgs
  config <- loadConfigOrSandboxConfig verbosity globalFlags
  let configFlags' = SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config
      configFlags =
        ConfigFlags
configFlags'
          { configPackageDBs =
              configPackageDBs configFlags'
                `mappend` infoPackageDBs infoFlags
          }
      globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config GlobalFlags -> GlobalFlags -> GlobalFlags
forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
  (comp, _, progdb) <- configCompilerAuxEx defaultVerbosityHandles configFlags
  withRepoContext verbosity globalFlags' $ \RepoContext
repoContext ->
    Verbosity
-> PackageDBStackCWD
-> RepoContext
-> Compiler
-> ProgramDb
-> GlobalFlags
-> InfoFlags
-> [UserTarget]
-> IO ()
List.info
      Verbosity
verbosity
      (Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack -> PackageDBStackCWD
interpretPackageDBStack Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing (ConfigFlags -> PackageDBStack
configPackageDB' ConfigFlags
configFlags))
      RepoContext
repoContext
      Compiler
comp
      ProgramDb
progdb
      GlobalFlags
globalFlags'
      InfoFlags
infoFlags
      [UserTarget]
targets

fetchAction :: FetchFlags -> [String] -> Action
fetchAction :: FetchFlags -> [String] -> Action
fetchAction FetchFlags
fetchFlags [String]
extraArgs GlobalFlags
globalFlags = do
  let verbosity :: Verbosity
verbosity =
        VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
          Flag VerbosityFlags -> VerbosityFlags
forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag VerbosityFlags
fetchVerbosity FetchFlags
fetchFlags)
  targets <- Verbosity -> [String] -> IO [UserTarget]
readUserTargets Verbosity
verbosity [String]
extraArgs
  config <- loadConfig verbosity (globalConfigFile globalFlags)
  let configFlags = SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config
      globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config GlobalFlags -> GlobalFlags -> GlobalFlags
forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
  (comp, platform, progdb) <- configCompilerAux' configFlags
  withRepoContext verbosity globalFlags' $ \RepoContext
repoContext ->
    Verbosity
-> PackageDBStackCWD
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FetchFlags
-> [UserTarget]
-> IO ()
fetch
      Verbosity
verbosity
      (Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack -> PackageDBStackCWD
interpretPackageDBStack Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing (ConfigFlags -> PackageDBStack
configPackageDB' ConfigFlags
configFlags))
      RepoContext
repoContext
      Compiler
comp
      Platform
platform
      ProgramDb
progdb
      GlobalFlags
globalFlags'
      FetchFlags
fetchFlags
      [UserTarget]
targets

freezeAction :: FreezeFlags -> [String] -> Action
freezeAction :: FreezeFlags -> [String] -> Action
freezeAction FreezeFlags
freezeFlags [String]
_extraArgs GlobalFlags
globalFlags = do
  let verbosity :: Verbosity
verbosity =
        VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
          Flag VerbosityFlags -> VerbosityFlags
forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag VerbosityFlags
freezeVerbosity FreezeFlags
freezeFlags)
  config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  let configFlags = SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config
      globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config GlobalFlags -> GlobalFlags -> GlobalFlags
forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
  (comp, platform, progdb) <- configCompilerAux' configFlags

  withRepoContext verbosity globalFlags' $ \RepoContext
repoContext ->
    Verbosity
-> PackageDBStackCWD
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FreezeFlags
-> IO ()
freeze
      Verbosity
verbosity
      (Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack -> PackageDBStackCWD
interpretPackageDBStack Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing (ConfigFlags -> PackageDBStack
configPackageDB' ConfigFlags
configFlags))
      RepoContext
repoContext
      Compiler
comp
      Platform
platform
      ProgramDb
progdb
      GlobalFlags
globalFlags'
      FreezeFlags
freezeFlags

genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO ()
genBoundsAction :: FreezeFlags -> [String] -> Action
genBoundsAction FreezeFlags
freezeFlags [String]
_extraArgs GlobalFlags
globalFlags = do
  let verbosity :: Verbosity
verbosity =
        VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
          Flag VerbosityFlags -> VerbosityFlags
forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag VerbosityFlags
freezeVerbosity FreezeFlags
freezeFlags)
  config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  let configFlags = SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config
      globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config GlobalFlags -> GlobalFlags -> GlobalFlags
forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
  (comp, platform, progdb) <- configCompilerAux' configFlags

  withRepoContext verbosity globalFlags' $ \RepoContext
repoContext ->
    Verbosity
-> PackageDBStackCWD
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FreezeFlags
-> IO ()
genBounds
      Verbosity
verbosity
      (Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack -> PackageDBStackCWD
interpretPackageDBStack Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing (ConfigFlags -> PackageDBStack
configPackageDB' ConfigFlags
configFlags))
      RepoContext
repoContext
      Compiler
comp
      Platform
platform
      ProgramDb
progdb
      GlobalFlags
globalFlags'
      FreezeFlags
freezeFlags

uploadAction :: UploadFlags -> [String] -> Action
uploadAction :: UploadFlags -> [String] -> Action
uploadAction UploadFlags
uploadFlags [String]
extraArgs GlobalFlags
globalFlags = do
  config <- Verbosity -> Flag String -> IO SavedConfig
loadConfig Verbosity
verbosity (GlobalFlags -> Flag String
globalConfigFile GlobalFlags
globalFlags)
  let uploadFlags' = SavedConfig -> UploadFlags
savedUploadFlags SavedConfig
config UploadFlags -> UploadFlags -> UploadFlags
forall a. Monoid a => a -> a -> a
`mappend` UploadFlags
uploadFlags
      globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config GlobalFlags -> GlobalFlags -> GlobalFlags
forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
      tarfiles = [String]
extraArgs
      chosenRepo = Flag RepoName -> Maybe RepoName
forall a. Flag a -> Maybe a
flagToMaybe (Flag RepoName -> Maybe RepoName)
-> Flag RepoName -> Maybe RepoName
forall a b. (a -> b) -> a -> b
$ UploadFlags -> Flag RepoName
uploadRepoName UploadFlags
uploadFlags'
  when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $
    dieWithException verbosity UploadAction
  checkTarFiles extraArgs
  maybe_password <-
    case uploadPasswordCmd uploadFlags' of
      Flag (String
xs : [String]
xss) ->
        Password -> Maybe Password
forall a. a -> Maybe a
Just (Password -> Maybe Password)
-> (String -> Password) -> String -> Maybe Password
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Password
Password
          (String -> Maybe Password) -> IO String -> IO (Maybe Password)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput
            Verbosity
verbosity
            (String -> [String] -> ProgramInvocation
simpleProgramInvocation String
xs [String]
xss)
      Flag [String]
_ -> Maybe Password -> IO (Maybe Password)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Password -> IO (Maybe Password))
-> Maybe Password -> IO (Maybe Password)
forall a b. (a -> b) -> a -> b
$ Flag Password -> Maybe Password
forall a. Flag a -> Maybe a
flagToMaybe (Flag Password -> Maybe Password)
-> Flag Password -> Maybe Password
forall a b. (a -> b) -> a -> b
$ UploadFlags -> Flag Password
uploadPassword UploadFlags
uploadFlags'
  withRepoContext verbosity globalFlags' $ \RepoContext
repoContext -> do
    filteredRepoContext <- Verbosity -> RepoContext -> Maybe String -> IO RepoContext
chooseRepo Verbosity
verbosity RepoContext
repoContext (RepoName -> String
unRepoName (RepoName -> String) -> Maybe RepoName -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RepoName
chosenRepo)
    if fromFlag (uploadDoc uploadFlags')
      then do
        when (length tarfiles > 1) $
          dieWithException verbosity UploadActionDocumentation
        tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles
        Upload.uploadDoc
          verbosity
          filteredRepoContext
          (flagToMaybe $ uploadToken uploadFlags')
          (flagToMaybe $ uploadUsername uploadFlags')
          maybe_password
          (fromFlag (uploadCandidate uploadFlags'))
          tarfile
      else do
        Upload.upload
          verbosity
          filteredRepoContext
          (flagToMaybe $ uploadToken uploadFlags')
          (flagToMaybe $ uploadUsername uploadFlags')
          maybe_password
          (fromFlag (uploadCandidate uploadFlags'))
          tarfiles
  where
    verbosity :: Verbosity
verbosity =
      VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
        Flag VerbosityFlags -> VerbosityFlags
forall a. WithCallStack (Flag a -> a)
fromFlag (UploadFlags -> Flag VerbosityFlags
uploadVerbosity UploadFlags
uploadFlags)
    checkTarFiles :: [String] -> IO ()
checkTarFiles [String]
tarfiles
      | Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
otherFiles) =
          Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> CabalInstallException
UploadActionOnlyArchives [String]
otherFiles
      | Bool
otherwise =
          [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
            [ do
              exists <- String -> IO Bool
doesFileExist String
tarfile
              unless exists $ dieWithException verbosity $ FileNotFound tarfile
            | String
tarfile <- [String]
tarfiles
            ]
      where
        otherFiles :: [String]
otherFiles = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isTarGzFile) [String]
tarfiles
        isTarGzFile :: String -> Bool
isTarGzFile String
file = case String -> (String, String)
splitExtension String
file of
          (String
file', String
".gz") -> String -> String
takeExtension String
file' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".tar"
          (String, String)
_ -> Bool
False
    generateDocTarball :: SavedConfig -> IO String
generateDocTarball SavedConfig
config = do
      Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"No documentation tarball specified. "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Building a documentation tarball with default settings...\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"If you need to customise Haddock options, "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"run 'haddock --for-hackage' first "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"to generate a documentation tarball."
      HaddockFlags -> [String] -> Action
haddockAction
        (HaddockFlags
defaultHaddockFlags{haddockForHackage = Flag ForHackage})
        []
        GlobalFlags
globalFlags
      distPref <- SavedConfig
-> Flag (SymbolicPath Pkg ('Dir Dist))
-> IO (SymbolicPath Pkg ('Dir Dist))
findSavedDistPref SavedConfig
config Flag (SymbolicPath Pkg ('Dir Dist))
forall a. Last a
NoFlag
      let mbWorkDir = Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Flag a -> Maybe a
flagToMaybe (Flag (SymbolicPath CWD ('Dir Pkg))
 -> Maybe (SymbolicPath CWD ('Dir Pkg)))
-> Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
configWorkingDir (ConfigFlags -> Flag (SymbolicPath CWD ('Dir Pkg)))
-> ConfigFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config
      pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig mbWorkDir distPref)
      return $ getSymbolicPath distPref </> display (packageId pkg) ++ "-docs" <.> "tar.gz"

checkAction :: CheckFlags -> [String] -> Action
checkAction :: CheckFlags -> [String] -> Action
checkAction CheckFlags
checkFlags [String]
extraArgs GlobalFlags
_globalFlags = do
  let verbosityFlag :: Flag VerbosityFlags
verbosityFlag = CheckFlags -> Flag VerbosityFlags
checkVerbosity CheckFlags
checkFlags
      verbosity :: Verbosity
verbosity = VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$ Flag VerbosityFlags -> VerbosityFlags
forall a. WithCallStack (Flag a -> a)
fromFlag Flag VerbosityFlags
verbosityFlag
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
extraArgs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
      [String] -> CabalInstallException
CheckAction [String]
extraArgs
  allOk <- Verbosity -> [String] -> IO Bool
Check.check (VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$ Flag VerbosityFlags -> VerbosityFlags
forall a. WithCallStack (Flag a -> a)
fromFlag Flag VerbosityFlags
verbosityFlag) (CheckFlags -> [String]
checkIgnore CheckFlags
checkFlags)
  unless allOk exitFailure

formatAction :: Flag VerbosityFlags -> [String] -> Action
formatAction :: Flag VerbosityFlags -> [String] -> Action
formatAction Flag VerbosityFlags
verbosityFlag [String]
extraArgs GlobalFlags
_globalFlags = do
  let verbosity :: Verbosity
verbosity = VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$ Flag VerbosityFlags -> VerbosityFlags
forall a. WithCallStack (Flag a -> a)
fromFlag Flag VerbosityFlags
verbosityFlag
  Verbosity -> String -> IO ()
warn Verbosity
verbosity String
"This command is not a full formatter yet"
  path <- case [String]
extraArgs of
    [] -> RelativePath Pkg 'File -> SymbolicPath Pkg 'File
forall from (to :: FileOrDir).
RelativePath from to -> SymbolicPath from to
relativeSymbolicPath (RelativePath Pkg 'File -> SymbolicPath Pkg 'File)
-> IO (RelativePath Pkg 'File) -> IO (SymbolicPath Pkg 'File)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> IO (RelativePath Pkg 'File)
tryFindPackageDesc Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing
    (String
p : [String]
_) -> SymbolicPath Pkg 'File -> IO (SymbolicPath Pkg 'File)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymbolicPath Pkg 'File -> IO (SymbolicPath Pkg 'File))
-> SymbolicPath Pkg 'File -> IO (SymbolicPath Pkg 'File)
forall a b. (a -> b) -> a -> b
$ String -> SymbolicPath Pkg 'File
forall from (to :: FileOrDir). String -> SymbolicPath from to
makeSymbolicPath String
p
  pkgDesc <- readGenericPackageDescription verbosity Nothing path
  -- Uses 'writeFileAtomic' under the hood.
  writeGenericPackageDescription (getSymbolicPath path) pkgDesc

reportAction :: ReportFlags -> [String] -> Action
reportAction :: ReportFlags -> [String] -> Action
reportAction ReportFlags
reportFlags [String]
extraArgs GlobalFlags
globalFlags = do
  let verbosity :: Verbosity
verbosity =
        VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
          Flag VerbosityFlags -> VerbosityFlags
forall a. WithCallStack (Flag a -> a)
fromFlag (ReportFlags -> Flag VerbosityFlags
reportVerbosity ReportFlags
reportFlags)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
extraArgs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
      [String] -> CabalInstallException
ReportAction [String]
extraArgs
  config <- Verbosity -> Flag String -> IO SavedConfig
loadConfig Verbosity
verbosity (GlobalFlags -> Flag String
globalConfigFile GlobalFlags
globalFlags)
  let globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config GlobalFlags -> GlobalFlags -> GlobalFlags
forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
      reportFlags' = SavedConfig -> ReportFlags
savedReportFlags SavedConfig
config ReportFlags -> ReportFlags -> ReportFlags
forall a. Monoid a => a -> a -> a
`mappend` ReportFlags
reportFlags
      chosenRepo = Flag RepoName -> Maybe RepoName
forall a. Flag a -> Maybe a
flagToMaybe (Flag RepoName -> Maybe RepoName)
-> Flag RepoName -> Maybe RepoName
forall a b. (a -> b) -> a -> b
$ ReportFlags -> Flag RepoName
reportRepoName ReportFlags
reportFlags'
  withRepoContext verbosity globalFlags' $ \RepoContext
repoContext -> do
    filteredRepoContext <- Verbosity -> RepoContext -> Maybe String -> IO RepoContext
chooseRepo Verbosity
verbosity RepoContext
repoContext (RepoName -> String
unRepoName (RepoName -> String) -> Maybe RepoName -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RepoName
chosenRepo)
    Upload.report
      verbosity
      filteredRepoContext
      (flagToMaybe $ reportToken reportFlags')
      (flagToMaybe $ reportUsername reportFlags')
      (flagToMaybe $ reportPassword reportFlags')

runAction :: BuildFlags -> [String] -> Action
runAction :: BuildFlags -> [String] -> Action
runAction BuildFlags
buildFlags [String]
extraArgs GlobalFlags
globalFlags = do
  let common :: CommonSetupFlags
common = BuildFlags -> CommonSetupFlags
buildCommonFlags BuildFlags
buildFlags
      verbosity :: Verbosity
verbosity =
        VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
          VerbosityFlags -> Flag VerbosityFlags -> VerbosityFlags
forall a. a -> Flag a -> a
fromFlagOrDefault VerbosityFlags
normal (Flag VerbosityFlags -> VerbosityFlags)
-> Flag VerbosityFlags -> VerbosityFlags
forall a b. (a -> b) -> a -> b
$
            CommonSetupFlags -> Flag VerbosityFlags
setupVerbosity CommonSetupFlags
common
  config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  distPref <- findSavedDistPref config $ setupDistPref common
  config' <-
    reconfigure
      configureAction
      verbosity
      distPref
      (buildNumJobs buildFlags)
      mempty
      []
      globalFlags
      config
  let mbWorkDir = Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Flag a -> Maybe a
flagToMaybe (Flag (SymbolicPath CWD ('Dir Pkg))
 -> Maybe (SymbolicPath CWD ('Dir Pkg)))
-> Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ CommonSetupFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
setupWorkingDir CommonSetupFlags
common
  lbi <- getPersistBuildConfig mbWorkDir 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 -> [String] -> Action
getAction GetFlags
getFlags [String]
extraArgs GlobalFlags
globalFlags = do
  let verbosity :: Verbosity
verbosity =
        VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
          Flag VerbosityFlags -> VerbosityFlags
forall a. WithCallStack (Flag a -> a)
fromFlag (GetFlags -> Flag VerbosityFlags
getVerbosity GetFlags
getFlags)
  targets <- Verbosity -> [String] -> IO [UserTarget]
readUserTargets Verbosity
verbosity [String]
extraArgs
  config <- loadConfigOrSandboxConfig verbosity globalFlags
  let globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config GlobalFlags -> GlobalFlags -> GlobalFlags
forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
      chosenRepo = Flag RepoName -> Maybe RepoName
forall a. Flag a -> Maybe a
flagToMaybe (Flag RepoName -> Maybe RepoName)
-> Flag RepoName -> Maybe RepoName
forall a b. (a -> b) -> a -> b
$ GetFlags -> Flag RepoName
getRepoName GetFlags
getFlags
  withRepoContext verbosity (savedGlobalFlags config) $ \RepoContext
repoContext -> do
    filteredRepoContext <- Verbosity -> RepoContext -> Maybe String -> IO RepoContext
chooseRepo Verbosity
verbosity RepoContext
repoContext (RepoName -> String
unRepoName (RepoName -> String) -> Maybe RepoName -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RepoName
chosenRepo)
    get
      verbosity
      filteredRepoContext
      globalFlags'
      getFlags
      targets

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

initAction :: InitFlags -> [String] -> Action
initAction :: InitFlags -> [String] -> Action
initAction InitFlags
initFlags [String]
extraArgs GlobalFlags
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 [String]
extraArgs of
    [] -> IO ()
initAction'
    [String
projectDir] -> do
      Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True String
projectDir
      String -> IO () -> IO ()
forall a. String -> IO a -> IO a
withCurrentDirectory String
projectDir IO ()
initAction'
    [String]
_ -> Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
InitAction
  where
    initAction' :: IO ()
initAction' = do
      confFlags <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
      -- override with `--with-compiler` from CLI if available
      let confFlags' = SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
confFlags ConfigFlags -> ConfigFlags -> ConfigFlags
forall a. Monoid a => a -> a -> a
`mappend` ConfigFlags
compFlags
          initFlags' = SavedConfig -> InitFlags
savedInitFlags SavedConfig
confFlags InitFlags -> InitFlags -> InitFlags
forall a. Monoid a => a -> a -> a
`mappend` InitFlags
initFlags
          globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
confFlags GlobalFlags -> GlobalFlags -> GlobalFlags
forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags

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

      withRepoContext verbosity globalFlags' $ \RepoContext
repoContext ->
        Verbosity
-> PackageDBStackCWD
-> RepoContext
-> Compiler
-> ProgramDb
-> InitFlags
-> IO ()
initCmd
          Verbosity
verbosity
          (Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStack -> PackageDBStackCWD
interpretPackageDBStack Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing (ConfigFlags -> PackageDBStack
configPackageDB' ConfigFlags
confFlags'))
          RepoContext
repoContext
          Compiler
comp
          ProgramDb
progdb
          InitFlags
initFlags'

    verbosity :: Verbosity
verbosity =
      VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
        Flag VerbosityFlags -> VerbosityFlags
forall a. WithCallStack (Flag a -> a)
fromFlag (InitFlags -> Flag VerbosityFlags
initVerbosity InitFlags
initFlags)
    compFlags :: ConfigFlags
compFlags = ConfigFlags
forall a. Monoid a => a
mempty{configHcPath = initHcPath initFlags}

userConfigAction :: UserConfigFlags -> [String] -> Action
userConfigAction :: UserConfigFlags -> [String] -> Action
userConfigAction UserConfigFlags
ucflags [String]
extraArgs GlobalFlags
globalFlags = do
  let verbosity :: Verbosity
verbosity =
        VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
          Flag VerbosityFlags -> VerbosityFlags
forall a. WithCallStack (Flag a -> a)
fromFlag (UserConfigFlags -> Flag VerbosityFlags
userConfigVerbosity UserConfigFlags
ucflags)
      frc :: Bool
frc = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (UserConfigFlags -> Flag Bool
userConfigForce UserConfigFlags
ucflags)
      extraLines :: [String]
extraLines = Flag [String] -> [String]
forall a. WithCallStack (Flag a -> a)
fromFlag (UserConfigFlags -> Flag [String]
userConfigAppendLines UserConfigFlags
ucflags)
  case [String]
extraArgs of
    (String
"init" : [String]
_) -> do
      path <- Verbosity -> Flag String -> IO String
getConfigFilePath Verbosity
verbosity (GlobalFlags -> Flag String
globalConfigFile GlobalFlags
globalFlags)
      fileExists <- doesFileExist path
      if not fileExists || (fileExists && frc)
        then void $ createDefaultConfigFile verbosity extraLines path
        else dieWithException verbosity $ UserConfigAction path
    (String
"diff" : [String]
_) -> (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ String -> IO ()
putStrLn ([String] -> IO ()) -> IO [String] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity -> GlobalFlags -> [String] -> IO [String]
userConfigDiff Verbosity
verbosity GlobalFlags
globalFlags [String]
extraLines
    (String
"update" : [String]
_) -> Verbosity -> GlobalFlags -> [String] -> IO ()
userConfigUpdate Verbosity
verbosity GlobalFlags
globalFlags [String]
extraLines
    -- Error handling.
    [] -> Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
SpecifySubcommand
    [String]
_ -> Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> CabalInstallException
UnknownUserConfigSubcommand [String]
extraArgs

-- | 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 -> [String] -> Action
actAsSetupAction ActAsSetupFlags
actAsSetupFlags [String]
args GlobalFlags
_globalFlags =
  let bt :: BuildType
bt = Flag BuildType -> BuildType
forall a. WithCallStack (Flag a -> a)
fromFlag (ActAsSetupFlags -> Flag BuildType
actAsSetupBuildType ActAsSetupFlags
actAsSetupFlags)
   in case BuildType
bt of
        BuildType
Simple -> [String] -> IO ()
Simple.defaultMainArgs [String]
args
        BuildType
Configure ->
          SetupHooks -> VerbosityHandles -> [String] -> IO ()
Simple.defaultMainWithSetupHooksArgs
            SetupHooks
Simple.autoconfSetupHooks
            VerbosityHandles
defaultVerbosityHandles
            [String]
args
        BuildType
Make -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"actAsSetupAction Main"
        BuildType
Hooks -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"actAsSetupAction Hooks"
        BuildType
Custom -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"actAsSetupAction Custom"

manpageAction :: [CommandSpec action] -> ManpageFlags -> [String] -> Action
manpageAction :: forall action.
[CommandSpec action] -> ManpageFlags -> [String] -> Action
manpageAction [CommandSpec action]
commands ManpageFlags
flags [String]
extraArgs GlobalFlags
_ = do
  let verbosity :: Verbosity
verbosity =
        VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
          Flag VerbosityFlags -> VerbosityFlags
forall a. WithCallStack (Flag a -> a)
fromFlag (ManpageFlags -> Flag VerbosityFlags
manpageVerbosity ManpageFlags
flags)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
extraArgs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
      [String] -> CabalInstallException
ManpageAction [String]
extraArgs
  pname <- IO String
getProgName
  let cabalCmd =
        if String -> String
takeExtension String
pname String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".exe"
          then String -> String
dropExtension String
pname
          else String
pname
  manpageCmd cabalCmd commands flags

chooseRepo :: Verbosity -> RepoContext -> Maybe String -> IO RepoContext
chooseRepo :: Verbosity -> RepoContext -> Maybe String -> IO RepoContext
chooseRepo Verbosity
verbosity RepoContext
ctx Maybe String
mrepo = do
  let repos :: [Repo]
repos = RepoContext -> [Repo]
repoContextRepos RepoContext
ctx
  let remoteRepositories :: [Repo]
remoteRepositories = (Repo -> Bool) -> [Repo] -> [Repo]
forall a. (a -> Bool) -> [a] -> [a]
filter Repo -> Bool
isRepoRemote [Repo]
repos
  filtered <- case Maybe String
mrepo of
    Just String
name -> case (Repo -> Bool) -> [Repo] -> Maybe Repo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Repo
r -> String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (RepoName -> String
unRepoName (RepoName -> String) -> (Repo -> RepoName) -> Repo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Repo -> RepoName
repoName) Repo
r) [Repo]
repos of
      Just Repo
found -> [Repo] -> IO [Repo]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Repo
found]
      Maybe Repo
Nothing ->
        Verbosity -> String -> IO [Repo]
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO [Repo]) -> String -> IO [Repo]
forall a b. (a -> b) -> a -> b
$
          [String] -> String
forall a. Monoid a => [a] -> a
mconcat
            [ String
"Cannot find chosen repository "
            , String
name
            , String
"."
            , String
" Available repositories are: "
            , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Repo -> String) -> [Repo] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RepoName -> String
unRepoName (RepoName -> String) -> (Repo -> RepoName) -> Repo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Repo -> RepoName
repoName) (RepoContext -> [Repo]
repoContextRepos RepoContext
ctx))
            ]
    Maybe String
Nothing -> [Repo] -> IO [Repo]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Repo]
remoteRepositories
  if length filtered > 1
    then
      die'
        verbosity
        $ mconcat
          [ "Cannot determine a specific hackage repository. Please choose one with --repository-name."
          , " Available repositories are: "
          , intercalate ", " (fmap (unRepoName . repoName) (repoContextRepos ctx))
          ]
    else pure ctx{repoContextRepos = filtered}