{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Client.Install
-- Copyright   :  (c) 2005 David Himmelstrup
--                    2007 Bjorn Bringert
--                    2007-2010 Duncan Coutts
-- License     :  BSD-like
--
-- Maintainer  :  cabal-devel@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- High level interface to package installation.
module Distribution.Client.Install
  ( -- * High-level interface
    install

    -- * Lower-level interface that allows to manipulate the install plan
  , makeInstallContext
  , makeInstallPlan
  , processInstallPlan
  , InstallArgs
  , InstallContext

    -- * Prune certain packages from the install plan
  , pruneInstallPlan
  ) where

import Distribution.Client.Compat.Prelude
import Distribution.Utils.Generic (safeLast)
import Prelude ()

import Control.Exception as Exception
  ( Handler (Handler)
  , bracket
  , catches
  , handleJust
  )
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import System.Directory
  ( createDirectoryIfMissing
  , doesDirectoryExist
  , doesFileExist
  , getDirectoryContents
  , getTemporaryDirectory
  , removeFile
  , renameDirectory
  )
import System.FilePath
  ( equalFilePath
  , takeDirectory
  , (<.>)
  )
import System.IO
  ( IOMode (AppendMode)
  , hClose
  , openFile
  )
import System.IO.Error
  ( ioeGetFileName
  , isDoesNotExistError
  )

import Distribution.Client.BuildReports.Anonymous (showBuildReport)
import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
import qualified Distribution.Client.BuildReports.Storage as BuildReports
  ( fromInstallPlan
  , fromPlanningFailure
  , storeAnonymous
  , storeLocal
  )
import Distribution.Client.BuildReports.Types
  ( ReportLevel (..)
  )
import Distribution.Client.Config
  ( defaultReportsDir
  , defaultUserInstall
  )
import Distribution.Client.Configure
  ( checkConfigExFlags
  , chooseCabalVersion
  , configureSetupScript
  )
import Distribution.Client.Dependency
import Distribution.Client.FetchUtils
import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)
import Distribution.Client.HttpUtils
  ( HttpTransport (..)
  )
import Distribution.Client.IndexUtils as IndexUtils
  ( getInstalledPackages
  , getSourcePackagesAtIndexState
  )
import Distribution.Client.InstallPlan (InstallPlan)
import qualified Distribution.Client.InstallPlan as InstallPlan
import qualified Distribution.Client.InstallSymlink as InstallSymlink
  ( symlinkBinaries
  )
import Distribution.Client.JobControl
import Distribution.Client.Setup
  ( ConfigExFlags (..)
  , ConfigFlags (..)
  , GlobalFlags (..)
  , InstallFlags (..)
  , RepoContext (..)
  , configureCommand
  , filterCommonFlags
  , filterConfigureFlags
  , filterTestFlags
  )
import Distribution.Client.SetupWrapper
  ( SetupScriptOptions (..)
  , defaultSetupScriptOptions
  , setupWrapper
  )
import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.Client.Tar (extractTarGzFile)
import Distribution.Client.Targets
import Distribution.Client.Types as Source
import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..))
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.Solver.Types.PackageFixedDeps

import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
import qualified Distribution.Solver.Types.PackageIndex as SourcePackageIndex
import Distribution.Solver.Types.PkgConfigDb
  ( PkgConfigDb
  , readPkgConfigDb
  )
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SourcePackage as SourcePackage

import Distribution.Client.Utils
  ( MergeResult (..)
  , ProgressPhase (..)
  , determineNumJobs
  , logDirChange
  , mergeBy
  , progressMessage
  )
import Distribution.Package
  ( HasMungedPackageId (..)
  , HasUnitId (..)
  , Package (..)
  , PackageId
  , PackageIdentifier (..)
  , UnitId
  , packageName
  , packageVersion
  )
import Distribution.PackageDescription
  ( GenericPackageDescription (..)
  , PackageDescription
  )
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription.Configuration
  ( finalizePD
  )
import Distribution.Simple.BuildPaths (exeExtension)
import Distribution.Simple.Compiler
  ( Compiler (compilerId)
  , CompilerId (..)
  , CompilerInfo (..)
  , PackageDBCWD
  , PackageDBStackCWD
  , PackageDBX (..)
  , compilerFlavor
  , compilerInfo
  )
import Distribution.Simple.Configure (interpretPackageDbFlags)
import Distribution.Simple.Errors
import Distribution.Simple.InstallDirs as InstallDirs
  ( PathTemplate
  , fromPathTemplate
  , initialPathTemplateEnv
  , installDirsTemplateEnv
  , substPathTemplate
  , toPathTemplate
  )
import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.Program (ProgramDb)
import Distribution.Simple.Register (defaultRegisterOptions, registerPackage)
import Distribution.Simple.Setup
  ( BenchmarkFlags (..)
  , BuildFlags (..)
  , CommonSetupFlags (..)
  , CopyFlags (..)
  , HaddockFlags (..)
  , RegisterFlags (..)
  , TestFlags (..)
  , buildCommand
  , copyCommonFlags
  , defaultCommonSetupFlags
  , defaultDistPref
  , emptyBuildFlags
  , flagToMaybe
  , fromFlag
  , fromFlagOrDefault
  , haddockCommand
  , maybeToFlag
  , registerCommonFlags
  , setupDistPref
  , setupVerbosity
  , setupWorkingDir
  , testCommonFlags
  , toFlag
  )
import qualified Distribution.Simple.Setup as Cabal
import Distribution.Utils.Path hiding
  ( (<.>)
  )

import Distribution.Simple.Utils
  ( VerboseException
  , createDirectoryIfMissingVerbose
  , writeFileAtomic
  )
import Distribution.Simple.Utils as Utils
  ( debug
  , debugNoWrap
  , dieWithException
  , info
  , notice
  , warn
  , withTempDirectory
  )
import Distribution.System
  ( OS (Windows)
  , Platform
  , buildOS
  , buildPlatform
  )
import Distribution.Types.Flag
  ( FlagAssignment
  , PackageFlag (..)
  , diffFlagAssignment
  , mkFlagAssignment
  , nullFlagAssignment
  , showFlagAssignment
  )
import Distribution.Types.GivenComponent
  ( GivenComponent (..)
  )
import Distribution.Types.MungedPackageId
import Distribution.Types.PackageVersionConstraint
  ( PackageVersionConstraint (..)
  , thisPackageVersionConstraint
  )
import Distribution.Utils.NubList
import Distribution.Verbosity as Verbosity
  ( modifyVerbosity
  , normal
  , verbose
  )
import Distribution.Version
  ( Version
  , VersionRange
  , foldVersionRange
  )

import qualified Data.ByteString as BS
import Distribution.Client.Errors

-- TODO:

-- * assign flags to packages individually

--   * complain about flags that do not apply to any package given as target
--     so flags do not apply to dependencies, only listed, can use flag
--     constraints for dependencies

-- * allow flag constraints

-- * allow installed constraints

-- * allow flag and installed preferences

--   * allow persistent configure flags for each package individually

-- ------------------------------------------------------------

-- * Top level user actions

-- ------------------------------------------------------------

-- | Installs the packages needed to satisfy a list of dependencies.
install
  :: Verbosity
  -> PackageDBStackCWD
  -> RepoContext
  -> Compiler
  -> Platform
  -> ProgramDb
  -> GlobalFlags
  -> ConfigFlags
  -> ConfigExFlags
  -> InstallFlags
  -> HaddockFlags
  -> TestFlags
  -> BenchmarkFlags
  -> [UserTarget]
  -> IO ()
install :: Verbosity
-> PackageDBStackCWD
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> HaddockFlags
-> TestFlags
-> BenchmarkFlags
-> [UserTarget]
-> IO ()
install
  Verbosity
verbosity
  PackageDBStackCWD
packageDBs
  RepoContext
repos
  Compiler
comp
  Platform
platform
  ProgramDb
progdb
  GlobalFlags
globalFlags
  ConfigFlags
configFlags
  ConfigExFlags
configExFlags
  InstallFlags
installFlags
  HaddockFlags
haddockFlags
  TestFlags
testFlags
  BenchmarkFlags
benchmarkFlags
  [UserTarget]
userTargets0 = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (InstallFlags -> Flag FilePath
installRootCmd InstallFlags
installFlags Flag FilePath -> Flag FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== Flag FilePath
forall a. Flag a
Cabal.NoFlag) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath
"--root-cmd is no longer supported, "
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"see https://github.com/haskell/cabal/issues/3353"
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" (if you didn't type --root-cmd, comment out root-cmd"
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" in your ~/.config/cabal/config file)"
    let userOrSandbox :: Bool
userOrSandbox = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
userOrSandbox (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath
"the --global flag is deprecated -- "
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"it is generally considered a bad idea to install packages "
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"into the global store"

    InstallContext
installContext <- Verbosity -> InstallArgs -> Maybe [UserTarget] -> IO InstallContext
makeInstallContext Verbosity
verbosity InstallArgs
args ([UserTarget] -> Maybe [UserTarget]
forall a. a -> Maybe a
Just [UserTarget]
userTargets0)
    Either FilePath SolverInstallPlan
planResult <-
      (FilePath
 -> IO (Either FilePath SolverInstallPlan)
 -> IO (Either FilePath SolverInstallPlan))
-> (FilePath -> IO (Either FilePath SolverInstallPlan))
-> (SolverInstallPlan -> IO (Either FilePath SolverInstallPlan))
-> Progress FilePath FilePath SolverInstallPlan
-> IO (Either FilePath SolverInstallPlan)
forall step a fail done.
(step -> a -> a)
-> (fail -> a) -> (done -> a) -> Progress step fail done -> a
foldProgress FilePath
-> IO (Either FilePath SolverInstallPlan)
-> IO (Either FilePath SolverInstallPlan)
forall {b}. FilePath -> IO b -> IO b
logMsg (Either FilePath SolverInstallPlan
-> IO (Either FilePath SolverInstallPlan)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath SolverInstallPlan
 -> IO (Either FilePath SolverInstallPlan))
-> (FilePath -> Either FilePath SolverInstallPlan)
-> FilePath
-> IO (Either FilePath SolverInstallPlan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Either FilePath SolverInstallPlan
forall a b. a -> Either a b
Left) (Either FilePath SolverInstallPlan
-> IO (Either FilePath SolverInstallPlan)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath SolverInstallPlan
 -> IO (Either FilePath SolverInstallPlan))
-> (SolverInstallPlan -> Either FilePath SolverInstallPlan)
-> SolverInstallPlan
-> IO (Either FilePath SolverInstallPlan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SolverInstallPlan -> Either FilePath SolverInstallPlan
forall a b. b -> Either a b
Right)
        (Progress FilePath FilePath SolverInstallPlan
 -> IO (Either FilePath SolverInstallPlan))
-> IO (Progress FilePath FilePath SolverInstallPlan)
-> IO (Either FilePath SolverInstallPlan)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity
-> InstallArgs
-> InstallContext
-> IO (Progress FilePath FilePath SolverInstallPlan)
makeInstallPlan Verbosity
verbosity InstallArgs
args InstallContext
installContext

    case Either FilePath SolverInstallPlan
planResult of
      Left FilePath
message -> do
        Verbosity -> InstallArgs -> InstallContext -> FilePath -> IO ()
reportPlanningFailure Verbosity
verbosity InstallArgs
args InstallContext
installContext FilePath
message
        CabalInstallException -> IO ()
forall {a}. CabalInstallException -> IO a
die'' (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalInstallException
ReportPlanningFailure FilePath
message
      Right SolverInstallPlan
installPlan ->
        Verbosity
-> InstallArgs -> InstallContext -> SolverInstallPlan -> IO ()
processInstallPlan Verbosity
verbosity InstallArgs
args InstallContext
installContext SolverInstallPlan
installPlan
    where
      args :: InstallArgs
      args :: InstallArgs
args =
        ( PackageDBStackCWD
packageDBs
        , RepoContext
repos
        , Compiler
comp
        , Platform
platform
        , ProgramDb
progdb
        , GlobalFlags
globalFlags
        , ConfigFlags
configFlags
        , ConfigExFlags
configExFlags
        , InstallFlags
installFlags
        , HaddockFlags
haddockFlags
        , TestFlags
testFlags
        , BenchmarkFlags
benchmarkFlags
        )

      die'' :: CabalInstallException -> IO a
die'' = Verbosity -> CabalInstallException -> IO a
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity

      logMsg :: FilePath -> IO b -> IO b
logMsg FilePath
message IO b
rest = Verbosity -> FilePath -> IO ()
debugNoWrap Verbosity
verbosity FilePath
message IO () -> IO b -> IO b
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
rest

-- TODO: Make InstallContext a proper data type with documented fields.

-- | Common context for makeInstallPlan and processInstallPlan.
type InstallContext =
  ( InstalledPackageIndex
  , SourcePackageDb
  , Maybe PkgConfigDb
  , [UserTarget]
  , [PackageSpecifier UnresolvedSourcePackage]
  , HttpTransport
  )

-- TODO: Make InstallArgs a proper data type with documented fields or just get
-- rid of it completely.

-- | Initial arguments given to 'install' or 'makeInstallContext'.
type InstallArgs =
  ( PackageDBStackCWD
  , RepoContext
  , Compiler
  , Platform
  , ProgramDb
  , GlobalFlags
  , ConfigFlags
  , ConfigExFlags
  , InstallFlags
  , HaddockFlags
  , TestFlags
  , BenchmarkFlags
  )

-- | Make an install context given install arguments.
makeInstallContext
  :: Verbosity
  -> InstallArgs
  -> Maybe [UserTarget]
  -> IO InstallContext
makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget] -> IO InstallContext
makeInstallContext
  Verbosity
verbosity
  ( PackageDBStackCWD
packageDBs
    , RepoContext
repoCtxt
    , Compiler
comp
    , Platform
_
    , ProgramDb
progdb
    , GlobalFlags
_
    , ConfigFlags
_
    , ConfigExFlags
configExFlags
    , InstallFlags
installFlags
    , HaddockFlags
_
    , TestFlags
_
    , BenchmarkFlags
_
    )
  Maybe [UserTarget]
mUserTargets = do
    let idxState :: Maybe TotalIndexState
idxState = Flag TotalIndexState -> Maybe TotalIndexState
forall a. Flag a -> Maybe a
flagToMaybe (InstallFlags -> Flag TotalIndexState
installIndexState InstallFlags
installFlags)

    InstalledPackageIndex
installedPkgIndex <- Verbosity
-> Compiler
-> PackageDBStackCWD
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
comp PackageDBStackCWD
packageDBs ProgramDb
progdb
    (SourcePackageDb
sourcePkgDb, TotalIndexState
_, ActiveRepos
_) <- Verbosity
-> RepoContext
-> Maybe TotalIndexState
-> Maybe ActiveRepos
-> IO (SourcePackageDb, TotalIndexState, ActiveRepos)
getSourcePackagesAtIndexState Verbosity
verbosity RepoContext
repoCtxt Maybe TotalIndexState
idxState Maybe ActiveRepos
forall a. Maybe a
Nothing
    Maybe PkgConfigDb
pkgConfigDb <- Verbosity -> ProgramDb -> IO (Maybe PkgConfigDb)
readPkgConfigDb Verbosity
verbosity ProgramDb
progdb

    Verbosity
-> InstalledPackageIndex
-> PackageIndex (SourcePackage UnresolvedPkgLoc)
-> ConfigExFlags
-> IO ()
forall pkg.
Package pkg =>
Verbosity
-> InstalledPackageIndex
-> PackageIndex pkg
-> ConfigExFlags
-> IO ()
checkConfigExFlags
      Verbosity
verbosity
      InstalledPackageIndex
installedPkgIndex
      (SourcePackageDb -> PackageIndex (SourcePackage UnresolvedPkgLoc)
packageIndex SourcePackageDb
sourcePkgDb)
      ConfigExFlags
configExFlags
    HttpTransport
transport <- RepoContext -> IO HttpTransport
repoContextGetTransport RepoContext
repoCtxt

    ([UserTarget]
userTargets, [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers) <- case Maybe [UserTarget]
mUserTargets of
      Maybe [UserTarget]
Nothing ->
        -- We want to distinguish between the case where the user has given an
        -- empty list of targets on the command-line and the case where we
        -- specifically want to have an empty list of targets.
        ([UserTarget], [PackageSpecifier (SourcePackage UnresolvedPkgLoc)])
-> IO
     ([UserTarget], [PackageSpecifier (SourcePackage UnresolvedPkgLoc)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
      Just [UserTarget]
userTargets0 -> do
        -- For install, if no target is given it means we use the current
        -- directory as the single target.
        let userTargets :: [UserTarget]
userTargets
              | [UserTarget] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UserTarget]
userTargets0 = [FilePath -> UserTarget
UserTargetLocalDir FilePath
"."]
              | Bool
otherwise = [UserTarget]
userTargets0

        [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers <-
          Verbosity
-> RepoContext
-> PackageIndex (SourcePackage UnresolvedPkgLoc)
-> [UserTarget]
-> IO [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
forall pkg.
Package pkg =>
Verbosity
-> RepoContext
-> PackageIndex pkg
-> [UserTarget]
-> IO [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
resolveUserTargets
            Verbosity
verbosity
            RepoContext
repoCtxt
            (SourcePackageDb -> PackageIndex (SourcePackage UnresolvedPkgLoc)
packageIndex SourcePackageDb
sourcePkgDb)
            [UserTarget]
userTargets
        ([UserTarget], [PackageSpecifier (SourcePackage UnresolvedPkgLoc)])
-> IO
     ([UserTarget], [PackageSpecifier (SourcePackage UnresolvedPkgLoc)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([UserTarget]
userTargets, [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers)

    InstallContext -> IO InstallContext
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
      ( InstalledPackageIndex
installedPkgIndex
      , SourcePackageDb
sourcePkgDb
      , Maybe PkgConfigDb
pkgConfigDb
      , [UserTarget]
userTargets
      , [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers
      , HttpTransport
transport
      )

-- | Make an install plan given install context and install arguments.
makeInstallPlan
  :: Verbosity
  -> InstallArgs
  -> InstallContext
  -> IO (Progress String String SolverInstallPlan)
makeInstallPlan :: Verbosity
-> InstallArgs
-> InstallContext
-> IO (Progress FilePath FilePath SolverInstallPlan)
makeInstallPlan
  Verbosity
verbosity
  ( PackageDBStackCWD
_
    , RepoContext
_
    , Compiler
comp
    , Platform
platform
    , ProgramDb
_
    , GlobalFlags
_
    , ConfigFlags
configFlags
    , ConfigExFlags
configExFlags
    , InstallFlags
installFlags
    , HaddockFlags
_
    , TestFlags
_
    , BenchmarkFlags
_
    )
  ( InstalledPackageIndex
installedPkgIndex
    , SourcePackageDb
sourcePkgDb
    , Maybe PkgConfigDb
pkgConfigDb
    , [UserTarget]
_
    , [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers
    , HttpTransport
_
    ) = do
    Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity FilePath
"Resolving dependencies..."
    Progress FilePath FilePath SolverInstallPlan
-> IO (Progress FilePath FilePath SolverInstallPlan)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Progress FilePath FilePath SolverInstallPlan
 -> IO (Progress FilePath FilePath SolverInstallPlan))
-> Progress FilePath FilePath SolverInstallPlan
-> IO (Progress FilePath FilePath SolverInstallPlan)
forall a b. (a -> b) -> a -> b
$
      Verbosity
-> Compiler
-> Platform
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> Maybe PkgConfigDb
-> [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
-> Progress FilePath FilePath SolverInstallPlan
planPackages
        Verbosity
verbosity
        Compiler
comp
        Platform
platform
        ConfigFlags
configFlags
        ConfigExFlags
configExFlags
        InstallFlags
installFlags
        InstalledPackageIndex
installedPkgIndex
        SourcePackageDb
sourcePkgDb
        Maybe PkgConfigDb
pkgConfigDb
        [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers

-- | Given an install plan, perform the actual installations.
processInstallPlan
  :: Verbosity
  -> InstallArgs
  -> InstallContext
  -> SolverInstallPlan
  -> IO ()
processInstallPlan :: Verbosity
-> InstallArgs -> InstallContext -> SolverInstallPlan -> IO ()
processInstallPlan
  Verbosity
verbosity
  args :: InstallArgs
args@(PackageDBStackCWD
_, RepoContext
_, Compiler
_, Platform
_, ProgramDb
_, GlobalFlags
_, ConfigFlags
configFlags, ConfigExFlags
_, InstallFlags
installFlags, HaddockFlags
_, TestFlags
_, BenchmarkFlags
_)
  ( InstalledPackageIndex
installedPkgIndex
    , SourcePackageDb
sourcePkgDb
    , Maybe PkgConfigDb
_
    , [UserTarget]
userTargets
    , [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers
    , HttpTransport
_
    )
  SolverInstallPlan
installPlan0 = do
    Verbosity
-> InstalledPackageIndex
-> InstallPlan
-> SourcePackageDb
-> InstallFlags
-> [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
-> IO ()
checkPrintPlan
      Verbosity
verbosity
      InstalledPackageIndex
installedPkgIndex
      InstallPlan
installPlan
      SourcePackageDb
sourcePkgDb
      InstallFlags
installFlags
      [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
dryRun Bool -> Bool -> Bool
|| Bool
nothingToInstall) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      BuildOutcomes
buildOutcomes <-
        Verbosity
-> InstallArgs
-> InstalledPackageIndex
-> InstallPlan
-> IO BuildOutcomes
performInstallations
          Verbosity
verbosity
          InstallArgs
args
          InstalledPackageIndex
installedPkgIndex
          InstallPlan
installPlan
      Verbosity
-> InstallArgs
-> [UserTarget]
-> InstallPlan
-> BuildOutcomes
-> IO ()
postInstallActions Verbosity
verbosity InstallArgs
args [UserTarget]
userTargets InstallPlan
installPlan BuildOutcomes
buildOutcomes
    where
      installPlan :: InstallPlan
installPlan = ConfigFlags -> SolverInstallPlan -> InstallPlan
InstallPlan.configureInstallPlan ConfigFlags
configFlags SolverInstallPlan
installPlan0
      dryRun :: Bool
dryRun = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installDryRun InstallFlags
installFlags)
      nothingToInstall :: Bool
nothingToInstall = [GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (([GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)],
 Processing)
-> [GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)]
forall a b. (a, b) -> a
fst (InstallPlan
-> ([GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)],
    Processing)
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> ([GenericReadyPackage srcpkg], Processing)
InstallPlan.ready InstallPlan
installPlan))

-- ------------------------------------------------------------

-- * Installation planning

-- ------------------------------------------------------------

planPackages
  :: Verbosity
  -> Compiler
  -> Platform
  -> ConfigFlags
  -> ConfigExFlags
  -> InstallFlags
  -> InstalledPackageIndex
  -> SourcePackageDb
  -> Maybe PkgConfigDb
  -> [PackageSpecifier UnresolvedSourcePackage]
  -> Progress String String SolverInstallPlan
planPackages :: Verbosity
-> Compiler
-> Platform
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> Maybe PkgConfigDb
-> [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
-> Progress FilePath FilePath SolverInstallPlan
planPackages
  Verbosity
verbosity
  Compiler
comp
  Platform
platform
  ConfigFlags
configFlags
  ConfigExFlags
configExFlags
  InstallFlags
installFlags
  InstalledPackageIndex
installedPkgIndex
  SourcePackageDb
sourcePkgDb
  Maybe PkgConfigDb
pkgConfigDb
  [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers =
    Platform
-> CompilerInfo
-> Maybe PkgConfigDb
-> DepResolverParams
-> Progress FilePath FilePath SolverInstallPlan
resolveDependencies
      Platform
platform
      (Compiler -> CompilerInfo
compilerInfo Compiler
comp)
      Maybe PkgConfigDb
pkgConfigDb
      DepResolverParams
resolverParams
      Progress FilePath FilePath SolverInstallPlan
-> (SolverInstallPlan
    -> Progress FilePath FilePath SolverInstallPlan)
-> Progress FilePath FilePath SolverInstallPlan
forall a b.
Progress FilePath FilePath a
-> (a -> Progress FilePath FilePath b)
-> Progress FilePath FilePath b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= if Bool
onlyDeps then [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
-> SolverInstallPlan
-> Progress FilePath FilePath SolverInstallPlan
forall targetpkg.
Package targetpkg =>
[PackageSpecifier targetpkg]
-> SolverInstallPlan
-> Progress FilePath FilePath SolverInstallPlan
pruneInstallPlan [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers else SolverInstallPlan -> Progress FilePath FilePath SolverInstallPlan
forall a. a -> Progress FilePath FilePath a
forall (m :: * -> *) a. Monad m => a -> m a
return
    where
      resolverParams :: DepResolverParams
resolverParams =
        Maybe Int -> DepResolverParams -> DepResolverParams
setMaxBackjumps
          ( if Int
maxBackjumps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
              then Maybe Int
forall a. Maybe a
Nothing
              else Int -> Maybe Int
forall a. a -> Maybe a
Just Int
maxBackjumps
          )
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndependentGoals -> DepResolverParams -> DepResolverParams
setIndependentGoals IndependentGoals
independentGoals
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReorderGoals -> DepResolverParams -> DepResolverParams
setReorderGoals ReorderGoals
reorderGoals
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CountConflicts -> DepResolverParams -> DepResolverParams
setCountConflicts CountConflicts
countConflicts
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FineGrainedConflicts -> DepResolverParams -> DepResolverParams
setFineGrainedConflicts FineGrainedConflicts
fineGrainedConflicts
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MinimizeConflictSet -> DepResolverParams -> DepResolverParams
setMinimizeConflictSet MinimizeConflictSet
minimizeConflictSet
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AvoidReinstalls -> DepResolverParams -> DepResolverParams
setAvoidReinstalls AvoidReinstalls
avoidReinstalls
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShadowPkgs -> DepResolverParams -> DepResolverParams
setShadowPkgs ShadowPkgs
shadowPkgs
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrongFlags -> DepResolverParams -> DepResolverParams
setStrongFlags StrongFlags
strongFlags
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllowBootLibInstalls -> DepResolverParams -> DepResolverParams
setAllowBootLibInstalls AllowBootLibInstalls
allowBootLibInstalls
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnlyConstrained -> DepResolverParams -> DepResolverParams
setOnlyConstrained OnlyConstrained
onlyConstrained
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> DepResolverParams -> DepResolverParams
setSolverVerbosity Verbosity
verbosity
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackagesPreferenceDefault -> DepResolverParams -> DepResolverParams
setPreferenceDefault
            ( if Bool
upgradeDeps
                then PackagesPreferenceDefault
PreferAllLatest
                else PackagesPreferenceDefault
PreferLatestForSelected
            )
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllowOlder -> DepResolverParams -> DepResolverParams
removeLowerBounds AllowOlder
allowOlder
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllowNewer -> DepResolverParams -> DepResolverParams
removeUpperBounds AllowNewer
allowNewer
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PackagePreference] -> DepResolverParams -> DepResolverParams
addPreferences
            -- preferences from the config file or command line
            [ PackageName -> VersionRange -> PackagePreference
PackageVersionPreference PackageName
name VersionRange
ver
            | PackageVersionConstraint PackageName
name VersionRange
ver <- ConfigExFlags -> [PackageVersionConstraint]
configPreferences ConfigExFlags
configExFlags
            ]
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LabeledPackageConstraint]
-> DepResolverParams -> DepResolverParams
addConstraints
            -- version constraints from the config file or command line
            [ PackageConstraint -> ConstraintSource -> LabeledPackageConstraint
LabeledPackageConstraint (UserConstraint -> PackageConstraint
userToPackageConstraint UserConstraint
pc) ConstraintSource
src
            | (UserConstraint
pc, ConstraintSource
src) <- ConfigExFlags -> [(UserConstraint, ConstraintSource)]
configExConstraints ConfigExFlags
configExFlags
            ]
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LabeledPackageConstraint]
-> DepResolverParams -> DepResolverParams
addConstraints
            -- FIXME: this just applies all flags to all targets which
            -- is silly. We should check if the flags are appropriate
            [ let pc :: PackageConstraint
pc =
                    ConstraintScope -> PackageProperty -> PackageConstraint
PackageConstraint
                      (PackageName -> ConstraintScope
scopeToplevel (PackageName -> ConstraintScope) -> PackageName -> ConstraintScope
forall a b. (a -> b) -> a -> b
$ PackageSpecifier (SourcePackage UnresolvedPkgLoc) -> PackageName
forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget PackageSpecifier (SourcePackage UnresolvedPkgLoc)
pkgSpecifier)
                      (FlagAssignment -> PackageProperty
PackagePropertyFlags FlagAssignment
flags)
               in PackageConstraint -> ConstraintSource -> LabeledPackageConstraint
LabeledPackageConstraint PackageConstraint
pc ConstraintSource
ConstraintSourceConfigFlagOrTarget
            | let flags :: FlagAssignment
flags = ConfigFlags -> FlagAssignment
configConfigurationsFlags ConfigFlags
configFlags
            , Bool -> Bool
not (FlagAssignment -> Bool
nullFlagAssignment FlagAssignment
flags)
            , PackageSpecifier (SourcePackage UnresolvedPkgLoc)
pkgSpecifier <- [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers
            ]
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LabeledPackageConstraint]
-> DepResolverParams -> DepResolverParams
addConstraints
            [ let pc :: PackageConstraint
pc =
                    ConstraintScope -> PackageProperty -> PackageConstraint
PackageConstraint
                      (PackageName -> ConstraintScope
scopeToplevel (PackageName -> ConstraintScope) -> PackageName -> ConstraintScope
forall a b. (a -> b) -> a -> b
$ PackageSpecifier (SourcePackage UnresolvedPkgLoc) -> PackageName
forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget PackageSpecifier (SourcePackage UnresolvedPkgLoc)
pkgSpecifier)
                      ([OptionalStanza] -> PackageProperty
PackagePropertyStanzas [OptionalStanza]
stanzas)
               in PackageConstraint -> ConstraintSource -> LabeledPackageConstraint
LabeledPackageConstraint PackageConstraint
pc ConstraintSource
ConstraintSourceConfigFlagOrTarget
            | PackageSpecifier (SourcePackage UnresolvedPkgLoc)
pkgSpecifier <- [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers
            ]
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
reinstall then DepResolverParams -> DepResolverParams
reinstallTargets else DepResolverParams -> DepResolverParams
forall a. a -> a
id)
          -- Don't solve for executables, the legacy install codepath
          -- doesn't understand how to install them
          (DepResolverParams -> DepResolverParams)
-> (DepResolverParams -> DepResolverParams)
-> DepResolverParams
-> DepResolverParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SolveExecutables -> DepResolverParams -> DepResolverParams
setSolveExecutables (Bool -> SolveExecutables
SolveExecutables Bool
False)
          (DepResolverParams -> DepResolverParams)
-> DepResolverParams -> DepResolverParams
forall a b. (a -> b) -> a -> b
$ InstalledPackageIndex
-> SourcePackageDb
-> [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
-> DepResolverParams
standardInstallPolicy
            InstalledPackageIndex
installedPkgIndex
            SourcePackageDb
sourcePkgDb
            [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers

      stanzas :: [OptionalStanza]
stanzas =
        [OptionalStanza
TestStanzas | Bool
testsEnabled]
          [OptionalStanza] -> [OptionalStanza] -> [OptionalStanza]
forall a. [a] -> [a] -> [a]
++ [OptionalStanza
BenchStanzas | Bool
benchmarksEnabled]
      testsEnabled :: Bool
testsEnabled = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> Flag Bool
configTests ConfigFlags
configFlags
      benchmarksEnabled :: Bool
benchmarksEnabled = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> Flag Bool
configBenchmarks ConfigFlags
configFlags

      reinstall :: Bool
reinstall =
        Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installOverrideReinstall InstallFlags
installFlags)
          Bool -> Bool -> Bool
|| Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installReinstall InstallFlags
installFlags)
      reorderGoals :: ReorderGoals
reorderGoals = Flag ReorderGoals -> ReorderGoals
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag ReorderGoals
installReorderGoals InstallFlags
installFlags)
      countConflicts :: CountConflicts
countConflicts = Flag CountConflicts -> CountConflicts
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag CountConflicts
installCountConflicts InstallFlags
installFlags)
      fineGrainedConflicts :: FineGrainedConflicts
fineGrainedConflicts = Flag FineGrainedConflicts -> FineGrainedConflicts
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag FineGrainedConflicts
installFineGrainedConflicts InstallFlags
installFlags)
      minimizeConflictSet :: MinimizeConflictSet
minimizeConflictSet = Flag MinimizeConflictSet -> MinimizeConflictSet
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag MinimizeConflictSet
installMinimizeConflictSet InstallFlags
installFlags)
      independentGoals :: IndependentGoals
independentGoals = Flag IndependentGoals -> IndependentGoals
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag IndependentGoals
installIndependentGoals InstallFlags
installFlags)
      avoidReinstalls :: AvoidReinstalls
avoidReinstalls = Flag AvoidReinstalls -> AvoidReinstalls
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag AvoidReinstalls
installAvoidReinstalls InstallFlags
installFlags)
      shadowPkgs :: ShadowPkgs
shadowPkgs = Flag ShadowPkgs -> ShadowPkgs
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag ShadowPkgs
installShadowPkgs InstallFlags
installFlags)
      strongFlags :: StrongFlags
strongFlags = Flag StrongFlags -> StrongFlags
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag StrongFlags
installStrongFlags InstallFlags
installFlags)
      maxBackjumps :: Int
maxBackjumps = Flag Int -> Int
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Int
installMaxBackjumps InstallFlags
installFlags)
      allowBootLibInstalls :: AllowBootLibInstalls
allowBootLibInstalls = Flag AllowBootLibInstalls -> AllowBootLibInstalls
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag AllowBootLibInstalls
installAllowBootLibInstalls InstallFlags
installFlags)
      onlyConstrained :: OnlyConstrained
onlyConstrained = Flag OnlyConstrained -> OnlyConstrained
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag OnlyConstrained
installOnlyConstrained InstallFlags
installFlags)
      upgradeDeps :: Bool
upgradeDeps = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installUpgradeDeps InstallFlags
installFlags)
      onlyDeps :: Bool
onlyDeps = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installOnlyDeps InstallFlags
installFlags)

      allowOlder :: AllowOlder
allowOlder =
        AllowOlder -> Maybe AllowOlder -> AllowOlder
forall a. a -> Maybe a -> a
fromMaybe
          (RelaxDeps -> AllowOlder
AllowOlder RelaxDeps
forall a. Monoid a => a
mempty)
          (ConfigExFlags -> Maybe AllowOlder
configAllowOlder ConfigExFlags
configExFlags)
      allowNewer :: AllowNewer
allowNewer =
        AllowNewer -> Maybe AllowNewer -> AllowNewer
forall a. a -> Maybe a -> a
fromMaybe
          (RelaxDeps -> AllowNewer
AllowNewer RelaxDeps
forall a. Monoid a => a
mempty)
          (ConfigExFlags -> Maybe AllowNewer
configAllowNewer ConfigExFlags
configExFlags)

-- | Remove the provided targets from the install plan.
pruneInstallPlan
  :: Package targetpkg
  => [PackageSpecifier targetpkg]
  -> SolverInstallPlan
  -> Progress String String SolverInstallPlan
pruneInstallPlan :: forall targetpkg.
Package targetpkg =>
[PackageSpecifier targetpkg]
-> SolverInstallPlan
-> Progress FilePath FilePath SolverInstallPlan
pruneInstallPlan [PackageSpecifier targetpkg]
pkgSpecifiers =
  -- TODO: this is a general feature and should be moved to D.C.Dependency
  -- Also, the InstallPlan.remove should return info more precise to the
  -- problem, rather than the very general PlanProblem type.
  ([SolverPlanProblem]
 -> Progress FilePath FilePath SolverInstallPlan)
-> (SolverInstallPlan
    -> Progress FilePath FilePath SolverInstallPlan)
-> Either [SolverPlanProblem] SolverInstallPlan
-> Progress FilePath FilePath SolverInstallPlan
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> Progress FilePath FilePath SolverInstallPlan
forall step fail done. fail -> Progress step fail done
Fail (FilePath -> Progress FilePath FilePath SolverInstallPlan)
-> ([SolverPlanProblem] -> FilePath)
-> [SolverPlanProblem]
-> Progress FilePath FilePath SolverInstallPlan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SolverPlanProblem] -> FilePath
explain) SolverInstallPlan -> Progress FilePath FilePath SolverInstallPlan
forall step fail done. done -> Progress step fail done
Done
    (Either [SolverPlanProblem] SolverInstallPlan
 -> Progress FilePath FilePath SolverInstallPlan)
-> (SolverInstallPlan
    -> Either [SolverPlanProblem] SolverInstallPlan)
-> SolverInstallPlan
-> Progress FilePath FilePath SolverInstallPlan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SolverPlanPackage -> Bool)
-> SolverInstallPlan
-> Either [SolverPlanProblem] SolverInstallPlan
SolverInstallPlan.remove (\SolverPlanPackage
pkg -> SolverPlanPackage -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName SolverPlanPackage
pkg PackageName -> [PackageName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
targetnames)
  where
    explain :: [SolverInstallPlan.SolverPlanProblem] -> String
    explain :: [SolverPlanProblem] -> FilePath
explain [SolverPlanProblem]
problems =
      FilePath
"Cannot select only the dependencies (as requested by the "
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'--only-dependencies' flag), "
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ( case [PackageIdentifier]
pkgids of
              [PackageIdentifier
pkgid] -> FilePath
"the package " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgid FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" is "
              [PackageIdentifier]
_ ->
                FilePath
"the packages "
                  FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " ((PackageIdentifier -> FilePath)
-> [PackageIdentifier] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow [PackageIdentifier]
pkgids)
                  FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" are "
           )
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"required by a dependency of one of the other targets."
      where
        pkgids :: [PackageIdentifier]
pkgids =
          [PackageIdentifier] -> [PackageIdentifier]
forall a. Eq a => [a] -> [a]
nub
            [ PackageIdentifier
depid
            | SolverInstallPlan.PackageMissingDeps SolverPlanPackage
_ [PackageIdentifier]
depids <- [SolverPlanProblem]
problems
            , PackageIdentifier
depid <- [PackageIdentifier]
depids
            , PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
depid PackageName -> [PackageName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
targetnames
            ]

    targetnames :: [PackageName]
targetnames = (PackageSpecifier targetpkg -> PackageName)
-> [PackageSpecifier targetpkg] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier targetpkg -> PackageName
forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget [PackageSpecifier targetpkg]
pkgSpecifiers

-- ------------------------------------------------------------

-- * Informational messages

-- ------------------------------------------------------------

-- | Perform post-solver checks of the install plan and print it if
-- either requested or needed.
checkPrintPlan
  :: Verbosity
  -> InstalledPackageIndex
  -> InstallPlan
  -> SourcePackageDb
  -> InstallFlags
  -> [PackageSpecifier UnresolvedSourcePackage]
  -> IO ()
checkPrintPlan :: Verbosity
-> InstalledPackageIndex
-> InstallPlan
-> SourcePackageDb
-> InstallFlags
-> [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
-> IO ()
checkPrintPlan
  Verbosity
verbosity
  InstalledPackageIndex
installed
  InstallPlan
installPlan
  SourcePackageDb
sourcePkgDb
  InstallFlags
installFlags
  [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers = do
    -- User targets that are already installed.
    let preExistingTargets :: [InstalledPackageInfo]
preExistingTargets =
          [ InstalledPackageInfo
p | let tgts :: [PackageName]
tgts = (PackageSpecifier (SourcePackage UnresolvedPkgLoc) -> PackageName)
-> [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
-> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier (SourcePackage UnresolvedPkgLoc) -> PackageName
forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers, InstallPlan.PreExisting InstalledPackageInfo
p <- InstallPlan
-> [GenericPlanPackage
      InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList InstallPlan
installPlan, InstalledPackageInfo -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName InstalledPackageInfo
p PackageName -> [PackageName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
tgts
          ]

    -- If there's nothing to install, we print the already existing
    -- target packages as an explanation.
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
nothingToInstall (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
          FilePath
"All the requested packages are already installed:"
            FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: (InstalledPackageInfo -> FilePath)
-> [InstalledPackageInfo] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageIdentifier -> FilePath)
-> (InstalledPackageInfo -> PackageIdentifier)
-> InstalledPackageInfo
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId) [InstalledPackageInfo]
preExistingTargets
            [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"Use --reinstall if you want to reinstall anyway."]

    let lPlan :: [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
  PackageStatus)]
lPlan =
          [ (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
pkg, PackageStatus
status)
          | GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
pkg <- InstallPlan
-> [GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)]
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg -> [GenericReadyPackage srcpkg]
InstallPlan.executionOrder InstallPlan
installPlan
          , let status :: PackageStatus
status = InstalledPackageIndex
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> PackageStatus
packageStatus InstalledPackageIndex
installed GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
pkg
          ]
    -- Are any packages classified as reinstalls?
    let reinstalledPkgs :: [UnitId]
reinstalledPkgs =
          [ UnitId
ipkg
          | (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
_pkg, PackageStatus
status) <- [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
  PackageStatus)]
lPlan
          , UnitId
ipkg <- PackageStatus -> [UnitId]
extractReinstalls PackageStatus
status
          ]
    -- Packages that are already broken.
    let oldBrokenPkgs :: [UnitId]
oldBrokenPkgs =
          (InstalledPackageInfo -> UnitId)
-> [InstalledPackageInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map InstalledPackageInfo -> UnitId
Installed.installedUnitId
            ([InstalledPackageInfo] -> [UnitId])
-> (InstalledPackageIndex -> [InstalledPackageInfo])
-> InstalledPackageIndex
-> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageIndex -> [UnitId] -> [InstalledPackageInfo]
forall a. PackageInstalled a => PackageIndex a -> [UnitId] -> [a]
PackageIndex.reverseDependencyClosure InstalledPackageIndex
installed
            ([UnitId] -> [InstalledPackageInfo])
-> (InstalledPackageIndex -> [UnitId])
-> InstalledPackageIndex
-> [InstalledPackageInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((InstalledPackageInfo, [UnitId]) -> UnitId)
-> [(InstalledPackageInfo, [UnitId])] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (InstalledPackageInfo -> UnitId
Installed.installedUnitId (InstalledPackageInfo -> UnitId)
-> ((InstalledPackageInfo, [UnitId]) -> InstalledPackageInfo)
-> (InstalledPackageInfo, [UnitId])
-> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstalledPackageInfo, [UnitId]) -> InstalledPackageInfo
forall a b. (a, b) -> a
fst)
            ([(InstalledPackageInfo, [UnitId])] -> [UnitId])
-> (InstalledPackageIndex -> [(InstalledPackageInfo, [UnitId])])
-> InstalledPackageIndex
-> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageIndex -> [(InstalledPackageInfo, [UnitId])]
forall a. PackageInstalled a => PackageIndex a -> [(a, [UnitId])]
PackageIndex.brokenPackages
            (InstalledPackageIndex -> [UnitId])
-> InstalledPackageIndex -> [UnitId]
forall a b. (a -> b) -> a -> b
$ InstalledPackageIndex
installed
    let excluded :: [UnitId]
excluded = [UnitId]
reinstalledPkgs [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ [UnitId]
oldBrokenPkgs
    -- Packages that are reverse dependencies of replaced packages are very
    -- likely to be broken. We exclude packages that are already broken.
    let newBrokenPkgs :: [InstalledPackageInfo]
newBrokenPkgs =
          (InstalledPackageInfo -> Bool)
-> [InstalledPackageInfo] -> [InstalledPackageInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter
            (\InstalledPackageInfo
p -> Bool -> Bool
not (InstalledPackageInfo -> UnitId
Installed.installedUnitId InstalledPackageInfo
p UnitId -> [UnitId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnitId]
excluded))
            (InstalledPackageIndex -> [UnitId] -> [InstalledPackageInfo]
forall a. PackageInstalled a => PackageIndex a -> [UnitId] -> [a]
PackageIndex.reverseDependencyClosure InstalledPackageIndex
installed [UnitId]
reinstalledPkgs)
    let containsReinstalls :: Bool
containsReinstalls = Bool -> Bool
not ([UnitId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitId]
reinstalledPkgs)
    let breaksPkgs :: Bool
breaksPkgs = Bool -> Bool
not ([InstalledPackageInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InstalledPackageInfo]
newBrokenPkgs)

    let adaptedVerbosity :: Verbosity
adaptedVerbosity
          | Bool
containsReinstalls
          , Bool -> Bool
not Bool
overrideReinstall =
              (Verbosity -> Verbosity) -> Verbosity -> Verbosity
modifyVerbosity (Verbosity -> Verbosity -> Verbosity
forall a. Ord a => a -> a -> a
max Verbosity
verbose) Verbosity
verbosity
          | Bool
otherwise = Verbosity
verbosity

    -- We print the install plan if we are in a dry-run or if we are confronted
    -- with a dangerous install plan.
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
dryRun Bool -> Bool -> Bool
|| Bool
containsReinstalls Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
overrideReinstall) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Bool
-> Verbosity
-> [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
     PackageStatus)]
-> SourcePackageDb
-> IO ()
printPlan
        (Bool
dryRun Bool -> Bool -> Bool
|| Bool
breaksPkgs Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
overrideReinstall)
        Verbosity
adaptedVerbosity
        [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
  PackageStatus)]
lPlan
        SourcePackageDb
sourcePkgDb

    -- If the install plan is dangerous, we print various warning messages. In
    -- particular, if we can see that packages are likely to be broken, we even
    -- bail out (unless installation has been forced with --force-reinstalls).
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
containsReinstalls (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      let errorStr :: FilePath
errorStr =
            [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
              FilePath
"The following packages are likely to be broken by the reinstalls:"
                FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: (InstalledPackageInfo -> FilePath)
-> [InstalledPackageInfo] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (MungedPackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (MungedPackageId -> FilePath)
-> (InstalledPackageInfo -> MungedPackageId)
-> InstalledPackageInfo
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> MungedPackageId
forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId) [InstalledPackageInfo]
newBrokenPkgs
                [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ if Bool
overrideReinstall
                  then
                    if Bool
dryRun
                      then []
                      else
                        [ FilePath
"Continuing even though "
                            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"the plan contains dangerous reinstalls."
                        ]
                  else [FilePath
"Use --force-reinstalls if you want to install anyway."]
      if Bool
breaksPkgs
        then do
          ( if Bool
dryRun Bool -> Bool -> Bool
|| Bool
overrideReinstall
              then Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity FilePath
errorStr
              else Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalInstallException
BrokenException FilePath
errorStr
            )
        else
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dryRun (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Verbosity -> FilePath -> IO ()
warn
              Verbosity
verbosity
              FilePath
"Note that reinstalls are always dangerous. Continuing anyway..."

    -- If we are explicitly told to not download anything, check that all packages
    -- are already fetched.
    let offline :: Bool
offline = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (InstallFlags -> Flag Bool
installOfflineMode InstallFlags
installFlags)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
offline (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      let pkgs :: [SourcePackage UnresolvedPkgLoc]
pkgs =
            [ ConfiguredPackage UnresolvedPkgLoc
-> SourcePackage UnresolvedPkgLoc
forall loc. ConfiguredPackage loc -> SourcePackage loc
confPkgSource ConfiguredPackage UnresolvedPkgLoc
cpkg
            | InstallPlan.Configured ConfiguredPackage UnresolvedPkgLoc
cpkg <- InstallPlan
-> [GenericPlanPackage
      InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList InstallPlan
installPlan
            ]
      [PackageIdentifier]
notFetched <-
        ([SourcePackage UnresolvedPkgLoc] -> [PackageIdentifier])
-> IO [SourcePackage UnresolvedPkgLoc] -> IO [PackageIdentifier]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SourcePackage UnresolvedPkgLoc -> PackageIdentifier)
-> [SourcePackage UnresolvedPkgLoc] -> [PackageIdentifier]
forall a b. (a -> b) -> [a] -> [b]
map SourcePackage UnresolvedPkgLoc -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId)
          (IO [SourcePackage UnresolvedPkgLoc] -> IO [PackageIdentifier])
-> ([SourcePackage UnresolvedPkgLoc]
    -> IO [SourcePackage UnresolvedPkgLoc])
-> [SourcePackage UnresolvedPkgLoc]
-> IO [PackageIdentifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourcePackage UnresolvedPkgLoc -> IO Bool)
-> [SourcePackage UnresolvedPkgLoc]
-> IO [SourcePackage UnresolvedPkgLoc]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Maybe ResolvedPkgLoc -> Bool)
-> IO (Maybe ResolvedPkgLoc) -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe ResolvedPkgLoc -> Bool
forall a. Maybe a -> Bool
isNothing (IO (Maybe ResolvedPkgLoc) -> IO Bool)
-> (SourcePackage UnresolvedPkgLoc -> IO (Maybe ResolvedPkgLoc))
-> SourcePackage UnresolvedPkgLoc
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnresolvedPkgLoc -> IO (Maybe ResolvedPkgLoc)
checkFetched (UnresolvedPkgLoc -> IO (Maybe ResolvedPkgLoc))
-> (SourcePackage UnresolvedPkgLoc -> UnresolvedPkgLoc)
-> SourcePackage UnresolvedPkgLoc
-> IO (Maybe ResolvedPkgLoc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePackage UnresolvedPkgLoc -> UnresolvedPkgLoc
forall loc. SourcePackage loc -> loc
srcpkgSource)
          ([SourcePackage UnresolvedPkgLoc] -> IO [PackageIdentifier])
-> [SourcePackage UnresolvedPkgLoc] -> IO [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$ [SourcePackage UnresolvedPkgLoc]
pkgs
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PackageIdentifier] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageIdentifier]
notFetched) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
          [FilePath] -> CabalInstallException
Can'tDownloadPackagesOffline ((PackageIdentifier -> FilePath)
-> [PackageIdentifier] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow [PackageIdentifier]
notFetched)
    where
      nothingToInstall :: Bool
nothingToInstall = [GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (([GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)],
 Processing)
-> [GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)]
forall a b. (a, b) -> a
fst (InstallPlan
-> ([GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)],
    Processing)
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> ([GenericReadyPackage srcpkg], Processing)
InstallPlan.ready InstallPlan
installPlan))

      dryRun :: Bool
dryRun = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installDryRun InstallFlags
installFlags)
      overrideReinstall :: Bool
overrideReinstall = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installOverrideReinstall InstallFlags
installFlags)

data PackageStatus
  = NewPackage
  | NewVersion [Version]
  | Reinstall [UnitId] [PackageChange]

type PackageChange = MergeResult MungedPackageId MungedPackageId

extractReinstalls :: PackageStatus -> [UnitId]
extractReinstalls :: PackageStatus -> [UnitId]
extractReinstalls (Reinstall [UnitId]
ipids [PackageChange]
_) = [UnitId]
ipids
extractReinstalls PackageStatus
_ = []

packageStatus
  :: InstalledPackageIndex
  -> ReadyPackage
  -> PackageStatus
packageStatus :: InstalledPackageIndex
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> PackageStatus
packageStatus InstalledPackageIndex
installedPkgIndex GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
cpkg =
  case InstalledPackageIndex
-> PackageName -> [(Version, [InstalledPackageInfo])]
forall a. PackageIndex a -> PackageName -> [(Version, [a])]
PackageIndex.lookupPackageName
    InstalledPackageIndex
installedPkgIndex
    (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
cpkg) of
    [] -> PackageStatus
NewPackage
    [(Version, [InstalledPackageInfo])]
ps -> case (InstalledPackageInfo -> Bool)
-> [InstalledPackageInfo] -> [InstalledPackageInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter
      ( (MungedPackageId -> MungedPackageId -> Bool
forall a. Eq a => a -> a -> Bool
== GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> MungedPackageId
forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
cpkg)
          (MungedPackageId -> Bool)
-> (InstalledPackageInfo -> MungedPackageId)
-> InstalledPackageInfo
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> MungedPackageId
forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId
      )
      (((Version, [InstalledPackageInfo]) -> [InstalledPackageInfo])
-> [(Version, [InstalledPackageInfo])] -> [InstalledPackageInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Version, [InstalledPackageInfo]) -> [InstalledPackageInfo]
forall a b. (a, b) -> b
snd [(Version, [InstalledPackageInfo])]
ps) of
      [] -> [Version] -> PackageStatus
NewVersion (((Version, [InstalledPackageInfo]) -> Version)
-> [(Version, [InstalledPackageInfo])] -> [Version]
forall a b. (a -> b) -> [a] -> [b]
map (Version, [InstalledPackageInfo]) -> Version
forall a b. (a, b) -> a
fst [(Version, [InstalledPackageInfo])]
ps)
      pkgs :: [InstalledPackageInfo]
pkgs@(InstalledPackageInfo
pkg : [InstalledPackageInfo]
_) ->
        [UnitId] -> [PackageChange] -> PackageStatus
Reinstall
          ((InstalledPackageInfo -> UnitId)
-> [InstalledPackageInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map InstalledPackageInfo -> UnitId
Installed.installedUnitId [InstalledPackageInfo]
pkgs)
          (InstalledPackageInfo
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> [PackageChange]
changes InstalledPackageInfo
pkg GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
cpkg)
  where
    changes
      :: Installed.InstalledPackageInfo
      -> ReadyPackage
      -> [PackageChange]
    changes :: InstalledPackageInfo
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> [PackageChange]
changes InstalledPackageInfo
pkg (ReadyPackage ConfiguredPackage UnresolvedPkgLoc
pkg') =
      (PackageChange -> Bool) -> [PackageChange] -> [PackageChange]
forall a. (a -> Bool) -> [a] -> [a]
filter PackageChange -> Bool
forall {a}. Eq a => MergeResult a a -> Bool
changed ([PackageChange] -> [PackageChange])
-> [PackageChange] -> [PackageChange]
forall a b. (a -> b) -> a -> b
$
        (MungedPackageId -> MungedPackageId -> Ordering)
-> [MungedPackageId] -> [MungedPackageId] -> [PackageChange]
forall a b. (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
mergeBy
          ((MungedPackageId -> MungedPackageName)
-> MungedPackageId -> MungedPackageId -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing MungedPackageId -> MungedPackageName
mungedName)
          -- deps of installed pkg
          ([UnitId] -> [MungedPackageId]
resolveInstalledIds ([UnitId] -> [MungedPackageId]) -> [UnitId] -> [MungedPackageId]
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo -> [UnitId]
Installed.depends InstalledPackageInfo
pkg)
          -- deps of configured pkg
          ([UnitId] -> [MungedPackageId]
resolveInstalledIds ([UnitId] -> [MungedPackageId]) -> [UnitId] -> [MungedPackageId]
forall a b. (a -> b) -> a -> b
$ ComponentDeps [UnitId] -> [UnitId]
forall a. Monoid a => ComponentDeps a -> a
CD.nonSetupDeps (ConfiguredPackage UnresolvedPkgLoc -> ComponentDeps [UnitId]
forall pkg. PackageFixedDeps pkg => pkg -> ComponentDeps [UnitId]
depends ConfiguredPackage UnresolvedPkgLoc
pkg'))

    -- convert to source pkg ids via index
    resolveInstalledIds :: [UnitId] -> [MungedPackageId]
    resolveInstalledIds :: [UnitId] -> [MungedPackageId]
resolveInstalledIds =
      [MungedPackageId] -> [MungedPackageId]
forall a. Eq a => [a] -> [a]
nub
        ([MungedPackageId] -> [MungedPackageId])
-> ([UnitId] -> [MungedPackageId]) -> [UnitId] -> [MungedPackageId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MungedPackageId] -> [MungedPackageId]
forall a. Ord a => [a] -> [a]
sort
        ([MungedPackageId] -> [MungedPackageId])
-> ([UnitId] -> [MungedPackageId]) -> [UnitId] -> [MungedPackageId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstalledPackageInfo -> MungedPackageId)
-> [InstalledPackageInfo] -> [MungedPackageId]
forall a b. (a -> b) -> [a] -> [b]
map InstalledPackageInfo -> MungedPackageId
forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId
        ([InstalledPackageInfo] -> [MungedPackageId])
-> ([UnitId] -> [InstalledPackageInfo])
-> [UnitId]
-> [MungedPackageId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId -> Maybe InstalledPackageInfo)
-> [UnitId] -> [InstalledPackageInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (InstalledPackageIndex -> UnitId -> Maybe InstalledPackageInfo
forall a. PackageIndex a -> UnitId -> Maybe a
PackageIndex.lookupUnitId InstalledPackageIndex
installedPkgIndex)

    changed :: MergeResult a a -> Bool
changed (InBoth a
pkgid a
pkgid') = a
pkgid a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
pkgid'
    changed MergeResult a a
_ = Bool
True

printPlan
  :: Bool -- is dry run
  -> Verbosity
  -> [(ReadyPackage, PackageStatus)]
  -> SourcePackageDb
  -> IO ()
printPlan :: Bool
-> Verbosity
-> [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
     PackageStatus)]
-> SourcePackageDb
-> IO ()
printPlan Bool
dryRun Verbosity
verbosity [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
  PackageStatus)]
plan SourcePackageDb
sourcePkgDb = case [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
  PackageStatus)]
plan of
  [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
  PackageStatus)]
pkgs
    | Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Verbosity.verbose ->
        Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
          [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
            (FilePath
"In order, the following " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
wouldWill FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" be installed:")
              FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: ((GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
  PackageStatus)
 -> FilePath)
-> [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
     PackageStatus)]
-> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
 PackageStatus)
-> FilePath
forall {loc}.
(GenericReadyPackage (ConfiguredPackage loc), PackageStatus)
-> FilePath
showPkgAndReason [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
  PackageStatus)]
pkgs
    | Bool
otherwise ->
        Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
          [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
            ( FilePath
"In order, the following "
                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
wouldWill
                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" be installed (use -v for more details):"
            )
              FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: ((GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
  PackageStatus)
 -> FilePath)
-> [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
     PackageStatus)]
-> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
 PackageStatus)
-> FilePath
forall {srcpkg} {b}. Package srcpkg => (srcpkg, b) -> FilePath
showPkg [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
  PackageStatus)]
pkgs
  where
    wouldWill :: FilePath
wouldWill
      | Bool
dryRun = FilePath
"would"
      | Bool
otherwise = FilePath
"will"

    showPkg :: (srcpkg, b) -> FilePath
showPkg (srcpkg
pkg, b
_) =
      PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (srcpkg -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId srcpkg
pkg)
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ srcpkg -> FilePath
forall srcpkg. Package srcpkg => srcpkg -> FilePath
showLatest (srcpkg
pkg)

    showPkgAndReason :: (GenericReadyPackage (ConfiguredPackage loc), PackageStatus)
-> FilePath
showPkgAndReason (ReadyPackage ConfiguredPackage loc
pkg', PackageStatus
pr) =
      [FilePath] -> FilePath
unwords
        [ PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (ConfiguredPackage loc -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ConfiguredPackage loc
pkg')
        , ConfiguredPackage loc -> FilePath
forall srcpkg. Package srcpkg => srcpkg -> FilePath
showLatest ConfiguredPackage loc
pkg'
        , FlagAssignment -> FilePath
showFlagAssignment (ConfiguredPackage loc -> FlagAssignment
forall loc. ConfiguredPackage loc -> FlagAssignment
nonDefaultFlags ConfiguredPackage loc
pkg')
        , OptionalStanzaSet -> FilePath
showStanzas (ConfiguredPackage loc -> OptionalStanzaSet
forall loc. ConfiguredPackage loc -> OptionalStanzaSet
confPkgStanzas ConfiguredPackage loc
pkg')
        , ConfiguredPackage loc -> FilePath
forall srcpkg. Package srcpkg => srcpkg -> FilePath
showDep ConfiguredPackage loc
pkg'
        , case PackageStatus
pr of
            PackageStatus
NewPackage -> FilePath
"(new package)"
            NewVersion [Version]
_ -> FilePath
"(new version)"
            Reinstall [UnitId]
_ [PackageChange]
cs ->
              FilePath
"(reinstall)" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ case [PackageChange]
cs of
                [] -> FilePath
""
                [PackageChange]
diff ->
                  FilePath
"(changes: "
                    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " ((PackageChange -> FilePath) -> [PackageChange] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map PackageChange -> FilePath
forall {a}. Pretty a => MergeResult a MungedPackageId -> FilePath
change [PackageChange]
diff)
                    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")"
        ]

    showLatest :: Package srcpkg => srcpkg -> String
    showLatest :: forall srcpkg. Package srcpkg => srcpkg -> FilePath
showLatest srcpkg
pkg = case Maybe Version
mLatestVersion of
      Just Version
latestVersion ->
        if srcpkg -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion srcpkg
pkg Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
latestVersion
          then (FilePath
"(latest: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow Version
latestVersion FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")")
          else FilePath
""
      Maybe Version
Nothing -> FilePath
""
      where
        mLatestVersion :: Maybe Version
        mLatestVersion :: Maybe Version
mLatestVersion =
          (SourcePackage UnresolvedPkgLoc -> Version)
-> Maybe (SourcePackage UnresolvedPkgLoc) -> Maybe Version
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SourcePackage UnresolvedPkgLoc -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion (Maybe (SourcePackage UnresolvedPkgLoc) -> Maybe Version)
-> Maybe (SourcePackage UnresolvedPkgLoc) -> Maybe Version
forall a b. (a -> b) -> a -> b
$
            [SourcePackage UnresolvedPkgLoc]
-> Maybe (SourcePackage UnresolvedPkgLoc)
forall a. [a] -> Maybe a
safeLast ([SourcePackage UnresolvedPkgLoc]
 -> Maybe (SourcePackage UnresolvedPkgLoc))
-> [SourcePackage UnresolvedPkgLoc]
-> Maybe (SourcePackage UnresolvedPkgLoc)
forall a b. (a -> b) -> a -> b
$
              PackageIndex (SourcePackage UnresolvedPkgLoc)
-> PackageName -> [SourcePackage UnresolvedPkgLoc]
forall pkg. Package pkg => PackageIndex pkg -> PackageName -> [pkg]
SourcePackageIndex.lookupPackageName
                (SourcePackageDb -> PackageIndex (SourcePackage UnresolvedPkgLoc)
packageIndex SourcePackageDb
sourcePkgDb)
                (srcpkg -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName srcpkg
pkg)

    toFlagAssignment :: [PackageFlag] -> FlagAssignment
    toFlagAssignment :: [PackageFlag] -> FlagAssignment
toFlagAssignment = [(FlagName, Bool)] -> FlagAssignment
mkFlagAssignment ([(FlagName, Bool)] -> FlagAssignment)
-> ([PackageFlag] -> [(FlagName, Bool)])
-> [PackageFlag]
-> FlagAssignment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageFlag -> (FlagName, Bool))
-> [PackageFlag] -> [(FlagName, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (\PackageFlag
f -> (PackageFlag -> FlagName
flagName PackageFlag
f, PackageFlag -> Bool
flagDefault PackageFlag
f))

    nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment
    nonDefaultFlags :: forall loc. ConfiguredPackage loc -> FlagAssignment
nonDefaultFlags ConfiguredPackage loc
cpkg =
      let defaultAssignment :: FlagAssignment
defaultAssignment =
            [PackageFlag] -> FlagAssignment
toFlagAssignment
              ( GenericPackageDescription -> [PackageFlag]
genPackageFlags
                  ( SourcePackage loc -> GenericPackageDescription
forall loc. SourcePackage loc -> GenericPackageDescription
SourcePackage.srcpkgDescription (SourcePackage loc -> GenericPackageDescription)
-> SourcePackage loc -> GenericPackageDescription
forall a b. (a -> b) -> a -> b
$
                      ConfiguredPackage loc -> SourcePackage loc
forall loc. ConfiguredPackage loc -> SourcePackage loc
confPkgSource ConfiguredPackage loc
cpkg
                  )
              )
       in ConfiguredPackage loc -> FlagAssignment
forall loc. ConfiguredPackage loc -> FlagAssignment
confPkgFlags ConfiguredPackage loc
cpkg FlagAssignment -> FlagAssignment -> FlagAssignment
`diffFlagAssignment` FlagAssignment
defaultAssignment

    change :: MergeResult a MungedPackageId -> FilePath
change (OnlyInLeft a
pkgid) = a -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow a
pkgid FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" removed"
    change (InBoth a
pkgid MungedPackageId
pkgid') =
      a -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow a
pkgid
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" -> "
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (MungedPackageId -> Version
mungedVersion MungedPackageId
pkgid')
    change (OnlyInRight MungedPackageId
pkgid') = MungedPackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow MungedPackageId
pkgid' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" added"

    showDep :: pkg -> FilePath
showDep pkg
pkg
      | Just [PackageIdentifier]
rdeps <- PackageIdentifier
-> Map PackageIdentifier [PackageIdentifier]
-> Maybe [PackageIdentifier]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (pkg -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId pkg
pkg) Map PackageIdentifier [PackageIdentifier]
revDeps =
          FilePath
" (via: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords ((PackageIdentifier -> FilePath)
-> [PackageIdentifier] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow [PackageIdentifier]
rdeps) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")"
      | Bool
otherwise = FilePath
""

    revDepGraphEdges :: [(PackageId, PackageId)]
    revDepGraphEdges :: [(PackageIdentifier, PackageIdentifier)]
revDepGraphEdges =
      [ (PackageIdentifier
rpid, ConfiguredPackage UnresolvedPkgLoc -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ConfiguredPackage UnresolvedPkgLoc
cpkg)
      | (ReadyPackage ConfiguredPackage UnresolvedPkgLoc
cpkg, PackageStatus
_) <- [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
  PackageStatus)]
plan
      , ConfiguredId
          PackageIdentifier
rpid
          ( Just
              ( PackageDescription.CLibName
                  LibraryName
PackageDescription.LMainLibName
                )
            )
          ComponentId
_ <-
          ComponentDeps [ConfiguredId] -> [ConfiguredId]
forall a. Monoid a => ComponentDeps a -> a
CD.flatDeps (ConfiguredPackage UnresolvedPkgLoc -> ComponentDeps [ConfiguredId]
forall loc. ConfiguredPackage loc -> ComponentDeps [ConfiguredId]
confPkgDeps ConfiguredPackage UnresolvedPkgLoc
cpkg)
      ]

    revDeps :: Map.Map PackageId [PackageId]
    revDeps :: Map PackageIdentifier [PackageIdentifier]
revDeps = ([PackageIdentifier] -> [PackageIdentifier] -> [PackageIdentifier])
-> [(PackageIdentifier, [PackageIdentifier])]
-> Map PackageIdentifier [PackageIdentifier]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [PackageIdentifier] -> [PackageIdentifier] -> [PackageIdentifier]
forall a. [a] -> [a] -> [a]
(++) (((PackageIdentifier, PackageIdentifier)
 -> (PackageIdentifier, [PackageIdentifier]))
-> [(PackageIdentifier, PackageIdentifier)]
-> [(PackageIdentifier, [PackageIdentifier])]
forall a b. (a -> b) -> [a] -> [b]
map ((PackageIdentifier -> [PackageIdentifier])
-> (PackageIdentifier, PackageIdentifier)
-> (PackageIdentifier, [PackageIdentifier])
forall a b.
(a -> b) -> (PackageIdentifier, a) -> (PackageIdentifier, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PackageIdentifier -> [PackageIdentifier] -> [PackageIdentifier]
forall a. a -> [a] -> [a]
: [])) [(PackageIdentifier, PackageIdentifier)]
revDepGraphEdges)

-- ------------------------------------------------------------

-- * Post installation stuff

-- ------------------------------------------------------------

-- | Report a solver failure. This works slightly differently to
-- 'postInstallActions', as (by definition) we don't have an install plan.
reportPlanningFailure
  :: Verbosity
  -> InstallArgs
  -> InstallContext
  -> String
  -> IO ()
reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> FilePath -> IO ()
reportPlanningFailure
  Verbosity
verbosity
  ( PackageDBStackCWD
_
    , RepoContext
_
    , Compiler
comp
    , Platform
platform
    , ProgramDb
_
    , GlobalFlags
_
    , ConfigFlags
configFlags
    , ConfigExFlags
_
    , InstallFlags
installFlags
    , HaddockFlags
_
    , TestFlags
_
    , BenchmarkFlags
_
    )
  (InstalledPackageIndex
_, SourcePackageDb
sourcePkgDb, Maybe PkgConfigDb
_, [UserTarget]
_, [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers, HttpTransport
_)
  FilePath
message = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
reportFailure (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      -- Only create reports for explicitly named packages
      let pkgids :: [PackageIdentifier]
pkgids =
            (PackageIdentifier -> Bool)
-> [PackageIdentifier] -> [PackageIdentifier]
forall a. (a -> Bool) -> [a] -> [a]
filter
              (PackageIndex (SourcePackage UnresolvedPkgLoc)
-> PackageIdentifier -> Bool
forall pkg.
Package pkg =>
PackageIndex pkg -> PackageIdentifier -> Bool
SourcePackageIndex.elemByPackageId (SourcePackageDb -> PackageIndex (SourcePackage UnresolvedPkgLoc)
packageIndex SourcePackageDb
sourcePkgDb))
              ([PackageIdentifier] -> [PackageIdentifier])
-> [PackageIdentifier] -> [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$ (PackageSpecifier (SourcePackage UnresolvedPkgLoc)
 -> Maybe PackageIdentifier)
-> [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
-> [PackageIdentifier]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PackageSpecifier (SourcePackage UnresolvedPkgLoc)
-> Maybe PackageIdentifier
forall pkg.
Package pkg =>
PackageSpecifier pkg -> Maybe PackageIdentifier
theSpecifiedPackage [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers

          buildReports :: [(BuildReport, Maybe Repo)]
buildReports =
            Platform
-> CompilerId
-> [PackageIdentifier]
-> FlagAssignment
-> [(BuildReport, Maybe Repo)]
BuildReports.fromPlanningFailure
              Platform
platform
              (Compiler -> CompilerId
compilerId Compiler
comp)
              [PackageIdentifier]
pkgids
              (ConfigFlags -> FlagAssignment
configConfigurationsFlags ConfigFlags
configFlags)

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(BuildReport, Maybe Repo)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(BuildReport, Maybe Repo)]
buildReports) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
          FilePath
"Solver failure will be reported for "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"," ((PackageIdentifier -> FilePath)
-> [PackageIdentifier] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow [PackageIdentifier]
pkgids)

      -- Save reports
      CompilerInfo
-> [PathTemplate]
-> [(BuildReport, Maybe Repo)]
-> Platform
-> IO ()
BuildReports.storeLocal
        (Compiler -> CompilerInfo
compilerInfo Compiler
comp)
        (NubList PathTemplate -> [PathTemplate]
forall a. NubList a -> [a]
fromNubList (NubList PathTemplate -> [PathTemplate])
-> NubList PathTemplate -> [PathTemplate]
forall a b. (a -> b) -> a -> b
$ InstallFlags -> NubList PathTemplate
installSummaryFile InstallFlags
installFlags)
        [(BuildReport, Maybe Repo)]
buildReports
        Platform
platform

      -- Save solver log
      case Maybe PathTemplate
logFile of
        Maybe PathTemplate
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just PathTemplate
template -> [PackageIdentifier] -> (PackageIdentifier -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [PackageIdentifier]
pkgids ((PackageIdentifier -> IO ()) -> IO ())
-> (PackageIdentifier -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PackageIdentifier
pkgid ->
          let env :: PathTemplateEnv
env =
                PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv
                  PackageIdentifier
pkgid
                  UnitId
forall {a}. a
dummyIpid
                  (Compiler -> CompilerInfo
compilerInfo Compiler
comp)
                  Platform
platform
              path :: FilePath
path = PathTemplate -> FilePath
fromPathTemplate (PathTemplate -> FilePath) -> PathTemplate -> FilePath
forall a b. (a -> b) -> a -> b
$ PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate PathTemplateEnv
env PathTemplate
template
           in FilePath -> FilePath -> IO ()
writeFile FilePath
path FilePath
message
    where
      reportFailure :: Bool
reportFailure = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installReportPlanningFailure InstallFlags
installFlags)
      logFile :: Maybe PathTemplate
logFile = Flag PathTemplate -> Maybe PathTemplate
forall a. Flag a -> Maybe a
flagToMaybe (InstallFlags -> Flag PathTemplate
installLogFile InstallFlags
installFlags)

      -- A IPID is calculated from the transitive closure of
      -- dependencies, but when the solver fails we don't have that.
      -- So we fail.
      dummyIpid :: a
dummyIpid = FilePath -> a
forall a. HasCallStack => FilePath -> a
error FilePath
"reportPlanningFailure: installed package ID not available"

-- | If a 'PackageSpecifier' refers to a single package, return Just that
-- package.
theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId
theSpecifiedPackage :: forall pkg.
Package pkg =>
PackageSpecifier pkg -> Maybe PackageIdentifier
theSpecifiedPackage PackageSpecifier pkg
pkgSpec =
  case PackageSpecifier pkg
pkgSpec of
    NamedPackage PackageName
name [PackagePropertyVersion VersionRange
version] ->
      PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name (Version -> PackageIdentifier)
-> Maybe Version -> Maybe PackageIdentifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VersionRange -> Maybe Version
trivialRange VersionRange
version
    NamedPackage PackageName
_ [PackageProperty]
_ -> Maybe PackageIdentifier
forall a. Maybe a
Nothing
    SpecificSourcePackage pkg
pkg -> PackageIdentifier -> Maybe PackageIdentifier
forall a. a -> Maybe a
Just (PackageIdentifier -> Maybe PackageIdentifier)
-> PackageIdentifier -> Maybe PackageIdentifier
forall a b. (a -> b) -> a -> b
$ pkg -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId pkg
pkg
  where
    -- \| If a range includes only a single version, return Just that version.
    trivialRange :: VersionRange -> Maybe Version
    trivialRange :: VersionRange -> Maybe Version
trivialRange =
      Maybe Version
-> (Version -> Maybe Version)
-> (Version -> Maybe Version)
-> (Version -> Maybe Version)
-> (Maybe Version -> Maybe Version -> Maybe Version)
-> (Maybe Version -> Maybe Version -> Maybe Version)
-> VersionRange
-> Maybe Version
forall a.
a
-> (Version -> a)
-> (Version -> a)
-> (Version -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> VersionRange
-> a
foldVersionRange
        Maybe Version
forall a. Maybe a
Nothing
        Version -> Maybe Version
forall a. a -> Maybe a
Just -- "== v"
        (\Version
_ -> Maybe Version
forall a. Maybe a
Nothing)
        (\Version
_ -> Maybe Version
forall a. Maybe a
Nothing)
        (\Maybe Version
_ Maybe Version
_ -> Maybe Version
forall a. Maybe a
Nothing)
        (\Maybe Version
_ Maybe Version
_ -> Maybe Version
forall a. Maybe a
Nothing)

-- | Various stuff we do after successful or unsuccessfully installing a bunch
-- of packages. This includes:
--
--  * build reporting, local and remote
--  * symlinking binaries
--  * updating indexes
--  * error reporting
postInstallActions
  :: Verbosity
  -> InstallArgs
  -> [UserTarget]
  -> InstallPlan
  -> BuildOutcomes
  -> IO ()
postInstallActions :: Verbosity
-> InstallArgs
-> [UserTarget]
-> InstallPlan
-> BuildOutcomes
-> IO ()
postInstallActions
  Verbosity
verbosity
  ( PackageDBStackCWD
packageDBs
    , RepoContext
_
    , Compiler
comp
    , Platform
platform
    , ProgramDb
progdb
    , GlobalFlags
globalFlags
    , ConfigFlags
configFlags
    , ConfigExFlags
_
    , InstallFlags
installFlags
    , HaddockFlags
_
    , TestFlags
_
    , BenchmarkFlags
_
    )
  [UserTarget]
_
  InstallPlan
installPlan
  BuildOutcomes
buildOutcomes = do
    let buildReports :: [(BuildReport, Maybe Repo)]
buildReports =
          Platform
-> CompilerId
-> InstallPlan
-> BuildOutcomes
-> [(BuildReport, Maybe Repo)]
BuildReports.fromInstallPlan
            Platform
platform
            (Compiler -> CompilerId
compilerId Compiler
comp)
            InstallPlan
installPlan
            BuildOutcomes
buildOutcomes
    CompilerInfo
-> [PathTemplate]
-> [(BuildReport, Maybe Repo)]
-> Platform
-> IO ()
BuildReports.storeLocal
      (Compiler -> CompilerInfo
compilerInfo Compiler
comp)
      (NubList PathTemplate -> [PathTemplate]
forall a. NubList a -> [a]
fromNubList (NubList PathTemplate -> [PathTemplate])
-> NubList PathTemplate -> [PathTemplate]
forall a b. (a -> b) -> a -> b
$ InstallFlags -> NubList PathTemplate
installSummaryFile InstallFlags
installFlags)
      [(BuildReport, Maybe Repo)]
buildReports
      Platform
platform
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReportLevel
reportingLevel ReportLevel -> ReportLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= ReportLevel
AnonymousReports) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      [(BuildReport, Maybe Repo)] -> IO ()
BuildReports.storeAnonymous [(BuildReport, Maybe Repo)]
buildReports
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReportLevel
reportingLevel ReportLevel -> ReportLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ReportLevel
DetailedReports) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity -> FilePath -> [(BuildReport, Maybe Repo)] -> IO ()
storeDetailedBuildReports Verbosity
verbosity FilePath
logsDir [(BuildReport, Maybe Repo)]
buildReports

    Verbosity
-> PackageDBStackCWD
-> Compiler
-> Platform
-> ProgramDb
-> ConfigFlags
-> InstallFlags
-> BuildOutcomes
-> IO ()
regenerateHaddockIndex
      Verbosity
verbosity
      PackageDBStackCWD
packageDBs
      Compiler
comp
      Platform
platform
      ProgramDb
progdb
      ConfigFlags
configFlags
      InstallFlags
installFlags
      BuildOutcomes
buildOutcomes

    Verbosity
-> Platform
-> Compiler
-> ConfigFlags
-> InstallFlags
-> InstallPlan
-> BuildOutcomes
-> IO ()
symlinkBinaries
      Verbosity
verbosity
      Platform
platform
      Compiler
comp
      ConfigFlags
configFlags
      InstallFlags
installFlags
      InstallPlan
installPlan
      BuildOutcomes
buildOutcomes

    Verbosity -> BuildOutcomes -> IO ()
printBuildFailures Verbosity
verbosity BuildOutcomes
buildOutcomes
    where
      reportingLevel :: ReportLevel
reportingLevel = Flag ReportLevel -> ReportLevel
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag ReportLevel
installBuildReports InstallFlags
installFlags)
      logsDir :: FilePath
logsDir = Flag FilePath -> FilePath
forall a. WithCallStack (Flag a -> a)
fromFlag (GlobalFlags -> Flag FilePath
globalLogsDir GlobalFlags
globalFlags)

storeDetailedBuildReports
  :: Verbosity
  -> FilePath
  -> [(BuildReports.BuildReport, Maybe Repo)]
  -> IO ()
storeDetailedBuildReports :: Verbosity -> FilePath -> [(BuildReport, Maybe Repo)] -> IO ()
storeDetailedBuildReports Verbosity
verbosity FilePath
logsDir [(BuildReport, Maybe Repo)]
reports =
  [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
    [ do
      FilePath
allReportsDir <- IO FilePath
defaultReportsDir
      let logFileName :: FilePath
logFileName = PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (BuildReport -> PackageIdentifier
BuildReports.package BuildReport
report) FilePath -> FilePath -> FilePath
<.> FilePath
"log"
          logFile :: FilePath
logFile = FilePath
logsDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
logFileName
          reportsDir :: FilePath
reportsDir = FilePath
allReportsDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> RepoName -> FilePath
unRepoName (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
remoteRepo)
          reportFile :: FilePath
reportFile = FilePath
reportsDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
logFileName

      IO () -> IO ()
handleMissingLogFile (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        FilePath
buildLog <- FilePath -> IO FilePath
readFile FilePath
logFile
        Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
reportsDir -- FIXME
        FilePath -> FilePath -> IO ()
writeFile FilePath
reportFile ((FilePath, FilePath) -> FilePath
forall a. Show a => a -> FilePath
show (BuildReport -> FilePath
showBuildReport BuildReport
report, FilePath
buildLog))
    | (BuildReport
report, Just Repo
repo) <- [(BuildReport, Maybe Repo)]
reports
    , Just RemoteRepo
remoteRepo <- [Repo -> Maybe RemoteRepo
maybeRepoRemote Repo
repo]
    , InstallOutcome -> Bool
isLikelyToHaveLogFile (BuildReport -> InstallOutcome
BuildReports.installOutcome BuildReport
report)
    ]
  where
    isLikelyToHaveLogFile :: InstallOutcome -> Bool
isLikelyToHaveLogFile BuildReports.ConfigureFailed{} = Bool
True
    isLikelyToHaveLogFile BuildReports.BuildFailed{} = Bool
True
    isLikelyToHaveLogFile BuildReports.InstallFailed{} = Bool
True
    isLikelyToHaveLogFile BuildReports.InstallOk{} = Bool
True
    isLikelyToHaveLogFile InstallOutcome
_ = Bool
False

    handleMissingLogFile :: IO () -> IO ()
handleMissingLogFile = (IOException -> Maybe IOException)
-> (IOException -> IO ()) -> IO () -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
Exception.handleJust IOException -> Maybe IOException
missingFile ((IOException -> IO ()) -> IO () -> IO ())
-> (IOException -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ \IOException
ioe ->
      Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath
"Missing log file for build report: "
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"" (IOException -> Maybe FilePath
ioeGetFileName IOException
ioe)

    missingFile :: IOException -> Maybe IOException
missingFile IOException
ioe
      | IOException -> Bool
isDoesNotExistError IOException
ioe = IOException -> Maybe IOException
forall a. a -> Maybe a
Just IOException
ioe
    missingFile IOException
_ = Maybe IOException
forall a. Maybe a
Nothing

regenerateHaddockIndex
  :: Verbosity
  -> [PackageDBCWD]
  -> Compiler
  -> Platform
  -> ProgramDb
  -> ConfigFlags
  -> InstallFlags
  -> BuildOutcomes
  -> IO ()
regenerateHaddockIndex :: Verbosity
-> PackageDBStackCWD
-> Compiler
-> Platform
-> ProgramDb
-> ConfigFlags
-> InstallFlags
-> BuildOutcomes
-> IO ()
regenerateHaddockIndex
  Verbosity
verbosity
  PackageDBStackCWD
packageDBs
  Compiler
comp
  Platform
platform
  ProgramDb
progdb
  ConfigFlags
configFlags
  InstallFlags
installFlags
  BuildOutcomes
buildOutcomes
    | Bool
haddockIndexFileIsRequested Bool -> Bool -> Bool
&& Bool
shouldRegenerateHaddockIndex = do
        InstallDirTemplates
defaultDirs <-
          CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
InstallDirs.defaultInstallDirs
            (Compiler -> CompilerFlavor
compilerFlavor Compiler
comp)
            (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags))
            Bool
True
        let indexFileTemplate :: PathTemplate
indexFileTemplate = Flag PathTemplate -> PathTemplate
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag PathTemplate
installHaddockIndex InstallFlags
installFlags)
            indexFile :: FilePath
indexFile = InstallDirTemplates -> PathTemplate -> FilePath
substHaddockIndexFileName InstallDirTemplates
defaultDirs PathTemplate
indexFileTemplate

        Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
          FilePath
"Updating documentation index " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
indexFile

        -- TODO: might be nice if the install plan gave us the new InstalledPackageInfo
        InstalledPackageIndex
installedPkgIndex <- Verbosity
-> Compiler
-> PackageDBStackCWD
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
comp PackageDBStackCWD
packageDBs ProgramDb
progdb
        Verbosity
-> InstalledPackageIndex -> ProgramDb -> FilePath -> IO ()
Haddock.regenerateHaddockIndex Verbosity
verbosity InstalledPackageIndex
installedPkgIndex ProgramDb
progdb FilePath
indexFile
    | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    where
      haddockIndexFileIsRequested :: Bool
haddockIndexFileIsRequested =
        Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installDocumentation InstallFlags
installFlags)
          Bool -> Bool -> Bool
&& Maybe PathTemplate -> Bool
forall a. Maybe a -> Bool
isJust (Flag PathTemplate -> Maybe PathTemplate
forall a. Flag a -> Maybe a
flagToMaybe (InstallFlags -> Flag PathTemplate
installHaddockIndex InstallFlags
installFlags))

      -- We want to regenerate the index if some new documentation was actually
      -- installed. Since the index can be only per-user or per-sandbox (see
      -- #1337), we don't do it for global installs or special cases where we're
      -- installing into a specific db.
      shouldRegenerateHaddockIndex :: Bool
shouldRegenerateHaddockIndex = Bool
normalUserInstall Bool -> Bool -> Bool
&& BuildOutcomes -> Bool
forall {k} {a}. Map k (Either a BuildResult) -> Bool
someDocsWereInstalled BuildOutcomes
buildOutcomes
        where
          someDocsWereInstalled :: Map k (Either a BuildResult) -> Bool
someDocsWereInstalled = (Either a BuildResult -> Bool) -> [Either a BuildResult] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either a BuildResult -> Bool
forall {a}. Either a BuildResult -> Bool
installedDocs ([Either a BuildResult] -> Bool)
-> (Map k (Either a BuildResult) -> [Either a BuildResult])
-> Map k (Either a BuildResult)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k (Either a BuildResult) -> [Either a BuildResult]
forall k a. Map k a -> [a]
Map.elems
          installedDocs :: Either a BuildResult -> Bool
installedDocs (Right (BuildResult DocsResult
DocsOk TestsResult
_ Maybe InstalledPackageInfo
_)) = Bool
True
          installedDocs Either a BuildResult
_ = Bool
False

          normalUserInstall :: Bool
normalUserInstall =
            (PackageDBX FilePath
forall fp. PackageDBX fp
UserPackageDB PackageDBX FilePath -> PackageDBStackCWD -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` PackageDBStackCWD
packageDBs)
              Bool -> Bool -> Bool
&& (PackageDBX FilePath -> Bool) -> PackageDBStackCWD -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool)
-> (PackageDBX FilePath -> Bool) -> PackageDBX FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDBX FilePath -> Bool
forall {fp}. PackageDBX fp -> Bool
isSpecificPackageDB) PackageDBStackCWD
packageDBs
          isSpecificPackageDB :: PackageDBX fp -> Bool
isSpecificPackageDB (SpecificPackageDB fp
_) = Bool
True
          isSpecificPackageDB PackageDBX fp
_ = Bool
False

      substHaddockIndexFileName :: InstallDirTemplates -> PathTemplate -> FilePath
substHaddockIndexFileName InstallDirTemplates
defaultDirs =
        PathTemplate -> FilePath
fromPathTemplate
          (PathTemplate -> FilePath)
-> (PathTemplate -> PathTemplate) -> PathTemplate -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate PathTemplateEnv
env
        where
          env :: PathTemplateEnv
env = PathTemplateEnv
env0 PathTemplateEnv -> PathTemplateEnv -> PathTemplateEnv
forall a. [a] -> [a] -> [a]
++ InstallDirTemplates -> PathTemplateEnv
installDirsTemplateEnv InstallDirTemplates
absoluteDirs
          env0 :: PathTemplateEnv
env0 =
            CompilerInfo -> PathTemplateEnv
InstallDirs.compilerTemplateEnv (Compiler -> CompilerInfo
compilerInfo Compiler
comp)
              PathTemplateEnv -> PathTemplateEnv -> PathTemplateEnv
forall a. [a] -> [a] -> [a]
++ Platform -> PathTemplateEnv
InstallDirs.platformTemplateEnv Platform
platform
              PathTemplateEnv -> PathTemplateEnv -> PathTemplateEnv
forall a. [a] -> [a] -> [a]
++ CompilerInfo -> Platform -> PathTemplateEnv
InstallDirs.abiTemplateEnv (Compiler -> CompilerInfo
compilerInfo Compiler
comp) Platform
platform
          absoluteDirs :: InstallDirTemplates
absoluteDirs =
            PathTemplateEnv -> InstallDirTemplates -> InstallDirTemplates
InstallDirs.substituteInstallDirTemplates
              PathTemplateEnv
env0
              InstallDirTemplates
templateDirs
          templateDirs :: InstallDirTemplates
templateDirs =
            (PathTemplate -> Flag PathTemplate -> PathTemplate)
-> InstallDirTemplates
-> InstallDirs (Flag PathTemplate)
-> InstallDirTemplates
forall a b c.
(a -> b -> c) -> InstallDirs a -> InstallDirs b -> InstallDirs c
InstallDirs.combineInstallDirs
              PathTemplate -> Flag PathTemplate -> PathTemplate
forall a. a -> Flag a -> a
fromFlagOrDefault
              InstallDirTemplates
defaultDirs
              (ConfigFlags -> InstallDirs (Flag PathTemplate)
configInstallDirs ConfigFlags
configFlags)

symlinkBinaries
  :: Verbosity
  -> Platform
  -> Compiler
  -> ConfigFlags
  -> InstallFlags
  -> InstallPlan
  -> BuildOutcomes
  -> IO ()
symlinkBinaries :: Verbosity
-> Platform
-> Compiler
-> ConfigFlags
-> InstallFlags
-> InstallPlan
-> BuildOutcomes
-> IO ()
symlinkBinaries
  Verbosity
verbosity
  Platform
platform
  Compiler
comp
  ConfigFlags
configFlags
  InstallFlags
installFlags
  InstallPlan
plan
  BuildOutcomes
buildOutcomes = do
    [(PackageIdentifier, UnqualComponentName, FilePath)]
failed <-
      Platform
-> Compiler
-> OverwritePolicy
-> ConfigFlags
-> InstallFlags
-> InstallPlan
-> BuildOutcomes
-> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
InstallSymlink.symlinkBinaries
        Platform
platform
        Compiler
comp
        OverwritePolicy
NeverOverwrite
        ConfigFlags
configFlags
        InstallFlags
installFlags
        InstallPlan
plan
        BuildOutcomes
buildOutcomes
    case [(PackageIdentifier, UnqualComponentName, FilePath)]
failed of
      [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [(PackageIdentifier
_, UnqualComponentName
exe, FilePath
path)] ->
        Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
          FilePath
"could not create a symlink in "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
bindir
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" for "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow UnqualComponentName
exe
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" because the file exists there already but is not "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"managed by cabal. You can create a symlink for this executable "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"manually if you wish. The executable file has been installed at "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path
      [(PackageIdentifier, UnqualComponentName, FilePath)]
exes ->
        Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
          FilePath
"could not create symlinks in "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
bindir
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" for "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " [UnqualComponentName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow UnqualComponentName
exe | (PackageIdentifier
_, UnqualComponentName
exe, FilePath
_) <- [(PackageIdentifier, UnqualComponentName, FilePath)]
exes]
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" because the files exist there already and are not "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"managed by cabal. You can create symlinks for these executables "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"manually if you wish. The executable files have been installed at "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " [FilePath
path | (PackageIdentifier
_, UnqualComponentName
_, FilePath
path) <- [(PackageIdentifier, UnqualComponentName, FilePath)]
exes]
    where
      bindir :: FilePath
bindir = Flag FilePath -> FilePath
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag FilePath
installSymlinkBinDir InstallFlags
installFlags)

printBuildFailures :: Verbosity -> BuildOutcomes -> IO ()
printBuildFailures :: Verbosity -> BuildOutcomes -> IO ()
printBuildFailures Verbosity
verbosity BuildOutcomes
buildOutcomes =
  case [ (UnitId
pkgid, BuildFailure
failure)
       | (UnitId
pkgid, Left BuildFailure
failure) <- BuildOutcomes -> [(UnitId, BuildOutcome)]
forall k a. Map k a -> [(k, a)]
Map.toList BuildOutcomes
buildOutcomes
       ] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [(UnitId, BuildFailure)]
failed ->
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
        [(FilePath, FilePath)] -> CabalInstallException
SomePackagesFailedToInstall ([(FilePath, FilePath)] -> CabalInstallException)
-> [(FilePath, FilePath)] -> CabalInstallException
forall a b. (a -> b) -> a -> b
$
          ((UnitId, BuildFailure) -> (FilePath, FilePath))
-> [(UnitId, BuildFailure)] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (\(UnitId
pkgid, BuildFailure
reason) -> (UnitId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow UnitId
pkgid, BuildFailure -> FilePath
printFailureReason BuildFailure
reason)) [(UnitId, BuildFailure)]
failed
  where
    printFailureReason :: BuildFailure -> FilePath
printFailureReason BuildFailure
reason = case BuildFailure
reason of
      GracefulFailure FilePath
msg -> FilePath
msg
      DependentFailed PackageIdentifier
pkgid ->
        FilePath
" depends on "
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgid
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" which failed to install."
      DownloadFailed SomeException
e ->
        FilePath
" failed while downloading the package."
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
showException SomeException
e
      UnpackFailed SomeException
e ->
        FilePath
" failed while unpacking the package."
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
showException SomeException
e
      ConfigureFailed SomeException
e ->
        FilePath
" failed during the configure step."
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
showException SomeException
e
      BuildFailed SomeException
e ->
        FilePath
" failed during the building phase."
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
showException SomeException
e
      TestsFailed SomeException
e ->
        FilePath
" failed during the tests phase."
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
showException SomeException
e
      InstallFailed SomeException
e ->
        FilePath
" failed during the final install step."
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
showException SomeException
e
      -- This will never happen, but we include it for completeness
      BuildFailure
PlanningFailed -> FilePath
" failed during the planning phase."

    showException :: SomeException -> FilePath
showException SomeException
e = FilePath
" The exception was:\n  " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
maybeOOM SomeException
e
#ifdef mingw32_HOST_OS
    maybeOOM _        = ""
#else
    maybeOOM :: SomeException -> FilePath
maybeOOM SomeException
e                    = FilePath -> (ExitCode -> FilePath) -> Maybe ExitCode -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" ExitCode -> FilePath
onExitFailure (SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e)
    onExitFailure :: ExitCode -> FilePath
onExitFailure (ExitFailure Int
n)
      | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
9 Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
9         =
      FilePath
"\nThis may be due to an out-of-memory condition."
    onExitFailure ExitCode
_               = FilePath
""
#endif

-- ------------------------------------------------------------

-- * Actually do the installations

-- ------------------------------------------------------------

data InstallMisc = InstallMisc
  { InstallMisc -> Maybe Version
libVersion :: Maybe Version
  }

-- | If logging is enabled, contains location of the log file and the verbosity
-- level for logging.
type UseLogFile = Maybe (PackageIdentifier -> UnitId -> FilePath, Verbosity)

performInstallations
  :: Verbosity
  -> InstallArgs
  -> InstalledPackageIndex
  -> InstallPlan
  -> IO BuildOutcomes
performInstallations :: Verbosity
-> InstallArgs
-> InstalledPackageIndex
-> InstallPlan
-> IO BuildOutcomes
performInstallations
  Verbosity
verbosity
  ( PackageDBStackCWD
packageDBs
    , RepoContext
repoCtxt
    , Compiler
comp
    , Platform
platform
    , ProgramDb
progdb
    , GlobalFlags
globalFlags
    , ConfigFlags
configFlags
    , ConfigExFlags
configExFlags
    , InstallFlags
installFlags
    , HaddockFlags
haddockFlags
    , TestFlags
testFlags
    , BenchmarkFlags
_
    )
  InstalledPackageIndex
installedPkgIndex
  InstallPlan
installPlan = do
    Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Number of threads used: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
numJobs) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"."

    JobControl IO (UnitId, BuildOutcome)
jobControl <-
      if Bool
parallelInstall
        then Int -> IO (JobControl IO (UnitId, BuildOutcome))
forall a. WithCallStack (Int -> IO (JobControl IO a))
newParallelJobControl Int
numJobs
        else IO (JobControl IO (UnitId, BuildOutcome))
forall a. IO (JobControl IO a)
newSerialJobControl
    JobLimit
fetchLimit <- Int -> IO JobLimit
newJobLimit (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
numJobs Int
numFetchJobs)
    Lock
installLock <- IO Lock
newLock -- serialise installation
    Lock
cacheLock <- IO Lock
newLock -- serialise access to setup exe cache
    Verbosity
-> JobControl IO (UnitId, BuildOutcome)
-> Bool
-> UseLogFile
-> InstallPlan
-> (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
    -> IO BuildOutcome)
-> IO BuildOutcomes
executeInstallPlan
      Verbosity
verbosity
      JobControl IO (UnitId, BuildOutcome)
jobControl
      Bool
keepGoing
      UseLogFile
useLogFile
      InstallPlan
installPlan
      ((GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
  -> IO BuildOutcome)
 -> IO BuildOutcomes)
-> (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
    -> IO BuildOutcome)
-> IO BuildOutcomes
forall a b. (a -> b) -> a -> b
$ \GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg ->
        Platform
-> CompilerInfo
-> ConfigFlags
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> (ConfigFlags
    -> UnresolvedPkgLoc
    -> PackageDescription
    -> PackageDescriptionOverride
    -> IO BuildOutcome)
-> IO BuildOutcome
forall a.
Platform
-> CompilerInfo
-> ConfigFlags
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> (ConfigFlags
    -> UnresolvedPkgLoc
    -> PackageDescription
    -> PackageDescriptionOverride
    -> a)
-> a
installReadyPackage
          Platform
platform
          CompilerInfo
cinfo
          ConfigFlags
configFlags
          GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg
          ((ConfigFlags
  -> UnresolvedPkgLoc
  -> PackageDescription
  -> PackageDescriptionOverride
  -> IO BuildOutcome)
 -> IO BuildOutcome)
-> (ConfigFlags
    -> UnresolvedPkgLoc
    -> PackageDescription
    -> PackageDescriptionOverride
    -> IO BuildOutcome)
-> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ \ConfigFlags
configFlags' UnresolvedPkgLoc
src PackageDescription
pkg PackageDescriptionOverride
pkgoverride ->
            Verbosity
-> RepoContext
-> JobLimit
-> UnresolvedPkgLoc
-> (ResolvedPkgLoc -> IO BuildOutcome)
-> IO BuildOutcome
fetchSourcePackage Verbosity
verbosity RepoContext
repoCtxt JobLimit
fetchLimit UnresolvedPkgLoc
src ((ResolvedPkgLoc -> IO BuildOutcome) -> IO BuildOutcome)
-> (ResolvedPkgLoc -> IO BuildOutcome) -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ \ResolvedPkgLoc
src' ->
              Verbosity
-> PackageIdentifier
-> ResolvedPkgLoc
-> SymbolicPath Pkg ('Dir Dist)
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
installLocalPackage Verbosity
verbosity (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg) ResolvedPkgLoc
src' SymbolicPath Pkg ('Dir Dist)
distPref ((Maybe FilePath -> IO BuildOutcome) -> IO BuildOutcome)
-> (Maybe FilePath -> IO BuildOutcome) -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ \Maybe FilePath
mpath ->
                Verbosity
-> Lock
-> Int
-> SetupScriptOptions
-> ConfigFlags
-> InstallFlags
-> HaddockFlags
-> TestFlags
-> Compiler
-> ProgramDb
-> Platform
-> PackageDescription
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> PackageDescriptionOverride
-> Maybe FilePath
-> UseLogFile
-> IO BuildOutcome
installUnpackedPackage
                  Verbosity
verbosity
                  Lock
installLock
                  Int
numJobs
                  ( InstalledPackageIndex
-> Lock
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> SetupScriptOptions
setupScriptOptions
                      InstalledPackageIndex
installedPkgIndex
                      Lock
cacheLock
                      GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg
                  )
                  ConfigFlags
configFlags'
                  InstallFlags
installFlags
                  HaddockFlags
haddockFlags
                  TestFlags
testFlags
                  Compiler
comp
                  ProgramDb
progdb
                  Platform
platform
                  PackageDescription
pkg
                  GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg
                  PackageDescriptionOverride
pkgoverride
                  Maybe FilePath
mpath
                  UseLogFile
useLogFile
    where
      cinfo :: CompilerInfo
cinfo = Compiler -> CompilerInfo
compilerInfo Compiler
comp

      numJobs :: Int
numJobs = Flag (Maybe Int) -> Int
determineNumJobs (InstallFlags -> Flag (Maybe Int)
installNumJobs InstallFlags
installFlags)
      numFetchJobs :: Int
numFetchJobs = Int
2
      parallelInstall :: Bool
parallelInstall = Int
numJobs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
      keepGoing :: Bool
keepGoing = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installKeepGoing InstallFlags
installFlags)
      distPref :: SymbolicPath Pkg ('Dir Dist)
distPref =
        SymbolicPath Pkg ('Dir Dist)
-> Flag (SymbolicPath Pkg ('Dir Dist))
-> SymbolicPath Pkg ('Dir Dist)
forall a. a -> Flag a -> a
fromFlagOrDefault
          (SetupScriptOptions -> SymbolicPath Pkg ('Dir Dist)
useDistPref SetupScriptOptions
defaultSetupScriptOptions)
          (CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
setupDistPref (CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist)))
-> CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
configFlags)

      setupScriptOptions :: InstalledPackageIndex
-> Lock
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> SetupScriptOptions
setupScriptOptions InstalledPackageIndex
index Lock
lock GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg =
        PackageDBStackCWD
-> Compiler
-> Platform
-> ProgramDb
-> SymbolicPath Pkg ('Dir Dist)
-> VersionRange
-> Maybe Lock
-> Bool
-> InstalledPackageIndex
-> Maybe (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc))
-> SetupScriptOptions
configureSetupScript
          PackageDBStackCWD
packageDBs
          Compiler
comp
          Platform
platform
          ProgramDb
progdb
          SymbolicPath Pkg ('Dir Dist)
distPref
          (ConfigExFlags -> Maybe Version -> VersionRange
chooseCabalVersion ConfigExFlags
configExFlags (InstallMisc -> Maybe Version
libVersion InstallMisc
miscOptions))
          (Lock -> Maybe Lock
forall a. a -> Maybe a
Just Lock
lock)
          Bool
parallelInstall
          InstalledPackageIndex
index
          (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> Maybe (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc))
forall a. a -> Maybe a
Just GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg)

      reportingLevel :: ReportLevel
reportingLevel = Flag ReportLevel -> ReportLevel
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag ReportLevel
installBuildReports InstallFlags
installFlags)
      logsDir :: FilePath
logsDir = Flag FilePath -> FilePath
forall a. WithCallStack (Flag a -> a)
fromFlag (GlobalFlags -> Flag FilePath
globalLogsDir GlobalFlags
globalFlags)

      -- Should the build output be written to a log file instead of stdout?
      useLogFile :: UseLogFile
      useLogFile :: UseLogFile
useLogFile =
        (PathTemplate
 -> (PackageIdentifier -> UnitId -> FilePath, Verbosity))
-> Maybe PathTemplate -> UseLogFile
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
          ((\PackageIdentifier -> UnitId -> FilePath
f -> (PackageIdentifier -> UnitId -> FilePath
f, Verbosity
loggingVerbosity)) ((PackageIdentifier -> UnitId -> FilePath)
 -> (PackageIdentifier -> UnitId -> FilePath, Verbosity))
-> (PathTemplate -> PackageIdentifier -> UnitId -> FilePath)
-> PathTemplate
-> (PackageIdentifier -> UnitId -> FilePath, Verbosity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplate -> PackageIdentifier -> UnitId -> FilePath
substLogFileName)
          Maybe PathTemplate
logFileTemplate
        where
          installLogFile' :: Maybe PathTemplate
installLogFile' = Flag PathTemplate -> Maybe PathTemplate
forall a. Flag a -> Maybe a
flagToMaybe (Flag PathTemplate -> Maybe PathTemplate)
-> Flag PathTemplate -> Maybe PathTemplate
forall a b. (a -> b) -> a -> b
$ InstallFlags -> Flag PathTemplate
installLogFile InstallFlags
installFlags
          defaultTemplate :: PathTemplate
defaultTemplate =
            FilePath -> PathTemplate
toPathTemplate (FilePath -> PathTemplate) -> FilePath -> PathTemplate
forall a b. (a -> b) -> a -> b
$
              FilePath
logsDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
"$compiler" FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
"$libname" FilePath -> FilePath -> FilePath
<.> FilePath
"log"

          -- If the user has specified --remote-build-reporting=detailed, use the
          -- default log file location. If the --build-log option is set, use the
          -- provided location. Otherwise don't use logging, unless building in
          -- parallel (in which case the default location is used).
          logFileTemplate :: Maybe PathTemplate
          logFileTemplate :: Maybe PathTemplate
logFileTemplate
            | Bool
useDefaultTemplate = PathTemplate -> Maybe PathTemplate
forall a. a -> Maybe a
Just PathTemplate
defaultTemplate
            | Bool
otherwise = Maybe PathTemplate
installLogFile'

          -- If the user has specified --remote-build-reporting=detailed or
          -- --build-log, use more verbose logging.
          loggingVerbosity :: Verbosity
          loggingVerbosity :: Verbosity
loggingVerbosity
            | Bool
overrideVerbosity = (Verbosity -> Verbosity) -> Verbosity -> Verbosity
modifyVerbosity (Verbosity -> Verbosity -> Verbosity
forall a. Ord a => a -> a -> a
max Verbosity
verbose) Verbosity
verbosity
            | Bool
otherwise = Verbosity
verbosity

          useDefaultTemplate :: Bool
          useDefaultTemplate :: Bool
useDefaultTemplate
            | ReportLevel
reportingLevel ReportLevel -> ReportLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ReportLevel
DetailedReports = Bool
True
            | Maybe PathTemplate -> Bool
forall a. Maybe a -> Bool
isJust Maybe PathTemplate
installLogFile' = Bool
False
            | Bool
parallelInstall = Bool
True
            | Bool
otherwise = Bool
False

          overrideVerbosity :: Bool
          overrideVerbosity :: Bool
overrideVerbosity
            | ReportLevel
reportingLevel ReportLevel -> ReportLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ReportLevel
DetailedReports = Bool
True
            | Maybe PathTemplate -> Bool
forall a. Maybe a -> Bool
isJust Maybe PathTemplate
installLogFile' = Bool
True
            | Bool
parallelInstall = Bool
False
            | Bool
otherwise = Bool
False

      substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath
      substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath
substLogFileName PathTemplate
template PackageIdentifier
pkg UnitId
uid =
        PathTemplate -> FilePath
fromPathTemplate
          (PathTemplate -> FilePath)
-> (PathTemplate -> PathTemplate) -> PathTemplate -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate PathTemplateEnv
env
          (PathTemplate -> FilePath) -> PathTemplate -> FilePath
forall a b. (a -> b) -> a -> b
$ PathTemplate
template
        where
          env :: PathTemplateEnv
env =
            PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv
              (PackageIdentifier -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageIdentifier
pkg)
              UnitId
uid
              (Compiler -> CompilerInfo
compilerInfo Compiler
comp)
              Platform
platform

      miscOptions :: InstallMisc
miscOptions =
        InstallMisc
          { libVersion :: Maybe Version
libVersion = Flag Version -> Maybe Version
forall a. Flag a -> Maybe a
flagToMaybe (ConfigExFlags -> Flag Version
configCabalVersion ConfigExFlags
configExFlags)
          }

executeInstallPlan
  :: Verbosity
  -> JobControl IO (UnitId, BuildOutcome)
  -> Bool
  -> UseLogFile
  -> InstallPlan
  -> (ReadyPackage -> IO BuildOutcome)
  -> IO BuildOutcomes
executeInstallPlan :: Verbosity
-> JobControl IO (UnitId, BuildOutcome)
-> Bool
-> UseLogFile
-> InstallPlan
-> (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
    -> IO BuildOutcome)
-> IO BuildOutcomes
executeInstallPlan Verbosity
verbosity JobControl IO (UnitId, BuildOutcome)
jobCtl Bool
keepGoing UseLogFile
useLogFile InstallPlan
plan0 GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> IO BuildOutcome
installPkg =
  JobControl IO (UnitId, BuildOutcome)
-> Bool
-> (ConfiguredPackage UnresolvedPkgLoc -> BuildFailure)
-> InstallPlan
-> (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
    -> IO BuildOutcome)
-> IO BuildOutcomes
forall (m :: * -> *) ipkg srcpkg result failure.
(IsUnit ipkg, IsUnit srcpkg, Monad m) =>
JobControl m (UnitId, Either failure result)
-> Bool
-> (srcpkg -> failure)
-> GenericInstallPlan ipkg srcpkg
-> (GenericReadyPackage srcpkg -> m (Either failure result))
-> m (BuildOutcomes failure result)
InstallPlan.execute
    JobControl IO (UnitId, BuildOutcome)
jobCtl
    Bool
keepGoing
    ConfiguredPackage UnresolvedPkgLoc -> BuildFailure
depsFailure
    InstallPlan
plan0
    ((GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
  -> IO BuildOutcome)
 -> IO BuildOutcomes)
-> (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
    -> IO BuildOutcome)
-> IO BuildOutcomes
forall a b. (a -> b) -> a -> b
$ \GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
pkg -> do
      BuildOutcome
buildOutcome <- GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> IO BuildOutcome
installPkg GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
pkg
      PackageIdentifier -> UnitId -> BuildOutcome -> IO ()
printBuildResult (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
pkg) (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc) -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
pkg) BuildOutcome
buildOutcome
      BuildOutcome -> IO BuildOutcome
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BuildOutcome
buildOutcome
  where
    depsFailure :: ConfiguredPackage UnresolvedPkgLoc -> BuildFailure
depsFailure = PackageIdentifier -> BuildFailure
DependentFailed (PackageIdentifier -> BuildFailure)
-> (ConfiguredPackage UnresolvedPkgLoc -> PackageIdentifier)
-> ConfiguredPackage UnresolvedPkgLoc
-> BuildFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfiguredPackage UnresolvedPkgLoc -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId

    -- Print build log if something went wrong, and 'Installed $PKGID'
    -- otherwise.
    printBuildResult :: PackageId -> UnitId -> BuildOutcome -> IO ()
    printBuildResult :: PackageIdentifier -> UnitId -> BuildOutcome -> IO ()
printBuildResult PackageIdentifier
pkgid UnitId
uid BuildOutcome
buildOutcome = case BuildOutcome
buildOutcome of
      (Right BuildResult
_) -> Verbosity -> ProgressPhase -> FilePath -> IO ()
progressMessage Verbosity
verbosity ProgressPhase
ProgressCompleted (PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgid)
      (Left BuildFailure
_) -> do
        Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to install " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgid
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          case UseLogFile
useLogFile of
            UseLogFile
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just (PackageIdentifier -> UnitId -> FilePath
mkLogFileName, Verbosity
_) -> do
              let logName :: FilePath
logName = PackageIdentifier -> UnitId -> FilePath
mkLogFileName PackageIdentifier
pkgid UnitId
uid
              FilePath -> IO ()
putStr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Build log ( " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
logName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" ):\n"
              FilePath -> IO ()
printFile FilePath
logName

    printFile :: FilePath -> IO ()
    printFile :: FilePath -> IO ()
printFile FilePath
path = FilePath -> IO FilePath
readFile FilePath
path IO FilePath -> (FilePath -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> IO ()
putStr

-- | Call an installer for an 'SourcePackage' but override the configure
-- flags with the ones given by the 'ReadyPackage'. In particular the
-- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly
-- versioned package dependencies. So we ignore any previous partial flag
-- assignment or dependency constraints and use the new ones.
--
-- NB: when updating this function, don't forget to also update
-- 'configurePackage' in D.C.Configure.
installReadyPackage
  :: Platform
  -> CompilerInfo
  -> ConfigFlags
  -> ReadyPackage
  -> ( ConfigFlags
       -> UnresolvedPkgLoc
       -> PackageDescription
       -> PackageDescriptionOverride
       -> a
     )
  -> a
installReadyPackage :: forall a.
Platform
-> CompilerInfo
-> ConfigFlags
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> (ConfigFlags
    -> UnresolvedPkgLoc
    -> PackageDescription
    -> PackageDescriptionOverride
    -> a)
-> a
installReadyPackage
  Platform
platform
  CompilerInfo
cinfo
  ConfigFlags
configFlags
  ( ReadyPackage
      ( ConfiguredPackage
          ComponentId
ipid
          (SourcePackage PackageIdentifier
_ GenericPackageDescription
gpkg UnresolvedPkgLoc
source PackageDescriptionOverride
pkgoverride)
          FlagAssignment
flags
          OptionalStanzaSet
stanzas
          ComponentDeps [ConfiguredId]
deps
        )
    )
  ConfigFlags
-> UnresolvedPkgLoc
-> PackageDescription
-> PackageDescriptionOverride
-> a
installPkg =
    ConfigFlags
-> UnresolvedPkgLoc
-> PackageDescription
-> PackageDescriptionOverride
-> a
installPkg
      ConfigFlags
configFlags
        { configIPID = toFlag (prettyShow ipid)
        , configConfigurationsFlags = flags
        , -- We generate the legacy constraints as well as the new style precise deps.
          -- In the end only one set gets passed to Setup.hs configure, depending on
          -- the Cabal version we are talking to.
          configConstraints =
            [ thisPackageVersionConstraint srcid
            | ConfiguredId
                srcid
                ( Just
                    ( PackageDescription.CLibName
                        PackageDescription.LMainLibName
                      )
                  )
                _ipid <-
                CD.nonSetupDeps deps
            ]
        , configDependencies =
            [ GivenComponent (packageName srcid) cname dep_ipid
            | ConfiguredId srcid (Just (PackageDescription.CLibName cname)) dep_ipid <-
                CD.nonSetupDeps deps
            ]
        , -- Use '--exact-configuration' if supported.
          configExactConfiguration = toFlag True
        , configBenchmarks = toFlag False
        , configTests = toFlag (TestStanzas `optStanzaSetMember` stanzas)
        }
      UnresolvedPkgLoc
source
      PackageDescription
pkg
      PackageDescriptionOverride
pkgoverride
    where
      pkg :: PackageDescription
pkg = case FlagAssignment
-> ComponentRequestedSpec
-> (Dependency -> Bool)
-> Platform
-> CompilerInfo
-> [PackageVersionConstraint]
-> GenericPackageDescription
-> Either [Dependency] (PackageDescription, FlagAssignment)
finalizePD
        FlagAssignment
flags
        (OptionalStanzaSet -> ComponentRequestedSpec
enableStanzas OptionalStanzaSet
stanzas)
        (Bool -> Dependency -> Bool
forall a b. a -> b -> a
const Bool
True)
        Platform
platform
        CompilerInfo
cinfo
        []
        GenericPackageDescription
gpkg of
        Left [Dependency]
_ -> FilePath -> PackageDescription
forall a. HasCallStack => FilePath -> a
error FilePath
"finalizePD ReadyPackage failed"
        Right (PackageDescription
desc, FlagAssignment
_) -> PackageDescription
desc

fetchSourcePackage
  :: Verbosity
  -> RepoContext
  -> JobLimit
  -> UnresolvedPkgLoc
  -> (ResolvedPkgLoc -> IO BuildOutcome)
  -> IO BuildOutcome
fetchSourcePackage :: Verbosity
-> RepoContext
-> JobLimit
-> UnresolvedPkgLoc
-> (ResolvedPkgLoc -> IO BuildOutcome)
-> IO BuildOutcome
fetchSourcePackage Verbosity
verbosity RepoContext
repoCtxt JobLimit
fetchLimit UnresolvedPkgLoc
src ResolvedPkgLoc -> IO BuildOutcome
installPkg = do
  Maybe ResolvedPkgLoc
fetched <- UnresolvedPkgLoc -> IO (Maybe ResolvedPkgLoc)
checkFetched UnresolvedPkgLoc
src
  case Maybe ResolvedPkgLoc
fetched of
    Just ResolvedPkgLoc
src' -> ResolvedPkgLoc -> IO BuildOutcome
installPkg ResolvedPkgLoc
src'
    Maybe ResolvedPkgLoc
Nothing -> (SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
DownloadFailed (IO BuildOutcome -> IO BuildOutcome)
-> IO BuildOutcome -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ do
      ResolvedPkgLoc
loc <-
        JobLimit -> IO ResolvedPkgLoc -> IO ResolvedPkgLoc
forall a. JobLimit -> IO a -> IO a
withJobLimit JobLimit
fetchLimit (IO ResolvedPkgLoc -> IO ResolvedPkgLoc)
-> IO ResolvedPkgLoc -> IO ResolvedPkgLoc
forall a b. (a -> b) -> a -> b
$
          Verbosity -> RepoContext -> UnresolvedPkgLoc -> IO ResolvedPkgLoc
fetchPackage Verbosity
verbosity RepoContext
repoCtxt UnresolvedPkgLoc
src
      ResolvedPkgLoc -> IO BuildOutcome
installPkg ResolvedPkgLoc
loc

installLocalPackage
  :: Verbosity
  -> PackageIdentifier
  -> ResolvedPkgLoc
  -> SymbolicPath Pkg (Dir Dist)
  -> (Maybe FilePath -> IO BuildOutcome)
  -> IO BuildOutcome
installLocalPackage :: Verbosity
-> PackageIdentifier
-> ResolvedPkgLoc
-> SymbolicPath Pkg ('Dir Dist)
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
installLocalPackage Verbosity
verbosity PackageIdentifier
pkgid ResolvedPkgLoc
location SymbolicPath Pkg ('Dir Dist)
distPref Maybe FilePath -> IO BuildOutcome
installPkg =
  case ResolvedPkgLoc
location of
    LocalUnpackedPackage FilePath
dir ->
      Maybe FilePath -> IO BuildOutcome
installPkg (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dir)
    RemoteSourceRepoPackage SourceRepoMaybe
_repo FilePath
dir ->
      Maybe FilePath -> IO BuildOutcome
installPkg (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dir)
    LocalTarballPackage FilePath
tarballPath ->
      Verbosity
-> PackageIdentifier
-> FilePath
-> SymbolicPath Pkg ('Dir Dist)
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
installLocalTarballPackage
        Verbosity
verbosity
        PackageIdentifier
pkgid
        FilePath
tarballPath
        SymbolicPath Pkg ('Dir Dist)
distPref
        Maybe FilePath -> IO BuildOutcome
installPkg
    RemoteTarballPackage URI
_ FilePath
tarballPath ->
      Verbosity
-> PackageIdentifier
-> FilePath
-> SymbolicPath Pkg ('Dir Dist)
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
installLocalTarballPackage
        Verbosity
verbosity
        PackageIdentifier
pkgid
        FilePath
tarballPath
        SymbolicPath Pkg ('Dir Dist)
distPref
        Maybe FilePath -> IO BuildOutcome
installPkg
    RepoTarballPackage Repo
_ PackageIdentifier
_ FilePath
tarballPath ->
      Verbosity
-> PackageIdentifier
-> FilePath
-> SymbolicPath Pkg ('Dir Dist)
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
installLocalTarballPackage
        Verbosity
verbosity
        PackageIdentifier
pkgid
        FilePath
tarballPath
        SymbolicPath Pkg ('Dir Dist)
distPref
        Maybe FilePath -> IO BuildOutcome
installPkg

installLocalTarballPackage
  :: Verbosity
  -> PackageIdentifier
  -> FilePath
  -> SymbolicPath Pkg (Dir Dist)
  -> (Maybe FilePath -> IO BuildOutcome)
  -> IO BuildOutcome
installLocalTarballPackage :: Verbosity
-> PackageIdentifier
-> FilePath
-> SymbolicPath Pkg ('Dir Dist)
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
installLocalTarballPackage
  Verbosity
verbosity
  PackageIdentifier
pkgid
  FilePath
tarballPath
  SymbolicPath Pkg ('Dir Dist)
distPref
  Maybe FilePath -> IO BuildOutcome
installPkg = do
    FilePath
tmp <- IO FilePath
getTemporaryDirectory
    Verbosity
-> FilePath
-> FilePath
-> (FilePath -> IO BuildOutcome)
-> IO BuildOutcome
forall a.
Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory Verbosity
verbosity FilePath
tmp FilePath
"cabal-tmp" ((FilePath -> IO BuildOutcome) -> IO BuildOutcome)
-> (FilePath -> IO BuildOutcome) -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ \FilePath
tmpDirPath ->
      (SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
UnpackFailed (IO BuildOutcome -> IO BuildOutcome)
-> IO BuildOutcome -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ do
        let relUnpackedPath :: FilePath
relUnpackedPath = PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgid
            absUnpackedPath :: FilePath
absUnpackedPath = FilePath
tmpDirPath FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
relUnpackedPath
            descFilePath :: FilePath
descFilePath =
              FilePath
absUnpackedPath
                FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgid)
                FilePath -> FilePath -> FilePath
<.> FilePath
"cabal"
        Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
          FilePath
"Extracting "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tarballPath
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" to "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tmpDirPath
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"..."
        FilePath -> FilePath -> FilePath -> IO ()
extractTarGzFile FilePath
tmpDirPath FilePath
relUnpackedPath FilePath
tarballPath
        Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
descFilePath
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
            FilePath -> CabalInstallException
PackageDotCabalFileNotFound FilePath
descFilePath
        FilePath -> IO ()
maybeRenameDistDir FilePath
absUnpackedPath
        Maybe FilePath -> IO BuildOutcome
installPkg (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
absUnpackedPath)
    where
      -- 'cabal sdist' puts pre-generated files in the 'dist'
      -- directory. This fails when a nonstandard build directory name
      -- is used (as is the case with sandboxes), so we need to rename
      -- the 'dist' dir here.
      --
      -- TODO: 'cabal get happy && cd sandbox && cabal install ../happy' still
      -- fails even with this workaround. We probably can live with that.
      maybeRenameDistDir :: FilePath -> IO ()
      maybeRenameDistDir :: FilePath -> IO ()
maybeRenameDistDir FilePath
absUnpackedPath = do
        let distDirPath :: FilePath
distDirPath = FilePath
absUnpackedPath FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> SymbolicPath Pkg ('Dir Dist) -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath SymbolicPath Pkg ('Dir Dist)
defaultDistPref
            distDirPathTmp :: FilePath
distDirPathTmp = FilePath
absUnpackedPath FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> (SymbolicPath Pkg ('Dir Dist) -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath SymbolicPath Pkg ('Dir Dist)
defaultDistPref FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-tmp")
            distDirPathNew :: FilePath
distDirPathNew = FilePath
absUnpackedPath FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> SymbolicPath Pkg ('Dir Dist) -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath SymbolicPath Pkg ('Dir Dist)
distPref
        Bool
distDirExists <- FilePath -> IO Bool
doesDirectoryExist FilePath
distDirPath
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
          ( Bool
distDirExists
              Bool -> Bool -> Bool
&& Bool -> Bool
not (FilePath
distDirPath FilePath -> FilePath -> Bool
`equalFilePath` FilePath
distDirPathNew)
          )
          (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            -- NB: we need to handle the case when 'distDirPathNew' is a
            -- subdirectory of 'distDirPath' (e.g. the former is
            -- 'dist/dist-sandbox-3688fbc2' and the latter is 'dist').
            Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
              FilePath
"Renaming '"
                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
distDirPath
                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' to '"
                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
distDirPathTmp
                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'."
            FilePath -> FilePath -> IO ()
renameDirectory FilePath
distDirPath FilePath
distDirPathTmp
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
distDirPath FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
distDirPathNew) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
False FilePath
distDirPath
            Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
              FilePath
"Renaming '"
                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
distDirPathTmp
                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' to '"
                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
distDirPathNew
                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'."
            FilePath -> FilePath -> IO ()
renameDirectory FilePath
distDirPathTmp FilePath
distDirPathNew

installUnpackedPackage
  :: Verbosity
  -> Lock
  -> Int
  -> SetupScriptOptions
  -> ConfigFlags
  -> InstallFlags
  -> HaddockFlags
  -> TestFlags
  -> Compiler
  -> ProgramDb
  -> Platform
  -> PackageDescription
  -> ReadyPackage
  -> PackageDescriptionOverride
  -> Maybe FilePath
  -- ^ Directory to change to before starting the installation.
  -> UseLogFile
  -- ^ File to log output to (if any)
  -> IO BuildOutcome
installUnpackedPackage :: Verbosity
-> Lock
-> Int
-> SetupScriptOptions
-> ConfigFlags
-> InstallFlags
-> HaddockFlags
-> TestFlags
-> Compiler
-> ProgramDb
-> Platform
-> PackageDescription
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> PackageDescriptionOverride
-> Maybe FilePath
-> UseLogFile
-> IO BuildOutcome
installUnpackedPackage
  Verbosity
verbosity
  Lock
installLock
  Int
numJobs
  SetupScriptOptions
scriptOptions
  ConfigFlags
configFlags
  InstallFlags
installFlags
  HaddockFlags
haddockFlags
  TestFlags
testFlags
  Compiler
comp
  ProgramDb
progdb
  Platform
platform
  PackageDescription
pkg
  GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg
  PackageDescriptionOverride
pkgoverride
  Maybe FilePath
workingDir
  UseLogFile
useLogFile = do
    -- Override the .cabal file if necessary
    case PackageDescriptionOverride
pkgoverride of
      PackageDescriptionOverride
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just ByteString
pkgtxt -> do
        let descFilePath :: FilePath
descFilePath =
              FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"." Maybe FilePath
workingDir
                FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgid)
                FilePath -> FilePath -> FilePath
<.> FilePath
"cabal"
        Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
          FilePath
"Updating "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgid) FilePath -> FilePath -> FilePath
<.> FilePath
"cabal"
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" with the latest revision from the index."
        FilePath -> ByteString -> IO ()
writeFileAtomic FilePath
descFilePath ByteString
pkgtxt

    let mbWorkDir :: Maybe (SymbolicPath from to)
mbWorkDir = (FilePath -> SymbolicPath from to)
-> Maybe FilePath -> Maybe (SymbolicPath from to)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> SymbolicPath from to
forall from (to :: FileOrDir). FilePath -> SymbolicPath from to
makeSymbolicPath Maybe FilePath
workingDir
        commonFlags :: Version -> CommonSetupFlags
commonFlags Version
ver =
          (CommonSetupFlags -> Version -> CommonSetupFlags
`filterCommonFlags` Version
ver) (CommonSetupFlags -> CommonSetupFlags)
-> CommonSetupFlags -> CommonSetupFlags
forall a b. (a -> b) -> a -> b
$
            CommonSetupFlags
defaultCommonSetupFlags
              { setupDistPref = setupDistPref $ configCommonFlags configFlags
              , setupVerbosity = toFlag verbosity'
              , setupWorkingDir = maybeToFlag mbWorkDir
              }

    -- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if
    -- the setup script was compiled against an old version of the Cabal lib).
    ConfigFlags
configFlags' <- ConfigFlags -> IO ConfigFlags
addDefaultInstallDirs ConfigFlags
configFlags
    -- Filter out flags not supported by the old versions of the Cabal lib.
    let configureFlags :: Version -> ConfigFlags
        configureFlags :: Version -> ConfigFlags
configureFlags =
          ConfigFlags -> Version -> ConfigFlags
filterConfigureFlags
            ConfigFlags
configFlags'
              { configCommonFlags =
                  (configCommonFlags (configFlags'))
                    { setupVerbosity = toFlag verbosity'
                    }
              }

        buildFlags :: Version -> BuildFlags
buildFlags Version
vers =
          BuildFlags
emptyBuildFlags{buildCommonFlags = commonFlags vers}
        shouldHaddock :: Bool
shouldHaddock = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installDocumentation InstallFlags
installFlags)
        haddockFlags' :: Version -> HaddockFlags
haddockFlags' Version
vers =
          HaddockFlags
haddockFlags{haddockCommonFlags = commonFlags vers}
        testsEnabled :: Bool
testsEnabled =
          Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Bool
configTests ConfigFlags
configFlags)
            Bool -> Bool -> Bool
&& Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (InstallFlags -> Flag Bool
installRunTests InstallFlags
installFlags)
        testFlags' :: Version -> TestFlags
testFlags' Version
vers =
          (TestFlags -> Version -> TestFlags
`filterTestFlags` Version
vers) (TestFlags -> TestFlags) -> TestFlags -> TestFlags
forall a b. (a -> b) -> a -> b
$
            TestFlags
testFlags{testCommonFlags = commonFlags vers}
        copyFlags :: Version -> CopyFlags
copyFlags Version
vers =
          CopyFlags
Cabal.emptyCopyFlags
            { Cabal.copyDest = toFlag InstallDirs.NoCopyDest
            , copyCommonFlags = commonFlags vers
            }
        shouldRegister :: Bool
shouldRegister = PackageDescription -> Bool
PackageDescription.hasLibs PackageDescription
pkg
        registerFlags :: Version -> RegisterFlags
registerFlags Version
vers =
          RegisterFlags
Cabal.emptyRegisterFlags
            { registerCommonFlags = commonFlags vers
            }

    -- Path to the optional log file.
    Maybe FilePath
mLogPath <- IO (Maybe FilePath)
maybeLogPath

    (FilePath -> IO ())
-> Maybe FilePath -> IO BuildOutcome -> IO BuildOutcome
forall a. (FilePath -> IO ()) -> Maybe FilePath -> IO a -> IO a
logDirChange ((FilePath -> IO ())
-> (FilePath -> FilePath -> IO ())
-> Maybe FilePath
-> FilePath
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO () -> FilePath -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())) FilePath -> FilePath -> IO ()
appendFile Maybe FilePath
mLogPath) Maybe FilePath
workingDir (IO BuildOutcome -> IO BuildOutcome)
-> IO BuildOutcome -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ do
      -- Configure phase
      (SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
ConfigureFailed (IO BuildOutcome -> IO BuildOutcome)
-> IO BuildOutcome -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ do
        ProgressPhase -> IO ()
noticeProgress ProgressPhase
ProgressStarting
        CommandUI ConfigFlags
-> (ConfigFlags -> CommonSetupFlags)
-> (Version -> IO ConfigFlags)
-> Maybe FilePath
-> IO ()
forall {flags}.
CommandUI flags
-> (flags -> CommonSetupFlags)
-> (Version -> IO flags)
-> Maybe FilePath
-> IO ()
setup CommandUI ConfigFlags
configureCommand ConfigFlags -> CommonSetupFlags
configCommonFlags (ConfigFlags -> IO ConfigFlags
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConfigFlags -> IO ConfigFlags)
-> (Version -> ConfigFlags) -> Version -> IO ConfigFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> ConfigFlags
configureFlags) Maybe FilePath
mLogPath

        -- Build phase
        (SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
BuildFailed (IO BuildOutcome -> IO BuildOutcome)
-> IO BuildOutcome -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ do
          ProgressPhase -> IO ()
noticeProgress ProgressPhase
ProgressBuilding
          CommandUI BuildFlags
-> (BuildFlags -> CommonSetupFlags)
-> (Version -> IO BuildFlags)
-> Maybe FilePath
-> IO ()
forall {flags}.
CommandUI flags
-> (flags -> CommonSetupFlags)
-> (Version -> IO flags)
-> Maybe FilePath
-> IO ()
setup CommandUI BuildFlags
buildCommand' BuildFlags -> CommonSetupFlags
buildCommonFlags (BuildFlags -> IO BuildFlags
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildFlags -> IO BuildFlags)
-> (Version -> BuildFlags) -> Version -> IO BuildFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> BuildFlags
buildFlags) Maybe FilePath
mLogPath

          -- Doc generation phase
          DocsResult
docsResult <-
            if Bool
shouldHaddock
              then
                ( do
                    CommandUI HaddockFlags
-> (HaddockFlags -> CommonSetupFlags)
-> (Version -> IO HaddockFlags)
-> Maybe FilePath
-> IO ()
forall {flags}.
CommandUI flags
-> (flags -> CommonSetupFlags)
-> (Version -> IO flags)
-> Maybe FilePath
-> IO ()
setup CommandUI HaddockFlags
haddockCommand HaddockFlags -> CommonSetupFlags
haddockCommonFlags (HaddockFlags -> IO HaddockFlags
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags -> IO HaddockFlags)
-> (Version -> HaddockFlags) -> Version -> IO HaddockFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> HaddockFlags
haddockFlags') Maybe FilePath
mLogPath
                    DocsResult -> IO DocsResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DocsResult
DocsOk
                )
                  IO DocsResult -> (IOException -> IO DocsResult) -> IO DocsResult
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` (\IOException
_ -> DocsResult -> IO DocsResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DocsResult
DocsFailed)
                  IO DocsResult -> (ExitCode -> IO DocsResult) -> IO DocsResult
forall a. IO a -> (ExitCode -> IO a) -> IO a
`catchExit` (\ExitCode
_ -> DocsResult -> IO DocsResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DocsResult
DocsFailed)
              else DocsResult -> IO DocsResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DocsResult
DocsNotTried

          -- Tests phase
          (SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
TestsFailed (IO BuildOutcome -> IO BuildOutcome)
-> IO BuildOutcome -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
testsEnabled Bool -> Bool -> Bool
&& PackageDescription -> Bool
PackageDescription.hasTests PackageDescription
pkg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              CommandUI TestFlags
-> (TestFlags -> CommonSetupFlags)
-> (Version -> IO TestFlags)
-> Maybe FilePath
-> IO ()
forall {flags}.
CommandUI flags
-> (flags -> CommonSetupFlags)
-> (Version -> IO flags)
-> Maybe FilePath
-> IO ()
setup CommandUI TestFlags
Cabal.testCommand TestFlags -> CommonSetupFlags
testCommonFlags (TestFlags -> IO TestFlags
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TestFlags -> IO TestFlags)
-> (Version -> TestFlags) -> Version -> IO TestFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> TestFlags
testFlags') Maybe FilePath
mLogPath

            let testsResult :: TestsResult
testsResult
                  | Bool
testsEnabled = TestsResult
TestsOk
                  | Bool
otherwise = TestsResult
TestsNotTried

            -- Install phase
            (SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
InstallFailed (IO BuildOutcome -> IO BuildOutcome)
-> IO BuildOutcome -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ Lock -> IO BuildOutcome -> IO BuildOutcome
forall a. Lock -> IO a -> IO a
criticalSection Lock
installLock (IO BuildOutcome -> IO BuildOutcome)
-> IO BuildOutcome -> IO BuildOutcome
forall a b. (a -> b) -> a -> b
$ do
              -- Actual installation
              Verbosity
-> UnitId
-> ConfigFlags
-> CompilerInfo
-> Platform
-> PackageDescription
-> IO ()
-> IO ()
forall a.
Verbosity
-> UnitId
-> ConfigFlags
-> CompilerInfo
-> Platform
-> PackageDescription
-> IO a
-> IO a
withWin32SelfUpgrade
                Verbosity
verbosity
                UnitId
uid
                ConfigFlags
configFlags
                CompilerInfo
cinfo
                Platform
platform
                PackageDescription
pkg
                (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                  CommandUI CopyFlags
-> (CopyFlags -> CommonSetupFlags)
-> (Version -> IO CopyFlags)
-> Maybe FilePath
-> IO ()
forall {flags}.
CommandUI flags
-> (flags -> CommonSetupFlags)
-> (Version -> IO flags)
-> Maybe FilePath
-> IO ()
setup CommandUI CopyFlags
Cabal.copyCommand CopyFlags -> CommonSetupFlags
copyCommonFlags (CopyFlags -> IO CopyFlags
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CopyFlags -> IO CopyFlags)
-> (Version -> CopyFlags) -> Version -> IO CopyFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> CopyFlags
copyFlags) Maybe FilePath
mLogPath

              -- Capture installed package configuration file, so that
              -- it can be incorporated into the final InstallPlan
              [InstalledPackageInfo]
ipkgs <-
                if Bool
shouldRegister
                  then (Version -> RegisterFlags)
-> Maybe FilePath -> IO [InstalledPackageInfo]
genPkgConfs Version -> RegisterFlags
registerFlags Maybe FilePath
mLogPath
                  else [InstalledPackageInfo] -> IO [InstalledPackageInfo]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
              let ipkgs' :: [InstalledPackageInfo]
ipkgs' = case [InstalledPackageInfo]
ipkgs of
                    [InstalledPackageInfo
ipkg] -> [InstalledPackageInfo
ipkg{Installed.installedUnitId = uid}]
                    [InstalledPackageInfo]
_ -> [InstalledPackageInfo]
ipkgs
              let packageDBs :: PackageDBStackX (SymbolicPath Pkg ('Dir PkgDB))
packageDBs =
                    Bool
-> [Maybe (PackageDBX (SymbolicPath Pkg ('Dir PkgDB)))]
-> PackageDBStackX (SymbolicPath Pkg ('Dir PkgDB))
forall fp. Bool -> [Maybe (PackageDBX fp)] -> PackageDBStackX fp
interpretPackageDbFlags
                      (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags))
                      (ConfigFlags -> [Maybe (PackageDBX (SymbolicPath Pkg ('Dir PkgDB)))]
configPackageDBs ConfigFlags
configFlags)
              [InstalledPackageInfo] -> (InstalledPackageInfo -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [InstalledPackageInfo]
ipkgs' ((InstalledPackageInfo -> IO ()) -> IO ())
-> (InstalledPackageInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \InstalledPackageInfo
ipkg' ->
                Verbosity
-> Compiler
-> ProgramDb
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageDBStackX (SymbolicPath Pkg ('Dir PkgDB))
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
forall from.
Verbosity
-> Compiler
-> ProgramDb
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackS from
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
registerPackage
                  Verbosity
verbosity
                  Compiler
comp
                  ProgramDb
progdb
                  Maybe (SymbolicPath CWD ('Dir Pkg))
forall {from} {to :: FileOrDir}. Maybe (SymbolicPath from to)
mbWorkDir
                  PackageDBStackX (SymbolicPath Pkg ('Dir PkgDB))
packageDBs
                  InstalledPackageInfo
ipkg'
                  RegisterOptions
defaultRegisterOptions

              BuildOutcome -> IO BuildOutcome
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildResult -> BuildOutcome
forall a b. b -> Either a b
Right (DocsResult
-> TestsResult -> Maybe InstalledPackageInfo -> BuildResult
BuildResult DocsResult
docsResult TestsResult
testsResult ((InstalledPackageInfo -> Bool)
-> [InstalledPackageInfo] -> Maybe InstalledPackageInfo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
uid) (UnitId -> Bool)
-> (InstalledPackageInfo -> UnitId) -> InstalledPackageInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId) [InstalledPackageInfo]
ipkgs')))
    where
      pkgid :: PackageIdentifier
pkgid = PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg
      uid :: UnitId
uid = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc) -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg
      cinfo :: CompilerInfo
cinfo = Compiler -> CompilerInfo
compilerInfo Compiler
comp
      buildCommand' :: CommandUI BuildFlags
buildCommand' = ProgramDb -> CommandUI BuildFlags
buildCommand ProgramDb
progdb
      dispname :: FilePath
dispname = PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgid
      isParallelBuild :: Bool
isParallelBuild = Int
numJobs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2

      noticeProgress :: ProgressPhase -> IO ()
noticeProgress ProgressPhase
phase =
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isParallelBuild (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Verbosity -> ProgressPhase -> FilePath -> IO ()
progressMessage Verbosity
verbosity ProgressPhase
phase FilePath
dispname
      verbosity' :: Verbosity
verbosity' = Verbosity
-> ((PackageIdentifier -> UnitId -> FilePath, Verbosity)
    -> Verbosity)
-> UseLogFile
-> Verbosity
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Verbosity
verbosity (PackageIdentifier -> UnitId -> FilePath, Verbosity) -> Verbosity
forall a b. (a, b) -> b
snd UseLogFile
useLogFile
      tempTemplate :: FilePath -> FilePath
tempTemplate FilePath
name = FilePath
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgid

      addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags
      addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags
addDefaultInstallDirs ConfigFlags
configFlags' = do
        InstallDirTemplates
defInstallDirs <- CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
InstallDirs.defaultInstallDirs CompilerFlavor
flavor Bool
userInstall Bool
False
        ConfigFlags -> IO ConfigFlags
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConfigFlags -> IO ConfigFlags) -> ConfigFlags -> IO ConfigFlags
forall a b. (a -> b) -> a -> b
$
          ConfigFlags
configFlags'
            { configInstallDirs =
                fmap Cabal.Flag
                  . InstallDirs.substituteInstallDirTemplates env
                  $ InstallDirs.combineInstallDirs
                    fromFlagOrDefault
                    defInstallDirs
                    (configInstallDirs configFlags)
            }
        where
          CompilerId CompilerFlavor
flavor Version
_ = CompilerInfo -> CompilerId
compilerInfoId CompilerInfo
cinfo
          env :: PathTemplateEnv
env = PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv PackageIdentifier
pkgid UnitId
uid CompilerInfo
cinfo Platform
platform
          userInstall :: Bool
userInstall =
            Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault
              Bool
defaultUserInstall
              (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags')

      genPkgConfs
        :: (Version -> Cabal.RegisterFlags)
        -> Maybe FilePath
        -> IO [Installed.InstalledPackageInfo]
      genPkgConfs :: (Version -> RegisterFlags)
-> Maybe FilePath -> IO [InstalledPackageInfo]
genPkgConfs Version -> RegisterFlags
flags Maybe FilePath
mLogPath = do
        FilePath
tmp <- IO FilePath
getTemporaryDirectory
        Verbosity
-> FilePath
-> FilePath
-> (FilePath -> IO [InstalledPackageInfo])
-> IO [InstalledPackageInfo]
forall a.
Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory Verbosity
verbosity FilePath
tmp (FilePath -> FilePath
tempTemplate FilePath
"pkgConf") ((FilePath -> IO [InstalledPackageInfo])
 -> IO [InstalledPackageInfo])
-> (FilePath -> IO [InstalledPackageInfo])
-> IO [InstalledPackageInfo]
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
          let pkgConfDest :: SymbolicPathX 'AllowAbsolute a3 c3
pkgConfDest = FilePath -> SymbolicPath a3 ('Dir Any)
forall from (to :: FileOrDir). FilePath -> SymbolicPath from to
makeSymbolicPath FilePath
dir SymbolicPath a3 ('Dir Any)
-> RelativePath Any c3 -> SymbolicPathX 'AllowAbsolute a3 c3
forall p q r. PathLike p q r => p -> q -> r
</> FilePath -> RelativePath Any c3
forall from (to :: FileOrDir).
HasCallStack =>
FilePath -> RelativePath from to
makeRelativePathEx FilePath
"pkgConf"
              registerFlags' :: Version -> RegisterFlags
registerFlags' Version
version =
                (Version -> RegisterFlags
flags Version
version)
                  { Cabal.regGenPkgConf = toFlag (Just pkgConfDest)
                  }
          CommandUI RegisterFlags
-> (RegisterFlags -> CommonSetupFlags)
-> (Version -> IO RegisterFlags)
-> Maybe FilePath
-> IO ()
forall {flags}.
CommandUI flags
-> (flags -> CommonSetupFlags)
-> (Version -> IO flags)
-> Maybe FilePath
-> IO ()
setup
            CommandUI RegisterFlags
Cabal.registerCommand
            RegisterFlags -> CommonSetupFlags
registerCommonFlags
            (RegisterFlags -> IO RegisterFlags
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RegisterFlags -> IO RegisterFlags)
-> (Version -> RegisterFlags) -> Version -> IO RegisterFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> RegisterFlags
registerFlags')
            Maybe FilePath
mLogPath
          Bool
is_dir <- FilePath -> IO Bool
doesDirectoryExist (SymbolicPathX 'AllowAbsolute Any Any -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
interpretSymbolicPathCWD SymbolicPathX 'AllowAbsolute Any Any
forall {a3} {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute a3 c3
pkgConfDest)
          let notHidden :: FilePath -> Bool
notHidden = Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
isHidden
              isHidden :: FilePath -> Bool
isHidden FilePath
name = FilePath
"." FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
name
          if Bool
is_dir
            then -- Sort so that each prefix of the package
            -- configurations is well formed

              (FilePath -> IO InstalledPackageInfo)
-> [FilePath] -> IO [InstalledPackageInfo]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (FilePath -> FilePath -> IO InstalledPackageInfo
readPkgConf (SymbolicPathX 'AllowAbsolute Any Any -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath SymbolicPathX 'AllowAbsolute Any Any
forall {a3} {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute a3 c3
pkgConfDest)) ([FilePath] -> IO [InstalledPackageInfo])
-> ([FilePath] -> [FilePath])
-> [FilePath]
-> IO [InstalledPackageInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort ([FilePath] -> [FilePath])
-> ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
notHidden
                ([FilePath] -> IO [InstalledPackageInfo])
-> IO [FilePath] -> IO [InstalledPackageInfo]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO [FilePath]
getDirectoryContents (SymbolicPathX 'AllowAbsolute Any Any -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath SymbolicPathX 'AllowAbsolute Any Any
forall {a3} {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute a3 c3
pkgConfDest)
            else (InstalledPackageInfo -> [InstalledPackageInfo])
-> IO InstalledPackageInfo -> IO [InstalledPackageInfo]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (InstalledPackageInfo
-> [InstalledPackageInfo] -> [InstalledPackageInfo]
forall a. a -> [a] -> [a]
: []) (IO InstalledPackageInfo -> IO [InstalledPackageInfo])
-> IO InstalledPackageInfo -> IO [InstalledPackageInfo]
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO InstalledPackageInfo
readPkgConf FilePath
"." (SymbolicPathX 'AllowAbsolute Any Any -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath SymbolicPathX 'AllowAbsolute Any Any
forall {a3} {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute a3 c3
pkgConfDest)

      readPkgConf
        :: FilePath
        -> FilePath
        -> IO Installed.InstalledPackageInfo
      readPkgConf :: FilePath -> FilePath -> IO InstalledPackageInfo
readPkgConf FilePath
pkgConfDir FilePath
pkgConfFile = do
        ByteString
pkgConfText <- FilePath -> IO ByteString
BS.readFile (FilePath
pkgConfDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
pkgConfFile)
        case ByteString
-> Either (NonEmpty FilePath) ([FilePath], InstalledPackageInfo)
Installed.parseInstalledPackageInfo ByteString
pkgConfText of
          Left NonEmpty FilePath
perrors -> FilePath -> IO InstalledPackageInfo
forall a. FilePath -> IO a
pkgConfParseFailed (FilePath -> IO InstalledPackageInfo)
-> FilePath -> IO InstalledPackageInfo
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ NonEmpty FilePath -> [FilePath]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty FilePath
perrors
          Right ([FilePath]
warns, InstalledPackageInfo
pkgConf) -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
warns) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
                [FilePath] -> FilePath
unlines [FilePath]
warns
            InstalledPackageInfo -> IO InstalledPackageInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageInfo
pkgConf

      pkgConfParseFailed :: String -> IO a
      pkgConfParseFailed :: forall a. FilePath -> IO a
pkgConfParseFailed FilePath
perror =
        Verbosity -> CabalInstallException -> IO a
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO a) -> CabalInstallException -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalInstallException
PkgConfParsedFailed FilePath
perror

      maybeLogPath :: IO (Maybe FilePath)
      maybeLogPath :: IO (Maybe FilePath)
maybeLogPath =
        case UseLogFile
useLogFile of
          UseLogFile
Nothing -> Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
          Just (PackageIdentifier -> UnitId -> FilePath
mkLogFileName, Verbosity
_) -> do
            let logFileName :: FilePath
logFileName = PackageIdentifier -> UnitId -> FilePath
mkLogFileName (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg) UnitId
uid
                logDir :: FilePath
logDir = FilePath -> FilePath
takeDirectory FilePath
logFileName
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
logDir) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
logDir
            Bool
logFileExists <- FilePath -> IO Bool
doesFileExist FilePath
logFileName
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
logFileExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
logFileName
            Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
logFileName)

      setup :: CommandUI flags
-> (flags -> CommonSetupFlags)
-> (Version -> IO flags)
-> Maybe FilePath
-> IO ()
setup CommandUI flags
cmd flags -> CommonSetupFlags
getCommonFlags Version -> IO flags
flags Maybe FilePath
mLogPath =
        IO (Maybe Handle)
-> (Maybe Handle -> IO ()) -> (Maybe Handle -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
          ((FilePath -> IO Handle) -> Maybe FilePath -> IO (Maybe Handle)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (\FilePath
path -> FilePath -> IOMode -> IO Handle
openFile FilePath
path IOMode
AppendMode) Maybe FilePath
mLogPath)
          ((Handle -> IO ()) -> Maybe Handle -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Handle -> IO ()
hClose)
          ( \Maybe Handle
logFileHandle ->
              Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (flags -> CommonSetupFlags)
-> (Version -> IO flags)
-> (Version -> [FilePath])
-> IO ()
forall flags.
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (flags -> CommonSetupFlags)
-> (Version -> IO flags)
-> (Version -> [FilePath])
-> IO ()
setupWrapper
                Verbosity
verbosity
                SetupScriptOptions
scriptOptions
                  { useLoggingHandle = logFileHandle
                  , useWorkingDir = makeSymbolicPath <$> workingDir
                  }
                (PackageDescription -> Maybe PackageDescription
forall a. a -> Maybe a
Just PackageDescription
pkg)
                CommandUI flags
cmd
                flags -> CommonSetupFlags
getCommonFlags
                Version -> IO flags
flags
                ([FilePath] -> Version -> [FilePath]
forall a b. a -> b -> a
const [])
          )

-- helper
onFailure :: (SomeException -> BuildFailure) -> IO BuildOutcome -> IO BuildOutcome
onFailure :: (SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
result IO BuildOutcome
action =
  IO BuildOutcome
action
    IO BuildOutcome -> [Handler BuildOutcome] -> IO BuildOutcome
forall a. IO a -> [Handler a] -> IO a
`catches` [ (IOException -> IO BuildOutcome) -> Handler BuildOutcome
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((IOException -> IO BuildOutcome) -> Handler BuildOutcome)
-> (IOException -> IO BuildOutcome) -> Handler BuildOutcome
forall a b. (a -> b) -> a -> b
$ \IOException
ioe -> IOException -> IO BuildOutcome
forall e. Exception e => e -> IO BuildOutcome
handler (IOException
ioe :: IOException)
              , (VerboseException CabalException -> IO BuildOutcome)
-> Handler BuildOutcome
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((VerboseException CabalException -> IO BuildOutcome)
 -> Handler BuildOutcome)
-> (VerboseException CabalException -> IO BuildOutcome)
-> Handler BuildOutcome
forall a b. (a -> b) -> a -> b
$ \VerboseException CabalException
cabalexe -> VerboseException CabalException -> IO BuildOutcome
forall e. Exception e => e -> IO BuildOutcome
handler (VerboseException CabalException
cabalexe :: VerboseException CabalException)
              , (ExitCode -> IO BuildOutcome) -> Handler BuildOutcome
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ExitCode -> IO BuildOutcome) -> Handler BuildOutcome)
-> (ExitCode -> IO BuildOutcome) -> Handler BuildOutcome
forall a b. (a -> b) -> a -> b
$ \ExitCode
exit -> ExitCode -> IO BuildOutcome
forall e. Exception e => e -> IO BuildOutcome
handler (ExitCode
exit :: ExitCode)
              ]
  where
    handler :: Exception e => e -> IO BuildOutcome
    handler :: forall e. Exception e => e -> IO BuildOutcome
handler = BuildOutcome -> IO BuildOutcome
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildOutcome -> IO BuildOutcome)
-> (e -> BuildOutcome) -> e -> IO BuildOutcome
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildFailure -> BuildOutcome
forall a b. a -> Either a b
Left (BuildFailure -> BuildOutcome)
-> (e -> BuildFailure) -> e -> BuildOutcome
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> BuildFailure
result (SomeException -> BuildFailure)
-> (e -> SomeException) -> e -> BuildFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> SomeException
forall e. Exception e => e -> SomeException
toException

-- ------------------------------------------------------------

-- * Weird windows hacks

-- ------------------------------------------------------------

withWin32SelfUpgrade
  :: Verbosity
  -> UnitId
  -> ConfigFlags
  -> CompilerInfo
  -> Platform
  -> PackageDescription
  -> IO a
  -> IO a
withWin32SelfUpgrade :: forall a.
Verbosity
-> UnitId
-> ConfigFlags
-> CompilerInfo
-> Platform
-> PackageDescription
-> IO a
-> IO a
withWin32SelfUpgrade Verbosity
_ UnitId
_ ConfigFlags
_ CompilerInfo
_ Platform
_ PackageDescription
_ IO a
action | OS
buildOS OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
/= OS
Windows = IO a
action
withWin32SelfUpgrade Verbosity
verbosity UnitId
uid ConfigFlags
configFlags CompilerInfo
cinfo Platform
platform PackageDescription
pkg IO a
action = do
  InstallDirTemplates
defaultDirs <-
    CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
InstallDirs.defaultInstallDirs
      CompilerFlavor
compFlavor
      (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags))
      (PackageDescription -> Bool
PackageDescription.hasLibs PackageDescription
pkg)

  Verbosity -> [FilePath] -> IO a -> IO a
forall a. Verbosity -> [FilePath] -> IO a -> IO a
Win32SelfUpgrade.possibleSelfUpgrade
    Verbosity
verbosity
    (InstallDirTemplates -> [FilePath]
exeInstallPaths InstallDirTemplates
defaultDirs)
    IO a
action
  where
    pkgid :: PackageIdentifier
pkgid = PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg
    (CompilerId CompilerFlavor
compFlavor Version
_) = CompilerInfo -> CompilerId
compilerInfoId CompilerInfo
cinfo

    exeInstallPaths :: InstallDirTemplates -> [FilePath]
exeInstallPaths InstallDirTemplates
defaultDirs =
      [ InstallDirs FilePath -> FilePath
forall dir. InstallDirs dir -> dir
InstallDirs.bindir InstallDirs FilePath
absoluteDirs FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
exeName FilePath -> FilePath -> FilePath
<.> Platform -> FilePath
exeExtension Platform
buildPlatform
      | Executable
exe <- PackageDescription -> [Executable]
PackageDescription.executables PackageDescription
pkg
      , BuildInfo -> Bool
PackageDescription.buildable (Executable -> BuildInfo
PackageDescription.buildInfo Executable
exe)
      , let exeName :: FilePath
exeName = FilePath
prefix FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (Executable -> UnqualComponentName
PackageDescription.exeName Executable
exe) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
suffix
            prefix :: FilePath
prefix = PathTemplate -> FilePath
substTemplate PathTemplate
prefixTemplate
            suffix :: FilePath
suffix = PathTemplate -> FilePath
substTemplate PathTemplate
suffixTemplate
      ]
      where
        fromFlagTemplate :: Flag PathTemplate -> PathTemplate
fromFlagTemplate = PathTemplate -> Flag PathTemplate -> PathTemplate
forall a. a -> Flag a -> a
fromFlagOrDefault (FilePath -> PathTemplate
InstallDirs.toPathTemplate FilePath
"")
        prefixTemplate :: PathTemplate
prefixTemplate = Flag PathTemplate -> PathTemplate
fromFlagTemplate (ConfigFlags -> Flag PathTemplate
configProgPrefix ConfigFlags
configFlags)
        suffixTemplate :: PathTemplate
suffixTemplate = Flag PathTemplate -> PathTemplate
fromFlagTemplate (ConfigFlags -> Flag PathTemplate
configProgSuffix ConfigFlags
configFlags)
        templateDirs :: InstallDirTemplates
templateDirs =
          (PathTemplate -> Flag PathTemplate -> PathTemplate)
-> InstallDirTemplates
-> InstallDirs (Flag PathTemplate)
-> InstallDirTemplates
forall a b c.
(a -> b -> c) -> InstallDirs a -> InstallDirs b -> InstallDirs c
InstallDirs.combineInstallDirs
            PathTemplate -> Flag PathTemplate -> PathTemplate
forall a. a -> Flag a -> a
fromFlagOrDefault
            InstallDirTemplates
defaultDirs
            (ConfigFlags -> InstallDirs (Flag PathTemplate)
configInstallDirs ConfigFlags
configFlags)
        absoluteDirs :: InstallDirs FilePath
absoluteDirs =
          PackageIdentifier
-> UnitId
-> CompilerInfo
-> CopyDest
-> Platform
-> InstallDirTemplates
-> InstallDirs FilePath
InstallDirs.absoluteInstallDirs
            PackageIdentifier
pkgid
            UnitId
uid
            CompilerInfo
cinfo
            CopyDest
InstallDirs.NoCopyDest
            Platform
platform
            InstallDirTemplates
templateDirs
        substTemplate :: PathTemplate -> FilePath
substTemplate =
          PathTemplate -> FilePath
InstallDirs.fromPathTemplate
            (PathTemplate -> FilePath)
-> (PathTemplate -> PathTemplate) -> PathTemplate -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplateEnv -> PathTemplate -> PathTemplate
InstallDirs.substPathTemplate PathTemplateEnv
env
          where
            env :: PathTemplateEnv
env =
              PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
InstallDirs.initialPathTemplateEnv
                PackageIdentifier
pkgid
                UnitId
uid
                CompilerInfo
cinfo
                Platform
platform