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

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

module Distribution.Client.Main (main) where

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

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

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

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

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

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

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

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


-- | Entry point
--
main :: [String] -> IO ()
main :: [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
  let ([String]
args0, [String]
args1) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== String
"--") [String]
args

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

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

mainWorker :: [String] -> IO ()
mainWorker :: [String] -> IO ()
mainWorker [String]
args = do
  forall a. IO a -> IO a
topHandler forall a b. (a -> b) -> a -> b
$
    case forall a action.
CommandUI a
-> [Command action]
-> [String]
-> CommandParse (a, CommandParse action)
commandsRun (forall action. [Command action] -> CommandUI GlobalFlags
globalCommand [Command Action]
commands) [Command Action]
commands [String]
args of
      CommandHelp   String -> String
help                 -> (String -> String) -> IO ()
printGlobalHelp String -> String
help
      CommandList   [String]
opts                 -> [String] -> IO ()
printOptionsList [String]
opts
      CommandErrors [String]
errs                 -> forall {a}. [String] -> IO a
printErrors [String]
errs
      CommandReadyToGo (GlobalFlags
globalFlags, CommandParse Action
commandParse)  ->
        case CommandParse Action
commandParse of
          CommandParse Action
_ | forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (GlobalFlags -> Flag Bool
globalVersion GlobalFlags
globalFlags)
              -> IO ()
printVersion
            | 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
              []      -> forall {a}. [String] -> IO a
printErrors [String]
errs
              String
script : [String]
scriptArgs -> String -> IO Bool
CmdRun.validScript String
script forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Bool
False -> 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
    printCommandHelp :: (String -> String) -> IO ()
printCommandHelp String -> String
help = do
      String
pname <- IO String
getProgName
      String -> IO ()
putStr (String -> String
help String
pname)
    printGlobalHelp :: (String -> String) -> IO ()
printGlobalHelp String -> String
help = do
      String
pname <- IO String
getProgName
      String
configFile <- IO String
defaultConfigFile
      String -> IO ()
putStr (String -> String
help String
pname)
      String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ String
"\nYou can edit the cabal configuration file to set defaults:\n"
            forall a. [a] -> [a] -> [a]
++ String
"  " forall a. [a] -> [a] -> [a]
++ String
configFile forall a. [a] -> [a] -> [a]
++ String
"\n"
      Bool
exists <- String -> IO Bool
doesFileExist String
configFile
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$
          String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"This file will be generated with sensible "
                  forall a. [a] -> [a] -> [a]
++ String
"defaults if you run 'cabal update'."
    printOptionsList :: [String] -> IO ()
printOptionsList = String -> IO ()
putStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines
    printErrors :: [String] -> IO a
printErrors [String]
errs = forall a. String -> IO a
dieNoVerbosity forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [String]
errs
    printNumericVersion :: IO ()
printNumericVersion = String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> String
display Version
cabalInstallVersion
    printVersion :: IO ()
printVersion        = String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"cabal-install version "
                                  forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
display Version
cabalInstallVersion
                                  forall a. [a] -> [a] -> [a]
++ String
"\ncompiled using version "
                                  forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
display Version
cabalVersion
                                  forall a. [a] -> [a] -> [a]
++ String
" of the Cabal library "

    commands :: [Command Action]
commands = forall a b. (a -> b) -> [a] -> [b]
map forall a. CommandSpec a -> Command a
commandFromSpec [CommandSpec Action]
commandSpecs
    commandSpecs :: [CommandSpec Action]
commandSpecs =
      [ forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI ListFlags
listCommand ListFlags -> [String] -> Action
listAction
      , forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI InfoFlags
infoCommand InfoFlags -> [String] -> Action
infoAction
      , forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI FetchFlags
fetchCommand FetchFlags -> [String] -> Action
fetchAction
      , forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI GetFlags
getCommand GetFlags -> [String] -> Action
getAction
      , forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI GetFlags
unpackCommand GetFlags -> [String] -> Action
unpackAction
      , forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI (Flag Verbosity)
checkCommand Flag Verbosity -> [String] -> Action
checkAction
      , forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI UploadFlags
uploadCommand UploadFlags -> [String] -> Action
uploadAction
      , forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI ReportFlags
reportCommand ReportFlags -> [String] -> Action
reportAction
      , forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI InitFlags
initCommand InitFlags -> [String] -> Action
initAction
      , forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI UserConfigFlags
userConfigCommand UserConfigFlags -> [String] -> Action
userConfigAction
      , forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI FreezeFlags
genBoundsCommand FreezeFlags -> [String] -> Action
genBoundsAction
      , forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI (ProjectFlags, OutdatedFlags)
CmdOutdated.outdatedCommand (ProjectFlags, OutdatedFlags) -> [String] -> Action
CmdOutdated.outdatedAction
      , forall flags.
Monoid flags =>
CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag String)
-> CommandSpec Action
wrapperCmd CommandUI HscolourFlags
hscolourCommand HscolourFlags -> Flag Verbosity
hscolourVerbosity HscolourFlags -> Flag String
hscolourDistPref
      , forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
hiddenCmd  CommandUI (Flag Verbosity)
formatCommand Flag Verbosity -> [String] -> Action
formatAction
      , forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
hiddenCmd  CommandUI ActAsSetupFlags
actAsSetupCommand ActAsSetupFlags -> [String] -> Action
actAsSetupAction
      , forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
hiddenCmd  CommandUI ManpageFlags
manpageCommand (forall action.
[CommandSpec action] -> ManpageFlags -> [String] -> Action
manpageAction [CommandSpec Action]
commandSpecs)
      , forall flags action.
CommandUI flags
-> (flags -> [String] -> action) -> CommandSpec action
regularCmd CommandUI (NixStyleFlags ())
CmdListBin.listbinCommand     NixStyleFlags () -> [String] -> Action
CmdListBin.listbinAction

      ] forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ 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
      , 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
      , 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
      , forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd  CommandUI (NixStyleFlags (ReplOptions, EnvFlags))
CmdRepl.replCommand           NixStyleFlags (ReplOptions, EnvFlags) -> [String] -> Action
CmdRepl.replAction
      , 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
      , 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
      , 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
      , 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
      , 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
      , 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
      , 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
      , 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
      , forall flags globals action.
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd  CommandUI CleanFlags
CmdClean.cleanCommand         CleanFlags -> [String] -> Action
CmdClean.cleanAction
      , 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

      , 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
      , 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
      , 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
      , 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
      , 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
      , 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
      , 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
      , 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
      , 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
      , 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
      , forall flags.
Monoid flags =>
CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag String)
-> [CommandSpec Action]
legacyWrapperCmd CommandUI CopyFlags
copyCommand CopyFlags -> Flag Verbosity
copyVerbosity CopyFlags -> Flag String
copyDistPref
      , forall flags.
Monoid flags =>
CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag String)
-> [CommandSpec Action]
legacyWrapperCmd CommandUI RegisterFlags
registerCommand RegisterFlags -> Flag Verbosity
regVerbosity RegisterFlags -> Flag String
regDistPref
      , 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 =
  forall action flags.
CommandUI flags
-> (CommandUI flags -> Command action)
-> CommandType
-> CommandSpec action
CommandSpec CommandUI flags
ui ((forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 =
  forall action flags.
CommandUI flags
-> (CommandUI flags -> Command action)
-> CommandType
-> CommandSpec action
CommandSpec CommandUI flags
ui (\CommandUI flags
ui' -> forall action. Command action -> Command action
hiddenCommand (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 -> Flag Verbosity)
           -> (flags -> Flag String) -> CommandSpec Action
wrapperCmd :: forall flags.
Monoid flags =>
CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag String)
-> CommandSpec Action
wrapperCmd CommandUI flags
ui flags -> Flag Verbosity
verbosity flags -> Flag String
distPref =
  forall action flags.
CommandUI flags
-> (CommandUI flags -> Command action)
-> CommandType
-> CommandSpec action
CommandSpec CommandUI flags
ui (\CommandUI flags
ui' -> forall flags.
Monoid flags =>
CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag String)
-> Command Action
wrapperAction CommandUI flags
ui' flags -> Flag Verbosity
verbosity flags -> Flag String
distPref) CommandType
NormalCommand

wrapperAction :: Monoid flags
              => CommandUI flags
              -> (flags -> Flag Verbosity)
              -> (flags -> Flag String)
              -> Command Action
wrapperAction :: forall flags.
Monoid flags =>
CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag String)
-> Command Action
wrapperAction CommandUI flags
command flags -> Flag Verbosity
verbosityFlag flags -> Flag String
distPrefFlag =
  forall flags action.
CommandUI flags -> (flags -> [String] -> action) -> Command action
commandAddAction CommandUI flags
command
    { commandDefaultFlags :: flags
commandDefaultFlags = forall a. Monoid a => a
mempty } forall a b. (a -> b) -> a -> b
$ \flags
flags [String]
extraArgs GlobalFlags
globalFlags -> do
    let verbosity :: Verbosity
verbosity = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (flags -> Flag Verbosity
verbosityFlag flags
flags)
    Either SomeException SavedConfig
load <- forall e a. Exception e => IO a -> IO (Either e a)
try (Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags)
    let config :: SavedConfig
config = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(SomeException e
_) -> forall a. Monoid a => a
mempty) forall a. a -> a
id Either SomeException SavedConfig
load
    String
distPref <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config (flags -> Flag String
distPrefFlag flags
flags)
    let setupScriptOptions :: SetupScriptOptions
setupScriptOptions = SetupScriptOptions
defaultSetupScriptOptions { useDistPref :: String
useDistPref = String
distPref }
    forall flags.
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [String])
-> IO ()
setupWrapper Verbosity
verbosity SetupScriptOptions
setupScriptOptions forall a. Maybe a
Nothing
                 CommandUI flags
command (forall a b. a -> b -> a
const flags
flags) (forall a b. a -> b -> a
const [String]
extraArgs)

configureAction :: (ConfigFlags, ConfigExFlags)
                -> [String] -> Action
configureAction :: (ConfigFlags, ConfigExFlags) -> [String] -> Action
configureAction (ConfigFlags
configFlags, ConfigExFlags
configExFlags) [String]
extraArgs GlobalFlags
globalFlags = do
  let verbosity :: Verbosity
verbosity = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
configFlags)
  SavedConfig
config <- Flag Bool -> SavedConfig -> SavedConfig
updateInstallDirs (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags)
                          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  String
distPref <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config (ConfigFlags -> Flag String
configDistPref ConfigFlags
configFlags)
  Verbosity -> String -> Bool -> GlobalFlags -> SavedConfig -> IO ()
nixInstantiate Verbosity
verbosity String
distPref Bool
True GlobalFlags
globalFlags SavedConfig
config
  Verbosity -> String -> GlobalFlags -> SavedConfig -> IO () -> IO ()
nixShell Verbosity
verbosity String
distPref GlobalFlags
globalFlags SavedConfig
config forall a b. (a -> b) -> a -> b
$ do
    let configFlags' :: ConfigFlags
configFlags'   = SavedConfig -> ConfigFlags
savedConfigureFlags   SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend` ConfigFlags
configFlags
        configExFlags' :: ConfigExFlags
configExFlags' = SavedConfig -> ConfigExFlags
savedConfigureExFlags SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend` ConfigExFlags
configExFlags
        globalFlags' :: GlobalFlags
globalFlags'   = SavedConfig -> GlobalFlags
savedGlobalFlags      SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
    (Compiler
comp, Platform
platform, ProgramDb
progdb) <- ConfigFlags -> IO (Compiler, Platform, ProgramDb)
configCompilerAuxEx ConfigFlags
configFlags'

    Verbosity -> String -> (ConfigFlags, ConfigExFlags) -> IO ()
writeConfigFlags Verbosity
verbosity String
distPref (ConfigFlags
configFlags', ConfigExFlags
configExFlags')

    -- What package database(s) to use
    let packageDBs :: PackageDBStack
        packageDBs :: PackageDBStack
packageDBs
          = Bool -> [Maybe PackageDB] -> PackageDBStack
interpretPackageDbFlags
            (forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags'))
            (ConfigFlags -> [Maybe PackageDB]
configPackageDBs ConfigFlags
configFlags')

    forall a. Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext Verbosity
verbosity GlobalFlags
globalFlags' forall a b. (a -> b) -> a -> b
$ \RepoContext
repoContext ->
        Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> ConfigFlags
-> ConfigExFlags
-> [String]
-> IO ()
configure Verbosity
verbosity 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 verbosity :: Verbosity
verbosity = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
configFlags)
  SavedConfig
config <- Flag Bool -> SavedConfig -> SavedConfig
updateInstallDirs (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags)
                          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  String
distPref <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config (ConfigFlags -> Flag String
configDistPref ConfigFlags
configFlags)
  let checkFlags :: Check (ConfigFlags, ConfigExFlags)
checkFlags = forall a. (Any -> a -> IO (Any, a)) -> Check a
Check forall a b. (a -> b) -> a -> b
$ \Any
_ (ConfigFlags, ConfigExFlags)
saved -> do
        let flags' :: (ConfigFlags, ConfigExFlags)
flags' = (ConfigFlags, ConfigExFlags)
saved forall a. Semigroup a => a -> a -> a
<> (ConfigFlags, ConfigExFlags)
flags
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((ConfigFlags, ConfigExFlags)
saved forall a. Eq a => a -> a -> Bool
== (ConfigFlags, ConfigExFlags)
flags') forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
info Verbosity
verbosity String
message
        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: "
            forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (forall flags. CommandUI flags -> flags -> [String]
commandShowOptions CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand (ConfigFlags, ConfigExFlags)
flags)
  Verbosity -> String -> Bool -> GlobalFlags -> SavedConfig -> IO ()
nixInstantiate Verbosity
verbosity String
distPref Bool
True GlobalFlags
globalFlags SavedConfig
config
  SavedConfig
_ <-
    ((ConfigFlags, ConfigExFlags) -> [String] -> Action)
-> Verbosity
-> String
-> Flag (Maybe Int)
-> Check (ConfigFlags, ConfigExFlags)
-> [String]
-> GlobalFlags
-> SavedConfig
-> IO SavedConfig
reconfigure (ConfigFlags, ConfigExFlags) -> [String] -> Action
configureAction
    Verbosity
verbosity String
distPref forall a. Flag a
NoFlag
    Check (ConfigFlags, ConfigExFlags)
checkFlags [] GlobalFlags
globalFlags SavedConfig
config
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

buildAction :: BuildFlags -> [String] -> Action
buildAction :: BuildFlags -> [String] -> Action
buildAction BuildFlags
buildFlags [String]
extraArgs GlobalFlags
globalFlags = do
  let verbosity :: Verbosity
verbosity = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (BuildFlags -> Flag Verbosity
buildVerbosity BuildFlags
buildFlags)
  SavedConfig
config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  String
distPref <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config (BuildFlags -> Flag String
buildDistPref BuildFlags
buildFlags)
  -- Calls 'configureAction' to do the real work, so nothing special has to be
  -- done to support sandboxes.
  SavedConfig
config' <-
    ((ConfigFlags, ConfigExFlags) -> [String] -> Action)
-> Verbosity
-> String
-> Flag (Maybe Int)
-> Check (ConfigFlags, ConfigExFlags)
-> [String]
-> GlobalFlags
-> SavedConfig
-> IO SavedConfig
reconfigure (ConfigFlags, ConfigExFlags) -> [String] -> Action
configureAction
    Verbosity
verbosity String
distPref (BuildFlags -> Flag (Maybe Int)
buildNumJobs BuildFlags
buildFlags)
    forall a. Monoid a => a
mempty [] GlobalFlags
globalFlags SavedConfig
config
  Verbosity -> String -> GlobalFlags -> SavedConfig -> IO () -> IO ()
nixShell Verbosity
verbosity String
distPref GlobalFlags
globalFlags SavedConfig
config forall a b. (a -> b) -> a -> b
$ do
    Verbosity
-> SavedConfig -> String -> BuildFlags -> [String] -> IO ()
build Verbosity
verbosity SavedConfig
config' String
distPref BuildFlags
buildFlags [String]
extraArgs


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

    mkBuildFlags :: Version -> BuildFlags
mkBuildFlags Version
version = Version -> SavedConfig -> BuildFlags -> BuildFlags
filterBuildFlags Version
version SavedConfig
config BuildFlags
buildFlags'
    buildFlags' :: BuildFlags
buildFlags' = BuildFlags
buildFlags
      { buildVerbosity :: Flag Verbosity
buildVerbosity = forall a. a -> Flag a
toFlag Verbosity
verbosity
      , buildDistPref :: Flag String
buildDistPref  = forall a. a -> Flag a
toFlag String
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
  | Version
version 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 :: Flag (Maybe Int)
buildNumJobs = forall a. Flag a
NoFlag
      }
    buildFlags_latest :: BuildFlags
buildFlags_latest     = BuildFlags
buildFlags {
      -- Take the 'jobs' setting config file into account.
      buildNumJobs :: Flag (Maybe Int)
buildNumJobs = forall a. a -> Flag a
Flag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag (Maybe Int) -> Int
determineNumJobs forall a b. (a -> b) -> a -> b
$
                     (Flag (Maybe Int)
numJobsConfigFlag forall a. Monoid a => a -> a -> a
`mappend` Flag (Maybe Int)
numJobsCmdLineFlag)
      }
    numJobsConfigFlag :: Flag (Maybe Int)
numJobsConfigFlag  = InstallFlags -> Flag (Maybe Int)
installNumJobs forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> InstallFlags
savedInstallFlags 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 verbosity :: Verbosity
verbosity = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (ReplFlags -> Flag Verbosity
replVerbosity ReplFlags
replFlags)
  SavedConfig
config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  String
distPref <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config (ReplFlags -> Flag String
replDistPref ReplFlags
replFlags)
  String
cwd     <- IO String
getCurrentDirectory
  Either String String
pkgDesc <- String -> IO (Either String String)
findPackageDesc String
cwd
  let
    -- There is a .cabal file in the current directory: start a REPL and load
    -- the project's modules.
    onPkgDesc :: IO ()
onPkgDesc = do
      -- Calls 'configureAction' to do the real work, so nothing special has to
      -- be done to support sandboxes.
      SavedConfig
_ <-
        ((ConfigFlags, ConfigExFlags) -> [String] -> Action)
-> Verbosity
-> String
-> Flag (Maybe Int)
-> Check (ConfigFlags, ConfigExFlags)
-> [String]
-> GlobalFlags
-> SavedConfig
-> IO SavedConfig
reconfigure (ConfigFlags, ConfigExFlags) -> [String] -> Action
configureAction
        Verbosity
verbosity String
distPref forall a. Flag a
NoFlag
        forall a. Monoid a => a
mempty [] GlobalFlags
globalFlags SavedConfig
config
      let progDb :: ProgramDb
progDb = ProgramDb
defaultProgramDb
          setupOptions :: SetupScriptOptions
setupOptions = SetupScriptOptions
defaultSetupScriptOptions
            { useCabalVersion :: VersionRange
useCabalVersion = Version -> VersionRange
orLaterVersion forall a b. (a -> b) -> a -> b
$ [Int] -> Version
mkVersion [Int
1,Int
18,Int
0]
            , useDistPref :: String
useDistPref     = String
distPref
            }
          replFlags' :: ReplFlags
replFlags'   = ReplFlags
replFlags
            { replVerbosity :: Flag Verbosity
replVerbosity = forall a. a -> Flag a
toFlag Verbosity
verbosity
            , replDistPref :: Flag String
replDistPref  = forall a. a -> Flag a
toFlag String
distPref
            }

      Verbosity -> String -> GlobalFlags -> SavedConfig -> IO () -> IO ()
nixShell Verbosity
verbosity String
distPref GlobalFlags
globalFlags SavedConfig
config forall a b. (a -> b) -> a -> b
$
        forall flags.
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [String])
-> IO ()
setupWrapper Verbosity
verbosity SetupScriptOptions
setupOptions forall a. Maybe a
Nothing (ProgramDb -> CommandUI ReplFlags
Cabal.replCommand ProgramDb
progDb) (forall a b. a -> b -> a
const ReplFlags
replFlags') (forall a b. a -> b -> a
const [String]
extraArgs)

    -- No .cabal file in the current directory: just start the REPL (possibly
    -- using the sandbox package DB).
    onNoPkgDesc :: IO ()
onNoPkgDesc = do
      let configFlags :: ConfigFlags
configFlags = SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config
      (Compiler
comp, Platform
platform, ProgramDb
programDb) <- ConfigFlags -> IO (Compiler, Platform, ProgramDb)
configCompilerAux' ConfigFlags
configFlags
      ProgramDb
programDb' <- Verbosity
-> [(String, String)]
-> [(String, [String])]
-> ProgramDb
-> IO ProgramDb
reconfigurePrograms Verbosity
verbosity
                                        (ReplFlags -> [(String, String)]
replProgramPaths ReplFlags
replFlags)
                                        (ReplFlags -> [(String, [String])]
replProgramArgs ReplFlags
replFlags)
                                        ProgramDb
programDb
      Verbosity -> String -> GlobalFlags -> SavedConfig -> IO () -> IO ()
nixShell Verbosity
verbosity String
distPref GlobalFlags
globalFlags SavedConfig
config forall a b. (a -> b) -> a -> b
$ do
        Verbosity
-> ProgramDb -> Compiler -> Platform -> PackageDBStack -> IO ()
startInterpreter Verbosity
verbosity ProgramDb
programDb' Compiler
comp Platform
platform
                        (ConfigFlags -> PackageDBStack
configPackageDB' ConfigFlags
configFlags)

  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const IO ()
onNoPkgDesc) (forall a b. a -> b -> a
const IO ()
onPkgDesc) Either String String
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
  | forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (InstallFlags -> Flag Bool
installOnly InstallFlags
installFlags) = do
      let verb :: Verbosity
verb = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
configFlags)
      SavedConfig
config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verb GlobalFlags
globalFlags
      String
dist <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config (ConfigFlags -> Flag String
configDistPref ConfigFlags
configFlags)
      let setupOpts :: SetupScriptOptions
setupOpts = SetupScriptOptions
defaultSetupScriptOptions { useDistPref :: String
useDistPref = String
dist }
      forall flags.
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [String])
-> IO ()
setupWrapper
        Verbosity
verb SetupScriptOptions
setupOpts forall a. Maybe a
Nothing
        CommandUI
  (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags,
   BenchmarkFlags)
installCommand (forall a b. a -> b -> a
const (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty))
                       (forall a b. a -> b -> a
const [])

installAction
  ( ConfigFlags
configFlags, ConfigExFlags
configExFlags, InstallFlags
installFlags
  , HaddockFlags
haddockFlags, TestFlags
testFlags, BenchmarkFlags
benchmarkFlags )
  [String]
extraArgs GlobalFlags
globalFlags = do
  let verb :: Verbosity
verb = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
configFlags)
  SavedConfig
config <- Flag Bool -> SavedConfig -> SavedConfig
updateInstallDirs (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags)
                          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verb GlobalFlags
globalFlags

  String
dist <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config (ConfigFlags -> Flag String
configDistPref ConfigFlags
configFlags)

  do
    [UserTarget]
targets <- Verbosity -> [String] -> IO [UserTarget]
readUserTargets Verbosity
verb [String]
extraArgs

    let configFlags' :: ConfigFlags
configFlags'    = InstallFlags -> ConfigFlags -> ConfigFlags
maybeForceTests InstallFlags
installFlags' forall a b. (a -> b) -> a -> b
$
                          SavedConfig -> ConfigFlags
savedConfigureFlags   SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend`
                          ConfigFlags
configFlags { configDistPref :: Flag String
configDistPref = forall a. a -> Flag a
toFlag String
dist }
        configExFlags' :: ConfigExFlags
configExFlags'  = ConfigExFlags
defaultConfigExFlags         forall a. Monoid a => a -> a -> a
`mappend`
                          SavedConfig -> ConfigExFlags
savedConfigureExFlags SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend` ConfigExFlags
configExFlags
        installFlags' :: InstallFlags
installFlags'   = InstallFlags
defaultInstallFlags          forall a. Monoid a => a -> a -> a
`mappend`
                          SavedConfig -> InstallFlags
savedInstallFlags     SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend` InstallFlags
installFlags
        haddockFlags' :: HaddockFlags
haddockFlags'   = HaddockFlags
defaultHaddockFlags          forall a. Monoid a => a -> a -> a
`mappend`
                          SavedConfig -> HaddockFlags
savedHaddockFlags     SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend`
                          HaddockFlags
haddockFlags { haddockDistPref :: Flag String
haddockDistPref = forall a. a -> Flag a
toFlag String
dist }
        testFlags' :: TestFlags
testFlags'      = TestFlags
Cabal.defaultTestFlags       forall a. Monoid a => a -> a -> a
`mappend`
                          SavedConfig -> TestFlags
savedTestFlags        SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend`
                          TestFlags
testFlags { testDistPref :: Flag String
testDistPref = forall a. a -> Flag a
toFlag String
dist }
        benchmarkFlags' :: BenchmarkFlags
benchmarkFlags' = BenchmarkFlags
Cabal.defaultBenchmarkFlags  forall a. Monoid a => a -> a -> a
`mappend`
                          SavedConfig -> BenchmarkFlags
savedBenchmarkFlags   SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend`
                          BenchmarkFlags
benchmarkFlags { benchmarkDistPref :: Flag String
benchmarkDistPref = forall a. a -> Flag a
toFlag String
dist }
        globalFlags' :: GlobalFlags
globalFlags'    = SavedConfig -> GlobalFlags
savedGlobalFlags      SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
    (Compiler
comp, Platform
platform, ProgramDb
progdb) <- ConfigFlags -> IO (Compiler, Platform, ProgramDb)
configCompilerAux' ConfigFlags
configFlags'

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

    ConfigFlags
configFlags'' <- ConfigFlags -> IO ConfigFlags
configAbsolutePaths ConfigFlags
configFlags'

    forall a. Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext Verbosity
verb GlobalFlags
globalFlags' forall a b. (a -> b) -> a -> b
$ \RepoContext
repoContext ->
        Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> HaddockFlags
-> TestFlags
-> BenchmarkFlags
-> [UserTarget]
-> IO ()
install Verbosity
verb
                (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 forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (InstallFlags -> Flag Bool
installRunTests InstallFlags
installFlags')
          then ConfigFlags
configFlags' { configTests :: Flag Bool
configTests = forall a. a -> Flag a
toFlag Bool
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      = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (BuildFlags -> Flag Verbosity
buildVerbosity BuildFlags
buildFlags)
  SavedConfig
config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  String
distPref <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config (TestFlags -> Flag String
testDistPref TestFlags
testFlags)
  let buildFlags' :: BuildFlags
buildFlags'    = BuildFlags
buildFlags
                      { buildVerbosity :: Flag Verbosity
buildVerbosity = TestFlags -> Flag Verbosity
testVerbosity TestFlags
testFlags }
      checkFlags :: Check (ConfigFlags, b)
checkFlags = forall a. (Any -> a -> IO (Any, a)) -> Check a
Check forall a b. (a -> b) -> a -> b
$ \Any
_ flags :: (ConfigFlags, b)
flags@(ConfigFlags
configFlags, b
configExFlags) ->
        if forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (ConfigFlags -> Flag Bool
configTests ConfigFlags
configFlags)
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 :: Flag Bool
configTests = forall a. a -> Flag a
toFlag Bool
True }
                        , b
configExFlags
                        )
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Any
Any Bool
True, (ConfigFlags, b)
flags')

  SavedConfig
_ <-
    ((ConfigFlags, ConfigExFlags) -> [String] -> Action)
-> Verbosity
-> String
-> Flag (Maybe Int)
-> Check (ConfigFlags, ConfigExFlags)
-> [String]
-> GlobalFlags
-> SavedConfig
-> IO SavedConfig
reconfigure (ConfigFlags, ConfigExFlags) -> [String] -> Action
configureAction
    Verbosity
verbosity String
distPref (BuildFlags -> Flag (Maybe Int)
buildNumJobs BuildFlags
buildFlags')
    forall {b}. Check (ConfigFlags, b)
checkFlags [] GlobalFlags
globalFlags SavedConfig
config
  Verbosity -> String -> GlobalFlags -> SavedConfig -> IO () -> IO ()
nixShell Verbosity
verbosity String
distPref GlobalFlags
globalFlags SavedConfig
config forall a b. (a -> b) -> a -> b
$ do
    let setupOptions :: SetupScriptOptions
setupOptions   = SetupScriptOptions
defaultSetupScriptOptions { useDistPref :: String
useDistPref = String
distPref }
        testFlags' :: TestFlags
testFlags'     = TestFlags
testFlags { testDistPref :: Flag String
testDistPref = forall a. a -> Flag a
toFlag String
distPref }

    -- The package was just configured, so the LBI must be available.
    ComponentNames
names <- Verbosity
-> String -> String -> (Component -> Bool) -> IO ComponentNames
componentNamesFromLBI Verbosity
verbosity String
distPref String
"test suites"
              (\Component
c -> case Component
c of { LBI.CTest{} -> Bool
True; Component
_ -> Bool
False })
    let extraArgs' :: [String]
extraArgs'
          | 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

    Verbosity
-> SavedConfig -> String -> BuildFlags -> [String] -> IO ()
build Verbosity
verbosity SavedConfig
config String
distPref BuildFlags
buildFlags' [String]
extraArgs'
    forall flags.
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [String])
-> IO ()
setupWrapper Verbosity
verbosity SetupScriptOptions
setupOptions forall a. Maybe a
Nothing CommandUI TestFlags
Cabal.testCommand (forall a b. a -> b -> a
const TestFlags
testFlags') (forall a b. a -> b -> a
const [String]
extraArgs')

data ComponentNames = ComponentNamesUnknown
                    | ComponentNames [LBI.ComponentName]

-- | Return the names of all buildable components matching a given predicate.
componentNamesFromLBI :: Verbosity -> FilePath -> String
                         -> (LBI.Component -> Bool)
                         -> IO ComponentNames
componentNamesFromLBI :: Verbosity
-> String -> String -> (Component -> Bool) -> IO ComponentNames
componentNamesFromLBI Verbosity
verbosity String
distPref String
targetsDescr Component -> Bool
compPred = do
  Either ConfigStateFileError LocalBuildInfo
eLBI <- String -> IO (Either ConfigStateFileError LocalBuildInfo)
tryGetPersistBuildConfig String
distPref
  case Either ConfigStateFileError LocalBuildInfo
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 PackageIdentifier
_ PackageIdentifier
_ Either ConfigStateFileError LocalBuildInfo
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ComponentNames
ComponentNamesUnknown
      ConfigStateFileError
_                               -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (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    = forall a b. (a -> b) -> [a] -> [b]
map Component -> ComponentName
LBI.componentName
                     forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (BuildInfo -> Bool
buildable forall b c a. (b -> c) -> (a -> b) -> a -> c
. Component -> BuildInfo
LBI.componentBuildInfo)
                     forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter Component -> Bool
compPred forall a b. (a -> b) -> a -> b
$
                     PackageDescription -> [Component]
LBI.pkgComponents PackageDescription
pkgDescr
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ComponentName]
names
        then do Verbosity -> String -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Package has no buildable "
                  forall a. [a] -> [a] -> [a]
++ String
targetsDescr forall a. [a] -> [a] -> [a]
++ String
"."
                forall a. IO a
exitSuccess -- See #3215.

        else forall (m :: * -> *) a. Monad m => a -> m a
return 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      = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal
                       (BuildFlags -> Flag Verbosity
buildVerbosity BuildFlags
buildFlags)

  SavedConfig
config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  String
distPref <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config (BenchmarkFlags -> Flag String
benchmarkDistPref BenchmarkFlags
benchmarkFlags)
  let buildFlags' :: BuildFlags
buildFlags'    = BuildFlags
buildFlags
                      { buildVerbosity :: Flag Verbosity
buildVerbosity = BenchmarkFlags -> Flag Verbosity
benchmarkVerbosity BenchmarkFlags
benchmarkFlags }

  let checkFlags :: Check (ConfigFlags, b)
checkFlags = forall a. (Any -> a -> IO (Any, a)) -> Check a
Check forall a b. (a -> b) -> a -> b
$ \Any
_ flags :: (ConfigFlags, b)
flags@(ConfigFlags
configFlags, b
configExFlags) ->
        if forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (ConfigFlags -> Flag Bool
configBenchmarks ConfigFlags
configFlags)
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 :: Flag Bool
configBenchmarks = forall a. a -> Flag a
toFlag Bool
True }
                        , b
configExFlags
                        )
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Any
Any Bool
True, (ConfigFlags, b)
flags')

  SavedConfig
config' <-
    ((ConfigFlags, ConfigExFlags) -> [String] -> Action)
-> Verbosity
-> String
-> Flag (Maybe Int)
-> Check (ConfigFlags, ConfigExFlags)
-> [String]
-> GlobalFlags
-> SavedConfig
-> IO SavedConfig
reconfigure (ConfigFlags, ConfigExFlags) -> [String] -> Action
configureAction
    Verbosity
verbosity String
distPref (BuildFlags -> Flag (Maybe Int)
buildNumJobs BuildFlags
buildFlags')
    forall {b}. Check (ConfigFlags, b)
checkFlags [] GlobalFlags
globalFlags SavedConfig
config
  Verbosity -> String -> GlobalFlags -> SavedConfig -> IO () -> IO ()
nixShell Verbosity
verbosity String
distPref GlobalFlags
globalFlags SavedConfig
config forall a b. (a -> b) -> a -> b
$ do
    let setupOptions :: SetupScriptOptions
setupOptions   = SetupScriptOptions
defaultSetupScriptOptions { useDistPref :: String
useDistPref = String
distPref }
        benchmarkFlags' :: BenchmarkFlags
benchmarkFlags'= BenchmarkFlags
benchmarkFlags { benchmarkDistPref :: Flag String
benchmarkDistPref = forall a. a -> Flag a
toFlag String
distPref }

    -- The package was just configured, so the LBI must be available.
    ComponentNames
names <- Verbosity
-> String -> String -> (Component -> Bool) -> IO ComponentNames
componentNamesFromLBI Verbosity
verbosity String
distPref String
"benchmarks"
            (\Component
c -> case Component
c of { LBI.CBench{} -> Bool
True; Component
_ -> Bool
False; })
    let extraArgs' :: [String]
extraArgs'
          | 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

    Verbosity
-> SavedConfig -> String -> BuildFlags -> [String] -> IO ()
build Verbosity
verbosity SavedConfig
config' String
distPref BuildFlags
buildFlags' [String]
extraArgs'
    forall flags.
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [String])
-> IO ()
setupWrapper Verbosity
verbosity SetupScriptOptions
setupOptions forall a. Maybe a
Nothing CommandUI BenchmarkFlags
Cabal.benchmarkCommand (forall a b. a -> b -> a
const BenchmarkFlags
benchmarkFlags') (forall a b. a -> b -> a
const [String]
extraArgs')

haddockAction :: HaddockFlags -> [String] -> Action
haddockAction :: HaddockFlags -> [String] -> Action
haddockAction HaddockFlags
haddockFlags [String]
extraArgs GlobalFlags
globalFlags = do
  let verbosity :: Verbosity
verbosity = forall a. WithCallStack (Flag a -> a)
fromFlag (HaddockFlags -> Flag Verbosity
haddockVerbosity HaddockFlags
haddockFlags)
  SavedConfig
config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  String
distPref <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config (HaddockFlags -> Flag String
haddockDistPref HaddockFlags
haddockFlags)
  SavedConfig
config' <-
    ((ConfigFlags, ConfigExFlags) -> [String] -> Action)
-> Verbosity
-> String
-> Flag (Maybe Int)
-> Check (ConfigFlags, ConfigExFlags)
-> [String]
-> GlobalFlags
-> SavedConfig
-> IO SavedConfig
reconfigure (ConfigFlags, ConfigExFlags) -> [String] -> Action
configureAction
    Verbosity
verbosity String
distPref forall a. Flag a
NoFlag
    forall a. Monoid a => a
mempty [] GlobalFlags
globalFlags SavedConfig
config
  Verbosity -> String -> GlobalFlags -> SavedConfig -> IO () -> IO ()
nixShell Verbosity
verbosity String
distPref GlobalFlags
globalFlags SavedConfig
config forall a b. (a -> b) -> a -> b
$ do
    let haddockFlags' :: HaddockFlags
haddockFlags' = HaddockFlags
defaultHaddockFlags      forall a. Monoid a => a -> a -> a
`mappend`
                        SavedConfig -> HaddockFlags
savedHaddockFlags SavedConfig
config' forall a. Monoid a => a -> a -> a
`mappend`
                        HaddockFlags
haddockFlags { haddockDistPref :: Flag String
haddockDistPref = forall a. a -> Flag a
toFlag String
distPref }
        setupScriptOptions :: SetupScriptOptions
setupScriptOptions = SetupScriptOptions
defaultSetupScriptOptions
                             { useDistPref :: String
useDistPref = String
distPref }
    forall flags.
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [String])
-> IO ()
setupWrapper Verbosity
verbosity SetupScriptOptions
setupScriptOptions forall a. Maybe a
Nothing
      CommandUI HaddockFlags
haddockCommand (forall a b. a -> b -> a
const HaddockFlags
haddockFlags') (forall a b. a -> b -> a
const [String]
extraArgs)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HaddockFlags -> Flag HaddockTarget
haddockForHackage HaddockFlags
haddockFlags forall a. Eq a => a -> a -> Bool
== forall a. a -> Flag a
Flag HaddockTarget
ForHackage) forall a b. (a -> b) -> a -> b
$ do
      PackageDescription
pkg <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocalBuildInfo -> PackageDescription
LBI.localPkgDescr (String -> IO LocalBuildInfo
getPersistBuildConfig String
distPref)
      let dest :: String
dest = String
distPref String -> String -> String
</> String
name String -> String -> String
<.> String
"tar.gz"
          name :: String
name = forall a. Pretty a => a -> String
display (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg) forall a. [a] -> [a] -> [a]
++ String
"-docs"
          docDir :: String
docDir = String
distPref String -> String -> String
</> String
"doc" String -> String -> String
</> String
"html"
      String -> String -> String -> IO ()
createTarGzFile String
dest String
docDir String
name
      Verbosity -> String -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Documentation tarball created: " forall a. [a] -> [a] -> [a]
++ String
dest

cleanAction :: CleanFlags -> [String] -> Action
cleanAction :: CleanFlags -> [String] -> Action
cleanAction CleanFlags
cleanFlags [String]
extraArgs GlobalFlags
globalFlags = do
  Either SomeException SavedConfig
load <- forall e a. Exception e => IO a -> IO (Either e a)
try (Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags)
  let config :: SavedConfig
config = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(SomeException e
_) -> forall a. Monoid a => a
mempty) forall a. a -> a
id Either SomeException SavedConfig
load
  String
distPref <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config (CleanFlags -> Flag String
cleanDistPref CleanFlags
cleanFlags)
  let setupScriptOptions :: SetupScriptOptions
setupScriptOptions = SetupScriptOptions
defaultSetupScriptOptions
                           { useDistPref :: String
useDistPref = String
distPref
                           , useWin32CleanHack :: Bool
useWin32CleanHack = Bool
True
                           }
      cleanFlags' :: CleanFlags
cleanFlags' = CleanFlags
cleanFlags { cleanDistPref :: Flag String
cleanDistPref = forall a. a -> Flag a
toFlag String
distPref }
  forall flags.
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [String])
-> IO ()
setupWrapper Verbosity
verbosity SetupScriptOptions
setupScriptOptions forall a. Maybe a
Nothing
               CommandUI CleanFlags
cleanCommand (forall a b. a -> b -> a
const CleanFlags
cleanFlags') (forall a b. a -> b -> a
const [String]
extraArgs)
  where
    verbosity :: Verbosity
verbosity = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (CleanFlags -> Flag Verbosity
cleanVerbosity CleanFlags
cleanFlags)

listAction :: ListFlags -> [String] -> Action
listAction :: ListFlags -> [String] -> Action
listAction ListFlags
listFlags [String]
extraArgs GlobalFlags
globalFlags = do
  let verbosity :: Verbosity
verbosity = forall a. WithCallStack (Flag a -> a)
fromFlag (ListFlags -> Flag Verbosity
listVerbosity ListFlags
listFlags)
  SavedConfig
config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  let configFlags' :: ConfigFlags
configFlags' = SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config
      configFlags :: ConfigFlags
configFlags  = ConfigFlags
configFlags'
        { configPackageDBs :: [Maybe PackageDB]
configPackageDBs = ConfigFlags -> [Maybe PackageDB]
configPackageDBs ConfigFlags
configFlags'
                           forall a. Monoid a => a -> a -> a
`mappend` ListFlags -> [Maybe PackageDB]
listPackageDBs ListFlags
listFlags
        , configHcPath :: Flag String
configHcPath     = ListFlags -> Flag String
listHcPath ListFlags
listFlags
        }
      globalFlags' :: GlobalFlags
globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags    SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
  Maybe (Compiler, ProgramDb)
compProgdb <- if ListFlags -> Bool
listNeedsCompiler ListFlags
listFlags
      then do
          (Compiler
comp, Platform
_, ProgramDb
progdb) <- ConfigFlags -> IO (Compiler, Platform, ProgramDb)
configCompilerAux' ConfigFlags
configFlags
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Compiler
comp, ProgramDb
progdb))
      else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  forall a. Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext Verbosity
verbosity GlobalFlags
globalFlags' forall a b. (a -> b) -> a -> b
$ \RepoContext
repoContext ->
    Verbosity
-> PackageDBStack
-> RepoContext
-> Maybe (Compiler, ProgramDb)
-> ListFlags
-> [String]
-> IO ()
List.list Verbosity
verbosity
       (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 = forall a. WithCallStack (Flag a -> a)
fromFlag (InfoFlags -> Flag Verbosity
infoVerbosity InfoFlags
infoFlags)
  [UserTarget]
targets <- Verbosity -> [String] -> IO [UserTarget]
readUserTargets Verbosity
verbosity [String]
extraArgs
  SavedConfig
config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  let configFlags' :: ConfigFlags
configFlags' = SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config
      configFlags :: ConfigFlags
configFlags  = ConfigFlags
configFlags' {
        configPackageDBs :: [Maybe PackageDB]
configPackageDBs = ConfigFlags -> [Maybe PackageDB]
configPackageDBs ConfigFlags
configFlags'
                           forall a. Monoid a => a -> a -> a
`mappend` InfoFlags -> [Maybe PackageDB]
infoPackageDBs InfoFlags
infoFlags
        }
      globalFlags' :: GlobalFlags
globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags    SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
  (Compiler
comp, Platform
_, ProgramDb
progdb) <- ConfigFlags -> IO (Compiler, Platform, ProgramDb)
configCompilerAuxEx ConfigFlags
configFlags
  forall a. Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext Verbosity
verbosity GlobalFlags
globalFlags' forall a b. (a -> b) -> a -> b
$ \RepoContext
repoContext ->
    Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> ProgramDb
-> GlobalFlags
-> InfoFlags
-> [UserTarget]
-> IO ()
List.info Verbosity
verbosity
       (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 = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag Verbosity
fetchVerbosity FetchFlags
fetchFlags)
  [UserTarget]
targets <- Verbosity -> [String] -> IO [UserTarget]
readUserTargets Verbosity
verbosity [String]
extraArgs
  SavedConfig
config <- Verbosity -> Flag String -> IO SavedConfig
loadConfig Verbosity
verbosity (GlobalFlags -> Flag String
globalConfigFile GlobalFlags
globalFlags)
  let configFlags :: ConfigFlags
configFlags  = SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config
      globalFlags' :: GlobalFlags
globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
  (Compiler
comp, Platform
platform, ProgramDb
progdb) <- ConfigFlags -> IO (Compiler, Platform, ProgramDb)
configCompilerAux' ConfigFlags
configFlags
  forall a. Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext Verbosity
verbosity GlobalFlags
globalFlags' forall a b. (a -> b) -> a -> b
$ \RepoContext
repoContext ->
    Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FetchFlags
-> [UserTarget]
-> IO ()
fetch Verbosity
verbosity
        (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 = forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag Verbosity
freezeVerbosity FreezeFlags
freezeFlags)
  SavedConfig
config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  String
distPref <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config forall a. Flag a
NoFlag
  Verbosity -> String -> GlobalFlags -> SavedConfig -> IO () -> IO ()
nixShell Verbosity
verbosity String
distPref GlobalFlags
globalFlags SavedConfig
config forall a b. (a -> b) -> a -> b
$ do
    let configFlags :: ConfigFlags
configFlags  = SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config
        globalFlags' :: GlobalFlags
globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
    (Compiler
comp, Platform
platform, ProgramDb
progdb) <- ConfigFlags -> IO (Compiler, Platform, ProgramDb)
configCompilerAux' ConfigFlags
configFlags

    forall a. Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext Verbosity
verbosity GlobalFlags
globalFlags' forall a b. (a -> b) -> a -> b
$ \RepoContext
repoContext ->
        Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FreezeFlags
-> IO ()
freeze Verbosity
verbosity
            (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 = forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag Verbosity
freezeVerbosity FreezeFlags
freezeFlags)
  SavedConfig
config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  String
distPref <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config forall a. Flag a
NoFlag
  Verbosity -> String -> GlobalFlags -> SavedConfig -> IO () -> IO ()
nixShell Verbosity
verbosity String
distPref GlobalFlags
globalFlags SavedConfig
config forall a b. (a -> b) -> a -> b
$ do
    let configFlags :: ConfigFlags
configFlags  = SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config
        globalFlags' :: GlobalFlags
globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
    (Compiler
comp, Platform
platform, ProgramDb
progdb) <- ConfigFlags -> IO (Compiler, Platform, ProgramDb)
configCompilerAux' ConfigFlags
configFlags

    forall a. Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext Verbosity
verbosity GlobalFlags
globalFlags' forall a b. (a -> b) -> a -> b
$ \RepoContext
repoContext ->
        Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FreezeFlags
-> IO ()
genBounds Verbosity
verbosity
                (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
  SavedConfig
config <- Verbosity -> Flag String -> IO SavedConfig
loadConfig Verbosity
verbosity (GlobalFlags -> Flag String
globalConfigFile GlobalFlags
globalFlags)
  let uploadFlags' :: UploadFlags
uploadFlags' = SavedConfig -> UploadFlags
savedUploadFlags SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend` UploadFlags
uploadFlags
      globalFlags' :: GlobalFlags
globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
      tarfiles :: [String]
tarfiles     = [String]
extraArgs
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
tarfiles Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. WithCallStack (Flag a -> a)
fromFlag (UploadFlags -> Flag Bool
uploadDoc UploadFlags
uploadFlags'))) forall a b. (a -> b) -> a -> b
$
    forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"the 'upload' command expects at least one .tar.gz archive."
  [String] -> IO ()
checkTarFiles [String]
extraArgs
  Maybe Password
maybe_password <-
    case UploadFlags -> Flag [String]
uploadPasswordCmd UploadFlags
uploadFlags'
    of Flag (String
xs:[String]
xss) -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Password
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]
_             -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> Maybe a
flagToMaybe forall a b. (a -> b) -> a -> b
$ UploadFlags -> Flag Password
uploadPassword UploadFlags
uploadFlags'
  forall a. Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext Verbosity
verbosity GlobalFlags
globalFlags' forall a b. (a -> b) -> a -> b
$ \RepoContext
repoContext -> do
    if forall a. WithCallStack (Flag a -> a)
fromFlag (UploadFlags -> Flag Bool
uploadDoc UploadFlags
uploadFlags')
    then do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
tarfiles forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$
       forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"the 'upload' command can only upload documentation "
             forall a. [a] -> [a] -> [a]
++ String
"for one package at a time."
      String
tarfile <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SavedConfig -> IO String
generateDocTarball SavedConfig
config) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe [String]
tarfiles
      Verbosity
-> RepoContext
-> Maybe Username
-> Maybe Password
-> IsCandidate
-> String
-> IO ()
Upload.uploadDoc Verbosity
verbosity
                       RepoContext
repoContext
                       (forall a. Flag a -> Maybe a
flagToMaybe forall a b. (a -> b) -> a -> b
$ UploadFlags -> Flag Username
uploadUsername UploadFlags
uploadFlags')
                       Maybe Password
maybe_password
                       (forall a. WithCallStack (Flag a -> a)
fromFlag (UploadFlags -> Flag IsCandidate
uploadCandidate UploadFlags
uploadFlags'))
                       String
tarfile
    else do
      Verbosity
-> RepoContext
-> Maybe Username
-> Maybe Password
-> IsCandidate
-> [String]
-> IO ()
Upload.upload Verbosity
verbosity
                    RepoContext
repoContext
                    (forall a. Flag a -> Maybe a
flagToMaybe forall a b. (a -> b) -> a -> b
$ UploadFlags -> Flag Username
uploadUsername UploadFlags
uploadFlags')
                    Maybe Password
maybe_password
                    (forall a. WithCallStack (Flag a -> a)
fromFlag (UploadFlags -> Flag IsCandidate
uploadCandidate UploadFlags
uploadFlags'))
                    [String]
tarfiles
    where
    verbosity :: Verbosity
verbosity = forall a. WithCallStack (Flag a -> a)
fromFlag (UploadFlags -> Flag Verbosity
uploadVerbosity UploadFlags
uploadFlags)
    checkTarFiles :: [String] -> IO ()
checkTarFiles [String]
tarfiles
      | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
otherFiles)
      = forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"the 'upload' command expects only .tar.gz archives: "
           forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
otherFiles
      | Bool
otherwise = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
                      [ do Bool
exists <- String -> IO Bool
doesFileExist String
tarfile
                           forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"file not found: " forall a. [a] -> [a] -> [a]
++ String
tarfile
                      | String
tarfile <- [String]
tarfiles ]

      where otherFiles :: [String]
otherFiles = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not 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' 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 forall a b. (a -> b) -> a -> b
$
        String
"No documentation tarball specified. "
        forall a. [a] -> [a] -> [a]
++ String
"Building a documentation tarball with default settings...\n"
        forall a. [a] -> [a] -> [a]
++ String
"If you need to customise Haddock options, "
        forall a. [a] -> [a] -> [a]
++ String
"run 'haddock --for-hackage' first "
        forall a. [a] -> [a] -> [a]
++ String
"to generate a documentation tarball."
      HaddockFlags -> [String] -> Action
haddockAction (HaddockFlags
defaultHaddockFlags { haddockForHackage :: Flag HaddockTarget
haddockForHackage = forall a. a -> Flag a
Flag HaddockTarget
ForHackage })
                    [] GlobalFlags
globalFlags
      String
distPref <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config forall a. Flag a
NoFlag
      PackageDescription
pkg <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocalBuildInfo -> PackageDescription
LBI.localPkgDescr (String -> IO LocalBuildInfo
getPersistBuildConfig String
distPref)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
distPref String -> String -> String
</> forall a. Pretty a => a -> String
display (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg) forall a. [a] -> [a] -> [a]
++ String
"-docs" String -> String -> String
<.> String
"tar.gz"

checkAction :: Flag Verbosity -> [String] -> Action
checkAction :: Flag Verbosity -> [String] -> Action
checkAction Flag Verbosity
verbosityFlag [String]
extraArgs GlobalFlags
_globalFlags = do
  let verbosity :: Verbosity
verbosity = forall a. WithCallStack (Flag a -> a)
fromFlag Flag Verbosity
verbosityFlag
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
extraArgs) forall a b. (a -> b) -> a -> b
$
    forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"'check' doesn't take any extra arguments: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
extraArgs
  Bool
allOk <- Verbosity -> IO Bool
Check.check (forall a. WithCallStack (Flag a -> a)
fromFlag Flag Verbosity
verbosityFlag)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allOk forall a. IO a
exitFailure

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

reportAction :: ReportFlags -> [String] -> Action
reportAction :: ReportFlags -> [String] -> Action
reportAction ReportFlags
reportFlags [String]
extraArgs GlobalFlags
globalFlags = do
  let verbosity :: Verbosity
verbosity = forall a. WithCallStack (Flag a -> a)
fromFlag (ReportFlags -> Flag Verbosity
reportVerbosity ReportFlags
reportFlags)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
extraArgs) forall a b. (a -> b) -> a -> b
$
    forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"'report' doesn't take any extra arguments: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
extraArgs
  SavedConfig
config <- Verbosity -> Flag String -> IO SavedConfig
loadConfig Verbosity
verbosity (GlobalFlags -> Flag String
globalConfigFile GlobalFlags
globalFlags)
  let globalFlags' :: GlobalFlags
globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
      reportFlags' :: ReportFlags
reportFlags' = SavedConfig -> ReportFlags
savedReportFlags SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend` ReportFlags
reportFlags

  forall a. Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext Verbosity
verbosity GlobalFlags
globalFlags' forall a b. (a -> b) -> a -> b
$ \RepoContext
repoContext ->
   Verbosity
-> RepoContext -> Maybe Username -> Maybe Password -> IO ()
Upload.report Verbosity
verbosity RepoContext
repoContext
    (forall a. Flag a -> Maybe a
flagToMaybe forall a b. (a -> b) -> a -> b
$ ReportFlags -> Flag Username
reportUsername ReportFlags
reportFlags')
    (forall a. Flag a -> Maybe a
flagToMaybe forall a b. (a -> b) -> a -> b
$ ReportFlags -> Flag Password
reportPassword ReportFlags
reportFlags')

runAction :: BuildFlags -> [String] -> Action
runAction :: BuildFlags -> [String] -> Action
runAction BuildFlags
buildFlags [String]
extraArgs GlobalFlags
globalFlags = do
  let verbosity :: Verbosity
verbosity   = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (BuildFlags -> Flag Verbosity
buildVerbosity BuildFlags
buildFlags)
  SavedConfig
config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  String
distPref <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config (BuildFlags -> Flag String
buildDistPref BuildFlags
buildFlags)
  SavedConfig
config' <-
    ((ConfigFlags, ConfigExFlags) -> [String] -> Action)
-> Verbosity
-> String
-> Flag (Maybe Int)
-> Check (ConfigFlags, ConfigExFlags)
-> [String]
-> GlobalFlags
-> SavedConfig
-> IO SavedConfig
reconfigure (ConfigFlags, ConfigExFlags) -> [String] -> Action
configureAction
    Verbosity
verbosity String
distPref (BuildFlags -> Flag (Maybe Int)
buildNumJobs BuildFlags
buildFlags)
    forall a. Monoid a => a
mempty [] GlobalFlags
globalFlags SavedConfig
config
  Verbosity -> String -> GlobalFlags -> SavedConfig -> IO () -> IO ()
nixShell Verbosity
verbosity String
distPref GlobalFlags
globalFlags SavedConfig
config forall a b. (a -> b) -> a -> b
$ do
    LocalBuildInfo
lbi <- String -> IO LocalBuildInfo
getPersistBuildConfig String
distPref
    (Executable
exe, [String]
exeArgs) <- Verbosity
-> LocalBuildInfo -> [String] -> IO (Executable, [String])
splitRunArgs Verbosity
verbosity LocalBuildInfo
lbi [String]
extraArgs

    Verbosity
-> SavedConfig -> String -> BuildFlags -> [String] -> IO ()
build Verbosity
verbosity SavedConfig
config' String
distPref BuildFlags
buildFlags [String
"exe:" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
display (Executable -> UnqualComponentName
exeName Executable
exe)]
    Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO ()
run Verbosity
verbosity LocalBuildInfo
lbi Executable
exe [String]
exeArgs

getAction :: GetFlags -> [String] -> Action
getAction :: GetFlags -> [String] -> Action
getAction GetFlags
getFlags [String]
extraArgs GlobalFlags
globalFlags = do
  let verbosity :: Verbosity
verbosity = forall a. WithCallStack (Flag a -> a)
fromFlag (GetFlags -> Flag Verbosity
getVerbosity GetFlags
getFlags)
  [UserTarget]
targets <- Verbosity -> [String] -> IO [UserTarget]
readUserTargets Verbosity
verbosity [String]
extraArgs
  SavedConfig
config <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
  let globalFlags' :: GlobalFlags
globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags
  forall a. Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext Verbosity
verbosity (SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config) forall a b. (a -> b) -> a -> b
$ \RepoContext
repoContext ->
   Verbosity
-> RepoContext -> GlobalFlags -> GetFlags -> [UserTarget] -> IO ()
get Verbosity
verbosity
    RepoContext
repoContext
    GlobalFlags
globalFlags'
    GetFlags
getFlags
    [UserTarget]
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
      forall a. String -> IO a -> IO a
withCurrentDirectory String
projectDir IO ()
initAction'
    [String]
_ -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
      String
"'init' only takes a single, optional, extra " forall a. [a] -> [a] -> [a]
++
      String
"argument for the project root directory"
  where
    initAction' :: IO ()
initAction' = do
      SavedConfig
confFlags <- Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity GlobalFlags
globalFlags
      -- override with `--with-compiler` from CLI if available
      let confFlags' :: ConfigFlags
confFlags' = SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
confFlags forall a. Monoid a => a -> a -> a
`mappend` ConfigFlags
compFlags
          initFlags' :: InitFlags
initFlags' = SavedConfig -> InitFlags
savedInitFlags SavedConfig
confFlags forall a. Monoid a => a -> a -> a
`mappend` InitFlags
initFlags
          globalFlags' :: GlobalFlags
globalFlags' = SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
confFlags forall a. Monoid a => a -> a -> a
`mappend` GlobalFlags
globalFlags

      (Compiler
comp, Platform
_, ProgramDb
progdb) <- ConfigFlags -> IO (Compiler, Platform, ProgramDb)
configCompilerAux' ConfigFlags
confFlags'

      forall a. Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext Verbosity
verbosity GlobalFlags
globalFlags' forall a b. (a -> b) -> a -> b
$ \RepoContext
repoContext ->
        Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> ProgramDb
-> InitFlags
-> IO ()
initCmd Verbosity
verbosity (ConfigFlags -> PackageDBStack
configPackageDB' ConfigFlags
confFlags')
          RepoContext
repoContext Compiler
comp ProgramDb
progdb InitFlags
initFlags'

    verbosity :: Verbosity
verbosity = forall a. WithCallStack (Flag a -> a)
fromFlag (InitFlags -> Flag Verbosity
initVerbosity InitFlags
initFlags)
    compFlags :: ConfigFlags
compFlags = forall a. Monoid a => a
mempty { configHcPath :: Flag String
configHcPath = InitFlags -> Flag String
initHcPath InitFlags
initFlags }

userConfigAction :: UserConfigFlags -> [String] -> Action
userConfigAction :: UserConfigFlags -> [String] -> Action
userConfigAction UserConfigFlags
ucflags [String]
extraArgs GlobalFlags
globalFlags = do
  let verbosity :: Verbosity
verbosity  = forall a. WithCallStack (Flag a -> a)
fromFlag (UserConfigFlags -> Flag Verbosity
userConfigVerbosity UserConfigFlags
ucflags)
      frc :: Bool
frc        = forall a. WithCallStack (Flag a -> a)
fromFlag (UserConfigFlags -> Flag Bool
userConfigForce UserConfigFlags
ucflags)
      extraLines :: [String]
extraLines = forall a. WithCallStack (Flag a -> a)
fromFlag (UserConfigFlags -> Flag [String]
userConfigAppendLines UserConfigFlags
ucflags)
  case [String]
extraArgs of
    (String
"init":[String]
_) -> do
      String
path       <- IO String
configFile
      Bool
fileExists <- String -> IO Bool
doesFileExist String
path
      if (Bool -> Bool
not Bool
fileExists Bool -> Bool -> Bool
|| (Bool
fileExists Bool -> Bool -> Bool
&& Bool
frc))
      then forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Verbosity -> [String] -> String -> IO SavedConfig
createDefaultConfigFile Verbosity
verbosity [String]
extraLines String
path
      else forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
path forall a. [a] -> [a] -> [a]
++ String
" already exists."
    (String
"diff":[String]
_) -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ String -> IO ()
putStrLn 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.
    [] -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Please specify a subcommand (see 'help user-config')"
    [String]
_  -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Unknown 'user-config' subcommand: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
extraArgs
  where configFile :: IO String
configFile = Flag String -> IO String
getConfigFilePath (GlobalFlags -> Flag String
globalConfigFile GlobalFlags
globalFlags)

-- | Used as an entry point when cabal-install needs to invoke itself
-- as a setup script. This can happen e.g. when doing parallel builds.
--
actAsSetupAction :: ActAsSetupFlags -> [String] -> Action
actAsSetupAction :: ActAsSetupFlags -> [String] -> Action
actAsSetupAction ActAsSetupFlags
actAsSetupFlags [String]
args GlobalFlags
_globalFlags =
  let bt :: BuildType
bt = 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 -> UserHooks -> [String] -> IO ()
Simple.defaultMainWithHooksArgs
                  UserHooks
Simple.autoconfUserHooks [String]
args
    BuildType
Make      -> [String] -> IO ()
Make.defaultMainArgs [String]
args
    BuildType
Custom    -> 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 = forall a. WithCallStack (Flag a -> a)
fromFlag (ManpageFlags -> Flag Verbosity
manpageVerbosity ManpageFlags
flags)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
extraArgs) forall a b. (a -> b) -> a -> b
$
    forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"'man' doesn't take any extra arguments: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
extraArgs
  String
pname <- IO String
getProgName
  let cabalCmd :: String
cabalCmd = if String -> String
takeExtension String
pname forall a. Eq a => a -> a -> Bool
== String
".exe"
                 then String -> String
dropExtension String
pname
                 else String
pname
  forall a. String -> [CommandSpec a] -> ManpageFlags -> IO ()
manpageCmd String
cabalCmd [CommandSpec action]
commands ManpageFlags
flags