{-# LANGUAGE CPP #-}
module Distribution.Client.Install (
install,
makeInstallContext,
makeInstallPlan,
processInstallPlan,
InstallArgs,
InstallContext,
pruneInstallPlan
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Utils.Generic(safeLast)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import Control.Exception as Exception
( bracket, catches, Handler(Handler), handleJust )
import System.Directory
( getTemporaryDirectory, doesDirectoryExist, doesFileExist,
createDirectoryIfMissing, removeFile, renameDirectory,
getDirectoryContents )
import System.FilePath
( (</>), (<.>), equalFilePath, takeDirectory )
import System.IO
( openFile, IOMode(AppendMode), hClose )
import System.IO.Error
( isDoesNotExistError, ioeGetFileName )
import Distribution.Client.Targets
import Distribution.Client.Configure
( chooseCabalVersion, configureSetupScript, checkConfigExFlags )
import Distribution.Client.Dependency
import Distribution.Client.Dependency.Types
( Solver(..) )
import Distribution.Client.FetchUtils
import Distribution.Client.HttpUtils
( HttpTransport (..) )
import Distribution.Solver.Types.PackageFixedDeps
import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackagesAtIndexState, getInstalledPackages )
import qualified Distribution.Client.InstallPlan as InstallPlan
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
import Distribution.Client.Setup
( GlobalFlags(..), RepoContext(..)
, ConfigFlags(..), configureCommand, filterConfigureFlags
, ConfigExFlags(..), InstallFlags(..)
, filterTestFlags )
import Distribution.Client.Config
( defaultReportsDir, defaultUserInstall )
import Distribution.Client.Tar (extractTarGzFile)
import Distribution.Client.Types as Source
import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.SetupWrapper
( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
import Distribution.Client.BuildReports.Anonymous (showBuildReport)
import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
import qualified Distribution.Client.BuildReports.Storage as BuildReports
( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure )
import qualified Distribution.Client.InstallSymlink as InstallSymlink
( symlinkBinaries )
import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..))
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.Client.JobControl
import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.Settings
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.SourcePackage as SourcePackage
import Distribution.Utils.NubList
import Distribution.Simple.Compiler
( CompilerId(..), Compiler(compilerId), compilerFlavor
, CompilerInfo(..), compilerInfo, PackageDB(..), PackageDBStack )
import Distribution.Simple.Program (ProgramDb)
import qualified Distribution.Simple.InstallDirs as InstallDirs
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import Distribution.Simple.Setup
( haddockCommand, HaddockFlags(..)
, buildCommand, BuildFlags(..), emptyBuildFlags
, TestFlags, BenchmarkFlags
, toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref )
import qualified Distribution.Simple.Setup as Cabal
( Flag(..)
, copyCommand, CopyFlags(..), emptyCopyFlags
, registerCommand, RegisterFlags(..), emptyRegisterFlags
, testCommand, TestFlags(..) )
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, writeFileAtomic )
import Distribution.Simple.InstallDirs as InstallDirs
( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate
, initialPathTemplateEnv, installDirsTemplateEnv )
import Distribution.Simple.Configure (interpretPackageDbFlags)
import Distribution.Simple.Register (registerPackage, defaultRegisterOptions)
import Distribution.Package
( PackageIdentifier(..), PackageId, packageName, packageVersion
, Package(..), HasMungedPackageId(..), HasUnitId(..)
, UnitId )
import Distribution.Types.GivenComponent
( GivenComponent(..) )
import Distribution.Types.PackageVersionConstraint
( PackageVersionConstraint(..), thisPackageVersionConstraint )
import Distribution.Types.MungedPackageId
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription
( PackageDescription, GenericPackageDescription(..) )
import Distribution.Types.Flag
( PackageFlag(..), FlagAssignment, mkFlagAssignment
, showFlagAssignment, diffFlagAssignment, nullFlagAssignment )
import Distribution.PackageDescription.Configuration
( finalizePD )
import Distribution.Version
( Version, VersionRange, foldVersionRange )
import Distribution.Simple.Utils as Utils
( notice, info, warn, debug, debugNoWrap, die'
, withTempDirectory )
import Distribution.Client.Utils
( determineNumJobs, logDirChange, mergeBy, MergeResult(..)
, ProgressPhase(..), progressMessage )
import Distribution.System
( Platform, OS(Windows), buildOS, buildPlatform )
import Distribution.Verbosity as Verbosity
( modifyVerbosity, normal, verbose )
import Distribution.Simple.BuildPaths ( exeExtension )
import qualified Data.ByteString as BS
install
:: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> HaddockFlags
-> TestFlags
-> BenchmarkFlags
-> [UserTarget]
-> IO ()
install :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> HaddockFlags
-> TestFlags
-> BenchmarkFlags
-> [UserTarget]
-> IO ()
install Verbosity
verbosity PackageDBStack
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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (InstallFlags -> Flag FilePath
installRootCmd InstallFlags
installFlags forall a. Eq a => a -> a -> Bool
== forall a. Flag a
Cabal.NoFlag) forall a b. (a -> b) -> a -> b
$
Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"--root-cmd is no longer supported, "
forall a. [a] -> [a] -> [a]
++ FilePath
"see https://github.com/haskell/cabal/issues/3353"
forall a. [a] -> [a] -> [a]
++ FilePath
" (if you didn't type --root-cmd, comment out root-cmd"
forall a. [a] -> [a] -> [a]
++ FilePath
" in your ~/.config/cabal/config file)"
let userOrSandbox :: Bool
userOrSandbox = forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
userOrSandbox forall a b. (a -> b) -> a -> b
$
Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"the --global flag is deprecated -- "
forall a. [a] -> [a] -> [a]
++ FilePath
"it is generally considered a bad idea to install packages "
forall a. [a] -> [a] -> [a]
++ FilePath
"into the global store"
InstallContext
installContext <- Verbosity -> InstallArgs -> Maybe [UserTarget] -> IO InstallContext
makeInstallContext Verbosity
verbosity InstallArgs
args (forall a. a -> Maybe a
Just [UserTarget]
userTargets0)
Either FilePath SolverInstallPlan
planResult <- forall step a fail done.
(step -> a -> a)
-> (fail -> a) -> (done -> a) -> Progress step fail done -> a
foldProgress forall {b}. FilePath -> IO b -> IO b
logMsg (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right) 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
forall {a}. FilePath -> IO a
die'' 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 = (PackageDBStack
packageDBs, RepoContext
repos, Compiler
comp, Platform
platform, ProgramDb
progdb,
GlobalFlags
globalFlags, ConfigFlags
configFlags, ConfigExFlags
configExFlags,
InstallFlags
installFlags, HaddockFlags
haddockFlags, TestFlags
testFlags, BenchmarkFlags
benchmarkFlags)
die'' :: FilePath -> IO a
die'' = forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity
logMsg :: FilePath -> IO b -> IO b
logMsg FilePath
message IO b
rest = Verbosity -> FilePath -> IO ()
debugNoWrap Verbosity
verbosity FilePath
message forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
rest
type InstallContext = ( InstalledPackageIndex, SourcePackageDb
, PkgConfigDb
, [UserTarget], [PackageSpecifier UnresolvedSourcePackage]
, HttpTransport )
type InstallArgs = ( PackageDBStack
, RepoContext
, Compiler
, Platform
, ProgramDb
, GlobalFlags
, ConfigFlags
, ConfigExFlags
, InstallFlags
, HaddockFlags
, TestFlags
, BenchmarkFlags )
makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]
-> IO InstallContext
makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget] -> IO InstallContext
makeInstallContext Verbosity
verbosity
(PackageDBStack
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 = forall a. Flag a -> Maybe a
flagToMaybe (InstallFlags -> Flag TotalIndexState
installIndexState InstallFlags
installFlags)
InstalledPackageIndex
installedPkgIndex <- Verbosity
-> Compiler
-> PackageDBStack
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
comp PackageDBStack
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 forall a. Maybe a
Nothing
PkgConfigDb
pkgConfigDb <- Verbosity -> ProgramDb -> IO PkgConfigDb
readPkgConfigDb Verbosity
verbosity ProgramDb
progdb
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 ->
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
Just [UserTarget]
userTargets0 -> do
let userTargets :: [UserTarget]
userTargets | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UserTarget]
userTargets0 = [FilePath -> UserTarget
UserTargetLocalDir FilePath
"."]
| Bool
otherwise = [UserTarget]
userTargets0
[PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers <- 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
forall (m :: * -> *) a. Monad m => a -> m a
return ([UserTarget]
userTargets, [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers)
forall (m :: * -> *) a. Monad m => a -> m a
return (InstalledPackageIndex
installedPkgIndex, SourcePackageDb
sourcePkgDb, PkgConfigDb
pkgConfigDb, [UserTarget]
userTargets
,[PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers, HttpTransport
transport)
makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext
-> IO (Progress String String SolverInstallPlan)
makeInstallPlan :: Verbosity
-> InstallArgs
-> InstallContext
-> IO (Progress FilePath FilePath SolverInstallPlan)
makeInstallPlan Verbosity
verbosity
(PackageDBStack
_, RepoContext
_, Compiler
comp, Platform
platform,ProgramDb
_,
GlobalFlags
_, ConfigFlags
configFlags, ConfigExFlags
configExFlags, InstallFlags
installFlags,
HaddockFlags
_, TestFlags
_, BenchmarkFlags
_)
(InstalledPackageIndex
installedPkgIndex, SourcePackageDb
sourcePkgDb, PkgConfigDb
pkgConfigDb,
[UserTarget]
_, [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers, HttpTransport
_) = do
Solver
solver <- Verbosity -> PreSolver -> CompilerInfo -> IO Solver
chooseSolver Verbosity
verbosity (forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigExFlags -> Flag PreSolver
configSolver ConfigExFlags
configExFlags))
(Compiler -> CompilerInfo
compilerInfo Compiler
comp)
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity FilePath
"Resolving dependencies..."
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Verbosity
-> Compiler
-> Platform
-> Solver
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> PkgConfigDb
-> [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
-> Progress FilePath FilePath SolverInstallPlan
planPackages Verbosity
verbosity Compiler
comp Platform
platform Solver
solver
ConfigFlags
configFlags ConfigExFlags
configExFlags InstallFlags
installFlags
InstalledPackageIndex
installedPkgIndex SourcePackageDb
sourcePkgDb PkgConfigDb
pkgConfigDb [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers
processInstallPlan :: Verbosity -> InstallArgs -> InstallContext
-> SolverInstallPlan
-> IO ()
processInstallPlan :: Verbosity
-> InstallArgs -> InstallContext -> SolverInstallPlan -> IO ()
processInstallPlan Verbosity
verbosity
args :: InstallArgs
args@(PackageDBStack
_,RepoContext
_, Compiler
_, Platform
_, ProgramDb
_, GlobalFlags
_, ConfigFlags
configFlags, ConfigExFlags
_, InstallFlags
installFlags, HaddockFlags
_, TestFlags
_, BenchmarkFlags
_)
(InstalledPackageIndex
installedPkgIndex, SourcePackageDb
sourcePkgDb, 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
dryRun Bool -> Bool -> Bool
|| Bool
nothingToInstall) 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 = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installDryRun InstallFlags
installFlags)
nothingToInstall :: Bool
nothingToInstall = forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a b. (a, b) -> a
fst (forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> ([GenericReadyPackage srcpkg], Processing)
InstallPlan.ready InstallPlan
installPlan))
planPackages :: Verbosity
-> Compiler
-> Platform
-> Solver
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> PkgConfigDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> Progress String String SolverInstallPlan
planPackages :: Verbosity
-> Compiler
-> Platform
-> Solver
-> ConfigFlags
-> ConfigExFlags
-> InstallFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> PkgConfigDb
-> [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
-> Progress FilePath FilePath SolverInstallPlan
planPackages Verbosity
verbosity Compiler
comp Platform
platform Solver
solver
ConfigFlags
configFlags ConfigExFlags
configExFlags InstallFlags
installFlags
InstalledPackageIndex
installedPkgIndex SourcePackageDb
sourcePkgDb PkgConfigDb
pkgConfigDb [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers =
Platform
-> CompilerInfo
-> PkgConfigDb
-> Solver
-> DepResolverParams
-> Progress FilePath FilePath SolverInstallPlan
resolveDependencies
Platform
platform (Compiler -> CompilerInfo
compilerInfo Compiler
comp) PkgConfigDb
pkgConfigDb
Solver
solver
DepResolverParams
resolverParams
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= if Bool
onlyDeps then forall targetpkg.
Package targetpkg =>
[PackageSpecifier targetpkg]
-> SolverInstallPlan
-> Progress FilePath FilePath SolverInstallPlan
pruneInstallPlan [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers else forall (m :: * -> *) a. Monad m => a -> m a
return
where
resolverParams :: DepResolverParams
resolverParams =
Maybe Int -> DepResolverParams -> DepResolverParams
setMaxBackjumps (if Int
maxBackjumps forall a. Ord a => a -> a -> Bool
< Int
0 then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just Int
maxBackjumps)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndependentGoals -> DepResolverParams -> DepResolverParams
setIndependentGoals IndependentGoals
independentGoals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReorderGoals -> DepResolverParams -> DepResolverParams
setReorderGoals ReorderGoals
reorderGoals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CountConflicts -> DepResolverParams -> DepResolverParams
setCountConflicts CountConflicts
countConflicts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FineGrainedConflicts -> DepResolverParams -> DepResolverParams
setFineGrainedConflicts FineGrainedConflicts
fineGrainedConflicts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MinimizeConflictSet -> DepResolverParams -> DepResolverParams
setMinimizeConflictSet MinimizeConflictSet
minimizeConflictSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AvoidReinstalls -> DepResolverParams -> DepResolverParams
setAvoidReinstalls AvoidReinstalls
avoidReinstalls
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShadowPkgs -> DepResolverParams -> DepResolverParams
setShadowPkgs ShadowPkgs
shadowPkgs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrongFlags -> DepResolverParams -> DepResolverParams
setStrongFlags StrongFlags
strongFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllowBootLibInstalls -> DepResolverParams -> DepResolverParams
setAllowBootLibInstalls AllowBootLibInstalls
allowBootLibInstalls
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnlyConstrained -> DepResolverParams -> DepResolverParams
setOnlyConstrained OnlyConstrained
onlyConstrained
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> DepResolverParams -> DepResolverParams
setSolverVerbosity Verbosity
verbosity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackagesPreferenceDefault -> DepResolverParams -> DepResolverParams
setPreferenceDefault (if Bool
upgradeDeps then PackagesPreferenceDefault
PreferAllLatest
else PackagesPreferenceDefault
PreferLatestForSelected)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllowOlder -> DepResolverParams -> DepResolverParams
removeLowerBounds AllowOlder
allowOlder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllowNewer -> DepResolverParams -> DepResolverParams
removeUpperBounds AllowNewer
allowNewer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PackagePreference] -> DepResolverParams -> DepResolverParams
addPreferences
[ PackageName -> VersionRange -> PackagePreference
PackageVersionPreference PackageName
name VersionRange
ver
| PackageVersionConstraint PackageName
name VersionRange
ver <- ConfigExFlags -> [PackageVersionConstraint]
configPreferences ConfigExFlags
configExFlags ]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LabeledPackageConstraint]
-> DepResolverParams -> DepResolverParams
addConstraints
[ PackageConstraint -> ConstraintSource -> LabeledPackageConstraint
LabeledPackageConstraint (UserConstraint -> PackageConstraint
userToPackageConstraint UserConstraint
pc) ConstraintSource
src
| (UserConstraint
pc, ConstraintSource
src) <- ConfigExFlags -> [(UserConstraint, ConstraintSource)]
configExConstraints ConfigExFlags
configExFlags ]
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 forall a b. (a -> b) -> a -> b
$ 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 ]
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 forall a b. (a -> b) -> a -> b
$ 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 ]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
reinstall then DepResolverParams -> DepResolverParams
reinstallTargets else forall a. a -> a
id)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SolveExecutables -> DepResolverParams -> DepResolverParams
setSolveExecutables (Bool -> SolveExecutables
SolveExecutables Bool
False)
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 ]
forall a. [a] -> [a] -> [a]
++ [ OptionalStanza
BenchStanzas | Bool
benchmarksEnabled ]
testsEnabled :: Bool
testsEnabled = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False forall a b. (a -> b) -> a -> b
$ ConfigFlags -> Flag Bool
configTests ConfigFlags
configFlags
benchmarksEnabled :: Bool
benchmarksEnabled = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False forall a b. (a -> b) -> a -> b
$ ConfigFlags -> Flag Bool
configBenchmarks ConfigFlags
configFlags
reinstall :: Bool
reinstall = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installOverrideReinstall InstallFlags
installFlags) Bool -> Bool -> Bool
||
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installReinstall InstallFlags
installFlags)
reorderGoals :: ReorderGoals
reorderGoals = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag ReorderGoals
installReorderGoals InstallFlags
installFlags)
countConflicts :: CountConflicts
countConflicts = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag CountConflicts
installCountConflicts InstallFlags
installFlags)
fineGrainedConflicts :: FineGrainedConflicts
fineGrainedConflicts = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag FineGrainedConflicts
installFineGrainedConflicts InstallFlags
installFlags)
minimizeConflictSet :: MinimizeConflictSet
minimizeConflictSet = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag MinimizeConflictSet
installMinimizeConflictSet InstallFlags
installFlags)
independentGoals :: IndependentGoals
independentGoals = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag IndependentGoals
installIndependentGoals InstallFlags
installFlags)
avoidReinstalls :: AvoidReinstalls
avoidReinstalls = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag AvoidReinstalls
installAvoidReinstalls InstallFlags
installFlags)
shadowPkgs :: ShadowPkgs
shadowPkgs = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag ShadowPkgs
installShadowPkgs InstallFlags
installFlags)
strongFlags :: StrongFlags
strongFlags = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag StrongFlags
installStrongFlags InstallFlags
installFlags)
maxBackjumps :: Int
maxBackjumps = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Int
installMaxBackjumps InstallFlags
installFlags)
allowBootLibInstalls :: AllowBootLibInstalls
allowBootLibInstalls = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag AllowBootLibInstalls
installAllowBootLibInstalls InstallFlags
installFlags)
onlyConstrained :: OnlyConstrained
onlyConstrained = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag OnlyConstrained
installOnlyConstrained InstallFlags
installFlags)
upgradeDeps :: Bool
upgradeDeps = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installUpgradeDeps InstallFlags
installFlags)
onlyDeps :: Bool
onlyDeps = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installOnlyDeps InstallFlags
installFlags)
allowOlder :: AllowOlder
allowOlder = forall a. a -> Maybe a -> a
fromMaybe (RelaxDeps -> AllowOlder
AllowOlder forall a. Monoid a => a
mempty)
(ConfigExFlags -> Maybe AllowOlder
configAllowOlder ConfigExFlags
configExFlags)
allowNewer :: AllowNewer
allowNewer = forall a. a -> Maybe a -> a
fromMaybe (RelaxDeps -> AllowNewer
AllowNewer forall a. Monoid a => a
mempty)
(ConfigExFlags -> Maybe AllowNewer
configAllowNewer ConfigExFlags
configExFlags)
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 =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall step fail done. fail -> Progress step fail done
Fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SolverPlanProblem] -> FilePath
explain) forall step fail done. done -> Progress step fail done
Done
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SolverPlanPackage -> Bool)
-> SolverInstallPlan
-> Either [SolverPlanProblem] SolverInstallPlan
SolverInstallPlan.remove (\SolverPlanPackage
pkg -> forall pkg. Package pkg => pkg -> PackageName
packageName SolverPlanPackage
pkg 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 "
forall a. [a] -> [a] -> [a]
++ FilePath
"'--only-dependencies' flag), "
forall a. [a] -> [a] -> [a]
++ (case [PackageIdentifier]
pkgids of
[PackageIdentifier
pkgid] -> FilePath
"the package " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgid forall a. [a] -> [a] -> [a]
++ FilePath
" is "
[PackageIdentifier]
_ -> FilePath
"the packages "
forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> FilePath
prettyShow [PackageIdentifier]
pkgids) forall a. [a] -> [a] -> [a]
++ FilePath
" are ")
forall a. [a] -> [a] -> [a]
++ FilePath
"required by a dependency of one of the other targets."
where
pkgids :: [PackageIdentifier]
pkgids =
forall a. Eq a => [a] -> [a]
nub [ PackageIdentifier
depid
| SolverInstallPlan.PackageMissingDeps SolverPlanPackage
_ [PackageIdentifier]
depids <- [SolverPlanProblem]
problems
, PackageIdentifier
depid <- [PackageIdentifier]
depids
, forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
depid forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
targetnames ]
targetnames :: [PackageName]
targetnames = forall a b. (a -> b) -> [a] -> [b]
map forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget [PackageSpecifier targetpkg]
pkgSpecifiers
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
let preExistingTargets :: [InstalledPackageInfo]
preExistingTargets =
[ InstalledPackageInfo
p | let tgts :: [PackageName]
tgts = forall a b. (a -> b) -> [a] -> [b]
map forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers,
InstallPlan.PreExisting InstalledPackageInfo
p <- forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList InstallPlan
installPlan,
forall pkg. Package pkg => pkg -> PackageName
packageName InstalledPackageInfo
p forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
tgts ]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
nothingToInstall forall a b. (a -> b) -> a -> b
$
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines forall a b. (a -> b) -> a -> b
$
FilePath
"All the requested packages are already installed:"
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => a -> FilePath
prettyShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. Package pkg => pkg -> PackageIdentifier
packageId) [InstalledPackageInfo]
preExistingTargets
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 <- 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 ]
let reinstalledPkgs :: [UnitId]
reinstalledPkgs =
[ UnitId
ipkg
| (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
_pkg, PackageStatus
status) <- [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)]
lPlan
, UnitId
ipkg <- PackageStatus -> [UnitId]
extractReinstalls PackageStatus
status ]
let oldBrokenPkgs :: [UnitId]
oldBrokenPkgs =
forall a b. (a -> b) -> [a] -> [b]
map InstalledPackageInfo -> UnitId
Installed.installedUnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PackageInstalled a => PackageIndex a -> [UnitId] -> [a]
PackageIndex.reverseDependencyClosure InstalledPackageIndex
installed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (InstalledPackageInfo -> UnitId
Installed.installedUnitId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PackageInstalled a => PackageIndex a -> [(a, [UnitId])]
PackageIndex.brokenPackages
forall a b. (a -> b) -> a -> b
$ InstalledPackageIndex
installed
let excluded :: [UnitId]
excluded = [UnitId]
reinstalledPkgs forall a. [a] -> [a] -> [a]
++ [UnitId]
oldBrokenPkgs
let newBrokenPkgs :: [InstalledPackageInfo]
newBrokenPkgs =
forall a. (a -> Bool) -> [a] -> [a]
filter (\ InstalledPackageInfo
p -> Bool -> Bool
not (InstalledPackageInfo -> UnitId
Installed.installedUnitId InstalledPackageInfo
p forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnitId]
excluded))
(forall a. PackageInstalled a => PackageIndex a -> [UnitId] -> [a]
PackageIndex.reverseDependencyClosure InstalledPackageIndex
installed [UnitId]
reinstalledPkgs)
let containsReinstalls :: Bool
containsReinstalls = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitId]
reinstalledPkgs)
let breaksPkgs :: Bool
breaksPkgs = Bool -> Bool
not (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 (forall a. Ord a => a -> a -> a
max Verbosity
verbose) Verbosity
verbosity
| Bool
otherwise = Verbosity
verbosity
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
dryRun Bool -> Bool -> Bool
|| Bool
containsReinstalls Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
overrideReinstall) 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
containsReinstalls forall a b. (a -> b) -> a -> b
$ do
if Bool
breaksPkgs
then do
(if Bool
dryRun Bool -> Bool -> Bool
|| Bool
overrideReinstall then Verbosity -> FilePath -> IO ()
warn else forall a. Verbosity -> FilePath -> IO a
die') Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines forall a b. (a -> b) -> a -> b
$
FilePath
"The following packages are likely to be broken by the reinstalls:"
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => a -> FilePath
prettyShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId) [InstalledPackageInfo]
newBrokenPkgs
forall a. [a] -> [a] -> [a]
++ if Bool
overrideReinstall
then if Bool
dryRun then [] else
[FilePath
"Continuing even though " forall a. [a] -> [a] -> [a]
++
FilePath
"the plan contains dangerous reinstalls."]
else
[FilePath
"Use --force-reinstalls if you want to install anyway."]
else forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dryRun forall a b. (a -> b) -> a -> b
$ Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity
FilePath
"Note that reinstalls are always dangerous. Continuing anyway..."
let offline :: Bool
offline = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (InstallFlags -> Flag Bool
installOfflineMode InstallFlags
installFlags)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
offline forall a b. (a -> b) -> a -> b
$ do
let pkgs :: [SourcePackage UnresolvedPkgLoc]
pkgs = [ forall loc. ConfiguredPackage loc -> SourcePackage loc
confPkgSource ConfiguredPackage UnresolvedPkgLoc
cpkg
| InstallPlan.Configured ConfiguredPackage UnresolvedPkgLoc
cpkg <- forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList InstallPlan
installPlan ]
[PackageIdentifier]
notFetched <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map forall pkg. Package pkg => pkg -> PackageIdentifier
packageId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnresolvedPkgLoc -> IO (Maybe ResolvedPkgLoc)
checkFetched forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. SourcePackage loc -> loc
srcpkgSource)
forall a b. (a -> b) -> a -> b
$ [SourcePackage UnresolvedPkgLoc]
pkgs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageIdentifier]
notFetched) forall a b. (a -> b) -> a -> b
$
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Can't download packages in offline mode. "
forall a. [a] -> [a] -> [a]
++ FilePath
"Must download the following packages to proceed:\n"
forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> FilePath
prettyShow [PackageIdentifier]
notFetched)
forall a. [a] -> [a] -> [a]
++ FilePath
"\nTry using 'cabal fetch'."
where
nothingToInstall :: Bool
nothingToInstall = forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a b. (a, b) -> a
fst (forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> ([GenericReadyPackage srcpkg], Processing)
InstallPlan.ready InstallPlan
installPlan))
dryRun :: Bool
dryRun = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installDryRun InstallFlags
installFlags)
overrideReinstall :: Bool
overrideReinstall = 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]
(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 forall a. PackageIndex a -> PackageName -> [(Version, [a])]
PackageIndex.lookupPackageName InstalledPackageIndex
installedPkgIndex
(forall pkg. Package pkg => pkg -> PackageName
packageName GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
cpkg) of
[] -> PackageStatus
NewPackage
[(Version, [InstalledPackageInfo])]
ps -> case forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
cpkg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(Version, [InstalledPackageInfo])]
ps) of
[] -> [Version] -> PackageStatus
NewVersion (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Version, [InstalledPackageInfo])]
ps)
pkgs :: [InstalledPackageInfo]
pkgs@(InstalledPackageInfo
pkg:[InstalledPackageInfo]
_) -> [UnitId] -> [PackageChange] -> PackageStatus
Reinstall (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') = forall a. (a -> Bool) -> [a] -> [a]
filter forall {a}. Eq a => MergeResult a a -> Bool
changed forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
mergeBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing MungedPackageId -> MungedPackageName
mungedName)
([UnitId] -> [MungedPackageId]
resolveInstalledIds forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo -> [UnitId]
Installed.depends InstalledPackageInfo
pkg)
([UnitId] -> [MungedPackageId]
resolveInstalledIds forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => ComponentDeps a -> a
CD.nonSetupDeps (forall pkg. PackageFixedDeps pkg => pkg -> ComponentDeps [UnitId]
depends ConfiguredPackage UnresolvedPkgLoc
pkg'))
resolveInstalledIds :: [UnitId] -> [MungedPackageId]
resolveInstalledIds :: [UnitId] -> [MungedPackageId]
resolveInstalledIds =
forall a. Eq a => [a] -> [a]
nub
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. PackageIndex a -> UnitId -> Maybe a
PackageIndex.lookupUnitId InstalledPackageIndex
installedPkgIndex)
changed :: MergeResult a a -> Bool
changed (InBoth a
pkgid a
pkgid') = a
pkgid forall a. Eq a => a -> a -> Bool
/= a
pkgid'
changed MergeResult a a
_ = Bool
True
printPlan :: Bool
-> 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
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)]
pkgs
| Verbosity
verbosity forall a. Ord a => a -> a -> Bool
>= Verbosity
Verbosity.verbose -> Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines forall a b. (a -> b) -> a -> b
$
(FilePath
"In order, the following " forall a. [a] -> [a] -> [a]
++ FilePath
wouldWill forall a. [a] -> [a] -> [a]
++ FilePath
" be installed:")
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {loc}.
(GenericReadyPackage (ConfiguredPackage loc), PackageStatus)
-> FilePath
showPkgAndReason [(GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc),
PackageStatus)]
pkgs
| Bool
otherwise -> Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines forall a b. (a -> b) -> a -> b
$
(FilePath
"In order, the following " forall a. [a] -> [a] -> [a]
++ FilePath
wouldWill
forall a. [a] -> [a] -> [a]
++ FilePath
" be installed (use -v for more details):")
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map 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
_) = forall a. Pretty a => a -> FilePath
prettyShow (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId srcpkg
pkg) forall a. [a] -> [a] -> [a]
++
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
[ forall a. Pretty a => a -> FilePath
prettyShow (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ConfiguredPackage loc
pkg')
, forall srcpkg. Package srcpkg => srcpkg -> FilePath
showLatest ConfiguredPackage loc
pkg'
, FlagAssignment -> FilePath
showFlagAssignment (forall loc. ConfiguredPackage loc -> FlagAssignment
nonDefaultFlags ConfiguredPackage loc
pkg')
, OptionalStanzaSet -> FilePath
showStanzas (forall loc. ConfiguredPackage loc -> OptionalStanzaSet
confPkgStanzas ConfiguredPackage loc
pkg')
, 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)" forall a. [a] -> [a] -> [a]
++ case [PackageChange]
cs of
[] -> FilePath
""
[PackageChange]
diff -> FilePath
"(changes: " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Pretty a => MergeResult a MungedPackageId -> FilePath
change [PackageChange]
diff)
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 forall pkg. Package pkg => pkg -> Version
packageVersion srcpkg
pkg forall a. Ord a => a -> a -> Bool
< Version
latestVersion
then (FilePath
"(latest: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> FilePath
prettyShow Version
latestVersion forall a. [a] -> [a] -> [a]
++ FilePath
")")
else FilePath
""
Maybe Version
Nothing -> FilePath
""
where
mLatestVersion :: Maybe Version
mLatestVersion :: Maybe Version
mLatestVersion = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall pkg. Package pkg => pkg -> Version
packageVersion forall a b. (a -> b) -> a -> b
$
forall a. [a] -> Maybe a
safeLast forall a b. (a -> b) -> a -> b
$
forall pkg. Package pkg => PackageIndex pkg -> PackageName -> [pkg]
SourcePackageIndex.lookupPackageName
(SourcePackageDb -> PackageIndex (SourcePackage UnresolvedPkgLoc)
packageIndex SourcePackageDb
sourcePkgDb)
(forall pkg. Package pkg => pkg -> PackageName
packageName srcpkg
pkg)
toFlagAssignment :: [PackageFlag] -> FlagAssignment
toFlagAssignment :: [PackageFlag] -> FlagAssignment
toFlagAssignment = [(FlagName, Bool)] -> FlagAssignment
mkFlagAssignment forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (forall loc. SourcePackage loc -> GenericPackageDescription
SourcePackage.srcpkgDescription forall a b. (a -> b) -> a -> b
$
forall loc. ConfiguredPackage loc -> SourcePackage loc
confPkgSource ConfiguredPackage loc
cpkg))
in forall loc. ConfiguredPackage loc -> FlagAssignment
confPkgFlags ConfiguredPackage loc
cpkg FlagAssignment -> FlagAssignment -> FlagAssignment
`diffFlagAssignment` FlagAssignment
defaultAssignment
change :: MergeResult a MungedPackageId -> FilePath
change (OnlyInLeft a
pkgid) = forall a. Pretty a => a -> FilePath
prettyShow a
pkgid forall a. [a] -> [a] -> [a]
++ FilePath
" removed"
change (InBoth a
pkgid MungedPackageId
pkgid') = forall a. Pretty a => a -> FilePath
prettyShow a
pkgid forall a. [a] -> [a] -> [a]
++ FilePath
" -> "
forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> FilePath
prettyShow (MungedPackageId -> Version
mungedVersion MungedPackageId
pkgid')
change (OnlyInRight MungedPackageId
pkgid') = forall a. Pretty a => a -> FilePath
prettyShow MungedPackageId
pkgid' forall a. [a] -> [a] -> [a]
++ FilePath
" added"
showDep :: pkg -> FilePath
showDep pkg
pkg | Just [PackageIdentifier]
rdeps <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId pkg
pkg) Map PackageIdentifier [PackageIdentifier]
revDeps
= FilePath
" (via: " forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> FilePath
prettyShow [PackageIdentifier]
rdeps) forall a. [a] -> [a] -> [a]
++ FilePath
")"
| Bool
otherwise = FilePath
""
revDepGraphEdges :: [(PackageId, PackageId)]
revDepGraphEdges :: [(PackageIdentifier, PackageIdentifier)]
revDepGraphEdges = [ (PackageIdentifier
rpid, 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
_
<- forall a. Monoid a => ComponentDeps a -> a
CD.flatDeps (forall loc. ConfiguredPackage loc -> ComponentDeps [ConfiguredId]
confPkgDeps ConfiguredPackage UnresolvedPkgLoc
cpkg) ]
revDeps :: Map.Map PackageId [PackageId]
revDeps :: Map PackageIdentifier [PackageIdentifier]
revDeps = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[])) [(PackageIdentifier, PackageIdentifier)]
revDepGraphEdges)
reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String
-> IO ()
reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> FilePath -> IO ()
reportPlanningFailure Verbosity
verbosity
(PackageDBStack
_, RepoContext
_, Compiler
comp, Platform
platform, ProgramDb
_
,GlobalFlags
_, ConfigFlags
configFlags, ConfigExFlags
_, InstallFlags
installFlags, HaddockFlags
_, TestFlags
_, BenchmarkFlags
_)
(InstalledPackageIndex
_, SourcePackageDb
sourcePkgDb, PkgConfigDb
_, [UserTarget]
_, [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgSpecifiers, HttpTransport
_)
FilePath
message = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
reportFailure forall a b. (a -> b) -> a -> b
$ do
let pkgids :: [PackageIdentifier]
pkgids = forall a. (a -> Bool) -> [a] -> [a]
filter
(forall pkg.
Package pkg =>
PackageIndex pkg -> PackageIdentifier -> Bool
SourcePackageIndex.elemByPackageId (SourcePackageDb -> PackageIndex (SourcePackage UnresolvedPkgLoc)
packageIndex SourcePackageDb
sourcePkgDb)) forall a b. (a -> b) -> a -> b
$
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe 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)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(BuildReport, Maybe Repo)]
buildReports) forall a b. (a -> b) -> a -> b
$
Verbosity -> FilePath -> IO ()
info Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
FilePath
"Solver failure will be reported for "
forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"," (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> FilePath
prettyShow [PackageIdentifier]
pkgids)
CompilerInfo
-> [PathTemplate]
-> [(BuildReport, Maybe Repo)]
-> Platform
-> IO ()
BuildReports.storeLocal (Compiler -> CompilerInfo
compilerInfo Compiler
comp)
(forall a. NubList a -> [a]
fromNubList forall a b. (a -> b) -> a -> b
$ InstallFlags -> NubList PathTemplate
installSummaryFile InstallFlags
installFlags)
[(BuildReport, Maybe Repo)]
buildReports Platform
platform
case Maybe PathTemplate
logFile of
Maybe PathTemplate
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just PathTemplate
template -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [PackageIdentifier]
pkgids forall a b. (a -> b) -> a -> b
$ \PackageIdentifier
pkgid ->
let env :: PathTemplateEnv
env = PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv PackageIdentifier
pkgid forall {a}. a
dummyIpid
(Compiler -> CompilerInfo
compilerInfo Compiler
comp) Platform
platform
path :: FilePath
path = PathTemplate -> FilePath
fromPathTemplate 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 = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installReportPlanningFailure InstallFlags
installFlags)
logFile :: Maybe PathTemplate
logFile = forall a. Flag a -> Maybe a
flagToMaybe (InstallFlags -> Flag PathTemplate
installLogFile InstallFlags
installFlags)
dummyIpid :: a
dummyIpid = forall a. HasCallStack => FilePath -> a
error FilePath
"reportPlanningFailure: installed package ID not available"
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VersionRange -> Maybe Version
trivialRange VersionRange
version
NamedPackage PackageName
_ [PackageProperty]
_ -> forall a. Maybe a
Nothing
SpecificSourcePackage pkg
pkg -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall pkg. Package pkg => pkg -> PackageIdentifier
packageId pkg
pkg
where
trivialRange :: VersionRange -> Maybe Version
trivialRange :: VersionRange -> Maybe Version
trivialRange = forall a.
a
-> (Version -> a)
-> (Version -> a)
-> (Version -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> VersionRange
-> a
foldVersionRange
forall a. Maybe a
Nothing
forall a. a -> Maybe a
Just
(\Version
_ -> forall a. Maybe a
Nothing)
(\Version
_ -> forall a. Maybe a
Nothing)
(\Maybe Version
_ Maybe Version
_ -> forall a. Maybe a
Nothing)
(\Maybe Version
_ Maybe Version
_ -> forall a. Maybe a
Nothing)
postInstallActions :: Verbosity
-> InstallArgs
-> [UserTarget]
-> InstallPlan
-> BuildOutcomes
-> IO ()
postInstallActions :: Verbosity
-> InstallArgs
-> [UserTarget]
-> InstallPlan
-> BuildOutcomes
-> IO ()
postInstallActions Verbosity
verbosity
(PackageDBStack
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)
(forall a. NubList a -> [a]
fromNubList forall a b. (a -> b) -> a -> b
$ InstallFlags -> NubList PathTemplate
installSummaryFile InstallFlags
installFlags)
[(BuildReport, Maybe Repo)]
buildReports
Platform
platform
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReportLevel
reportingLevel forall a. Ord a => a -> a -> Bool
>= ReportLevel
AnonymousReports) forall a b. (a -> b) -> a -> b
$
[(BuildReport, Maybe Repo)] -> IO ()
BuildReports.storeAnonymous [(BuildReport, Maybe Repo)]
buildReports
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReportLevel
reportingLevel forall a. Eq a => a -> a -> Bool
== ReportLevel
DetailedReports) forall a b. (a -> b) -> a -> b
$
Verbosity -> FilePath -> [(BuildReport, Maybe Repo)] -> IO ()
storeDetailedBuildReports Verbosity
verbosity FilePath
logsDir [(BuildReport, Maybe Repo)]
buildReports
Verbosity
-> PackageDBStack
-> Compiler
-> Platform
-> ProgramDb
-> ConfigFlags
-> InstallFlags
-> BuildOutcomes
-> IO ()
regenerateHaddockIndex Verbosity
verbosity PackageDBStack
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 = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag ReportLevel
installBuildReports InstallFlags
installFlags)
logsDir :: FilePath
logsDir = 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 = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
[ do FilePath
allReportsDir <- IO FilePath
defaultReportsDir
let logFileName :: FilePath
logFileName = 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
</> FilePath
logFileName
reportsDir :: FilePath
reportsDir = FilePath
allReportsDir FilePath -> FilePath -> FilePath
</> RepoName -> FilePath
unRepoName (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
remoteRepo)
reportFile :: FilePath
reportFile = FilePath
reportsDir FilePath -> FilePath -> FilePath
</> FilePath
logFileName
IO () -> IO ()
handleMissingLogFile forall a b. (a -> b) -> a -> b
$ do
FilePath
buildLog <- FilePath -> IO FilePath
readFile FilePath
logFile
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
reportsDir
FilePath -> FilePath -> IO ()
writeFile FilePath
reportFile (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 = forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
Exception.handleJust IOException -> Maybe IOException
missingFile forall a b. (a -> b) -> a -> b
$ \IOException
ioe ->
Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Missing log file for build report: "
forall a. [a] -> [a] -> [a]
++ 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 = forall a. a -> Maybe a
Just IOException
ioe
missingFile IOException
_ = forall a. Maybe a
Nothing
regenerateHaddockIndex :: Verbosity
-> [PackageDB]
-> Compiler
-> Platform
-> ProgramDb
-> ConfigFlags
-> InstallFlags
-> BuildOutcomes
-> IO ()
regenerateHaddockIndex :: Verbosity
-> PackageDBStack
-> Compiler
-> Platform
-> ProgramDb
-> ConfigFlags
-> InstallFlags
-> BuildOutcomes
-> IO ()
regenerateHaddockIndex Verbosity
verbosity PackageDBStack
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)
(forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags))
Bool
True
let indexFileTemplate :: PathTemplate
indexFileTemplate = 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 forall a b. (a -> b) -> a -> b
$
FilePath
"Updating documentation index " forall a. [a] -> [a] -> [a]
++ FilePath
indexFile
InstalledPackageIndex
installedPkgIndex <- Verbosity
-> Compiler
-> PackageDBStack
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
comp PackageDBStack
packageDBs ProgramDb
progdb
Verbosity
-> InstalledPackageIndex -> ProgramDb -> FilePath -> IO ()
Haddock.regenerateHaddockIndex Verbosity
verbosity InstalledPackageIndex
installedPkgIndex ProgramDb
progdb FilePath
indexFile
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
haddockIndexFileIsRequested :: Bool
haddockIndexFileIsRequested =
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installDocumentation InstallFlags
installFlags)
Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust (forall a. Flag a -> Maybe a
flagToMaybe (InstallFlags -> Flag PathTemplate
installHaddockIndex InstallFlags
installFlags))
shouldRegenerateHaddockIndex :: Bool
shouldRegenerateHaddockIndex = Bool
normalUserInstall Bool -> Bool -> Bool
&& forall {k} {a}. Map k (Either a BuildResult) -> Bool
someDocsWereInstalled BuildOutcomes
buildOutcomes
where
someDocsWereInstalled :: Map k (Either a BuildResult) -> Bool
someDocsWereInstalled = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall {a}. Either a BuildResult -> Bool
installedDocs forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = (PackageDB
UserPackageDB forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` PackageDBStack
packageDBs)
Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDB -> Bool
isSpecificPackageDB) PackageDBStack
packageDBs
isSpecificPackageDB :: PackageDB -> Bool
isSpecificPackageDB (SpecificPackageDB FilePath
_) = Bool
True
isSpecificPackageDB PackageDB
_ = Bool
False
substHaddockIndexFileName :: InstallDirTemplates -> PathTemplate -> FilePath
substHaddockIndexFileName InstallDirTemplates
defaultDirs = PathTemplate -> FilePath
fromPathTemplate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate PathTemplateEnv
env
where
env :: PathTemplateEnv
env = PathTemplateEnv
env0 forall a. [a] -> [a] -> [a]
++ InstallDirTemplates -> PathTemplateEnv
installDirsTemplateEnv InstallDirTemplates
absoluteDirs
env0 :: PathTemplateEnv
env0 = CompilerInfo -> PathTemplateEnv
InstallDirs.compilerTemplateEnv (Compiler -> CompilerInfo
compilerInfo Compiler
comp)
forall a. [a] -> [a] -> [a]
++ Platform -> PathTemplateEnv
InstallDirs.platformTemplateEnv Platform
platform
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 = forall a b c.
(a -> b -> c) -> InstallDirs a -> InstallDirs b -> InstallDirs c
InstallDirs.combineInstallDirs 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
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[(PackageIdentifier
_, UnqualComponentName
exe, FilePath
path)] ->
Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
FilePath
"could not create a symlink in " forall a. [a] -> [a] -> [a]
++ FilePath
bindir forall a. [a] -> [a] -> [a]
++ FilePath
" for "
forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> FilePath
prettyShow UnqualComponentName
exe forall a. [a] -> [a] -> [a]
++ FilePath
" because the file exists there already but is not "
forall a. [a] -> [a] -> [a]
++ FilePath
"managed by cabal. You can create a symlink for this executable "
forall a. [a] -> [a] -> [a]
++ FilePath
"manually if you wish. The executable file has been installed at "
forall a. [a] -> [a] -> [a]
++ FilePath
path
[(PackageIdentifier, UnqualComponentName, FilePath)]
exes ->
Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
FilePath
"could not create symlinks in " forall a. [a] -> [a] -> [a]
++ FilePath
bindir forall a. [a] -> [a] -> [a]
++ FilePath
" for "
forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " [ forall a. Pretty a => a -> FilePath
prettyShow UnqualComponentName
exe | (PackageIdentifier
_, UnqualComponentName
exe, FilePath
_) <- [(PackageIdentifier, UnqualComponentName, FilePath)]
exes ]
forall a. [a] -> [a] -> [a]
++ FilePath
" because the files exist there already and are not "
forall a. [a] -> [a] -> [a]
++ FilePath
"managed by cabal. You can create symlinks for these executables "
forall a. [a] -> [a] -> [a]
++ FilePath
"manually if you wish. The executable files have been installed at "
forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " [ FilePath
path | (PackageIdentifier
_, UnqualComponentName
_, FilePath
path) <- [(PackageIdentifier, UnqualComponentName, FilePath)]
exes ]
where
bindir :: FilePath
bindir = 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) <- forall k a. Map k a -> [(k, a)]
Map.toList BuildOutcomes
buildOutcomes ] of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[(UnitId, BuildFailure)]
failed -> forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unlines
forall a b. (a -> b) -> a -> b
$ FilePath
"Some packages failed to install:"
forall a. a -> [a] -> [a]
: [ forall a. Pretty a => a -> FilePath
prettyShow UnitId
pkgid forall a. [a] -> [a] -> [a]
++ BuildFailure -> FilePath
printFailureReason BuildFailure
reason
| (UnitId
pkgid, BuildFailure
reason) <- [(UnitId, BuildFailure)]
failed ]
where
printFailureReason :: BuildFailure -> FilePath
printFailureReason BuildFailure
reason = case BuildFailure
reason of
DependentFailed PackageIdentifier
pkgid -> FilePath
" depends on " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgid
forall a. [a] -> [a] -> [a]
++ FilePath
" which failed to install."
DownloadFailed SomeException
e -> FilePath
" failed while downloading the package."
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
showException SomeException
e
UnpackFailed SomeException
e -> FilePath
" failed while unpacking the package."
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
showException SomeException
e
ConfigureFailed SomeException
e -> FilePath
" failed during the configure step."
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
showException SomeException
e
BuildFailed SomeException
e -> FilePath
" failed during the building phase."
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
showException SomeException
e
TestsFailed SomeException
e -> FilePath
" failed during the tests phase."
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
showException SomeException
e
InstallFailed SomeException
e -> FilePath
" failed during the final install step."
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
showException SomeException
e
BuildFailure
PlanningFailed -> FilePath
" failed during the planning phase."
showException :: SomeException -> FilePath
showException SomeException
e = FilePath
" The exception was:\n " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show SomeException
e forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
maybeOOM SomeException
e
#ifdef mingw32_HOST_OS
maybeOOM _ = ""
#else
maybeOOM :: SomeException -> FilePath
maybeOOM SomeException
e = forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" ExitCode -> FilePath
onExitFailure (forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e)
onExitFailure :: ExitCode -> FilePath
onExitFailure (ExitFailure Int
n)
| Int
n forall a. Eq a => a -> a -> Bool
== Int
9 Bool -> Bool -> Bool
|| Int
n forall a. Eq a => a -> a -> Bool
== -Int
9 =
FilePath
"\nThis may be due to an out-of-memory condition."
onExitFailure ExitCode
_ = FilePath
""
#endif
data InstallMisc = InstallMisc {
InstallMisc -> Maybe Version
libVersion :: Maybe Version
}
type UseLogFile = Maybe (PackageIdentifier -> UnitId -> FilePath, Verbosity)
performInstallations :: Verbosity
-> InstallArgs
-> InstalledPackageIndex
-> InstallPlan
-> IO BuildOutcomes
performInstallations :: Verbosity
-> InstallArgs
-> InstalledPackageIndex
-> InstallPlan
-> IO BuildOutcomes
performInstallations Verbosity
verbosity
(PackageDBStack
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 forall a b. (a -> b) -> a -> b
$ FilePath
"Number of threads used: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> FilePath
show Int
numJobs) forall a. [a] -> [a] -> [a]
++ FilePath
"."
JobControl IO (UnitId, BuildOutcome)
jobControl <- if Bool
parallelInstall then forall a. WithCallStack (Int -> IO (JobControl IO a))
newParallelJobControl Int
numJobs
else forall a. IO (JobControl IO a)
newSerialJobControl
JobLimit
fetchLimit <- Int -> IO JobLimit
newJobLimit (forall a. Ord a => a -> a -> a
min Int
numJobs Int
numFetchJobs)
Lock
installLock <- IO Lock
newLock
Lock
cacheLock <- IO Lock
newLock
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 forall a b. (a -> b) -> a -> b
$ \GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg ->
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 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 forall a b. (a -> b) -> a -> b
$ \ResolvedPkgLoc
src' ->
Verbosity
-> PackageIdentifier
-> ResolvedPkgLoc
-> FilePath
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
installLocalPackage Verbosity
verbosity (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg) ResolvedPkgLoc
src' FilePath
distPref 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 forall a. Ord a => a -> a -> Bool
>= Int
2
keepGoing :: Bool
keepGoing = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installKeepGoing InstallFlags
installFlags)
distPref :: FilePath
distPref = forall a. a -> Flag a -> a
fromFlagOrDefault (SetupScriptOptions -> FilePath
useDistPref SetupScriptOptions
defaultSetupScriptOptions)
(ConfigFlags -> Flag FilePath
configDistPref ConfigFlags
configFlags)
setupScriptOptions :: InstalledPackageIndex
-> Lock
-> GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
-> SetupScriptOptions
setupScriptOptions InstalledPackageIndex
index Lock
lock GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg =
PackageDBStack
-> Compiler
-> Platform
-> ProgramDb
-> FilePath
-> VersionRange
-> Maybe Lock
-> Bool
-> InstalledPackageIndex
-> Maybe (GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc))
-> SetupScriptOptions
configureSetupScript
PackageDBStack
packageDBs
Compiler
comp
Platform
platform
ProgramDb
progdb
FilePath
distPref
(ConfigExFlags -> Maybe Version -> VersionRange
chooseCabalVersion ConfigExFlags
configExFlags (InstallMisc -> Maybe Version
libVersion InstallMisc
miscOptions))
(forall a. a -> Maybe a
Just Lock
lock)
Bool
parallelInstall
InstalledPackageIndex
index
(forall a. a -> Maybe a
Just GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
rpkg)
reportingLevel :: ReportLevel
reportingLevel = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag ReportLevel
installBuildReports InstallFlags
installFlags)
logsDir :: FilePath
logsDir = forall a. WithCallStack (Flag a -> a)
fromFlag (GlobalFlags -> Flag FilePath
globalLogsDir GlobalFlags
globalFlags)
useLogFile :: UseLogFile
useLogFile :: UseLogFile
useLogFile = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((\PackageIdentifier -> UnitId -> FilePath
f -> (PackageIdentifier -> UnitId -> FilePath
f, Verbosity
loggingVerbosity)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplate -> PackageIdentifier -> UnitId -> FilePath
substLogFileName)
Maybe PathTemplate
logFileTemplate
where
installLogFile' :: Maybe PathTemplate
installLogFile' = forall a. Flag a -> Maybe a
flagToMaybe forall a b. (a -> b) -> a -> b
$ InstallFlags -> Flag PathTemplate
installLogFile InstallFlags
installFlags
defaultTemplate :: PathTemplate
defaultTemplate = FilePath -> PathTemplate
toPathTemplate forall a b. (a -> b) -> a -> b
$
FilePath
logsDir FilePath -> FilePath -> FilePath
</> FilePath
"$compiler" FilePath -> FilePath -> FilePath
</> FilePath
"$libname" FilePath -> FilePath -> FilePath
<.> FilePath
"log"
logFileTemplate :: Maybe PathTemplate
logFileTemplate :: Maybe PathTemplate
logFileTemplate
| Bool
useDefaultTemplate = forall a. a -> Maybe a
Just PathTemplate
defaultTemplate
| Bool
otherwise = Maybe PathTemplate
installLogFile'
loggingVerbosity :: Verbosity
loggingVerbosity :: Verbosity
loggingVerbosity | Bool
overrideVerbosity = (Verbosity -> Verbosity) -> Verbosity -> Verbosity
modifyVerbosity (forall a. Ord a => a -> a -> a
max Verbosity
verbose) Verbosity
verbosity
| Bool
otherwise = Verbosity
verbosity
useDefaultTemplate :: Bool
useDefaultTemplate :: Bool
useDefaultTemplate
| ReportLevel
reportingLevel forall a. Eq a => a -> a -> Bool
== ReportLevel
DetailedReports = Bool
True
| 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 forall a. Eq a => a -> a -> Bool
== ReportLevel
DetailedReports = Bool
True
| 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
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate PathTemplateEnv
env
forall a b. (a -> b) -> a -> b
$ PathTemplate
template
where env :: PathTemplateEnv
env = PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv (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 = 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 =
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 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 (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
pkg) (forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
pkg) BuildOutcome
buildOutcome
forall (m :: * -> *) a. Monad m => a -> m a
return BuildOutcome
buildOutcome
where
depsFailure :: ConfiguredPackage UnresolvedPkgLoc -> BuildFailure
depsFailure = PackageIdentifier -> BuildFailure
DependentFailed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. Package pkg => pkg -> PackageIdentifier
packageId
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 (forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgid)
(Left BuildFailure
_) -> do
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to install " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgid
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity forall a. Ord a => a -> a -> Bool
>= Verbosity
normal) forall a b. (a -> b) -> a -> b
$
case UseLogFile
useLogFile of
UseLogFile
Nothing -> 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 forall a b. (a -> b) -> a -> b
$ FilePath
"Build log ( " forall a. [a] -> [a] -> [a]
++ FilePath
logName 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> IO ()
putStr
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 :: Flag FilePath
configIPID = forall a. a -> Flag a
toFlag (forall a. Pretty a => a -> FilePath
prettyShow ComponentId
ipid),
configConfigurationsFlags :: FlagAssignment
configConfigurationsFlags = FlagAssignment
flags,
configConstraints :: [PackageVersionConstraint]
configConstraints = [ PackageIdentifier -> PackageVersionConstraint
thisPackageVersionConstraint PackageIdentifier
srcid
| ConfiguredId
PackageIdentifier
srcid
(Just
(PackageDescription.CLibName
LibraryName
PackageDescription.LMainLibName))
ComponentId
_ipid
<- forall a. Monoid a => ComponentDeps a -> a
CD.nonSetupDeps ComponentDeps [ConfiguredId]
deps ],
configDependencies :: [GivenComponent]
configDependencies = [ PackageName -> LibraryName -> ComponentId -> GivenComponent
GivenComponent (forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
srcid) LibraryName
cname ComponentId
dep_ipid
| ConfiguredId PackageIdentifier
srcid (Just (PackageDescription.CLibName LibraryName
cname)) ComponentId
dep_ipid
<- forall a. Monoid a => ComponentDeps a -> a
CD.nonSetupDeps ComponentDeps [ConfiguredId]
deps ],
configExactConfiguration :: Flag Bool
configExactConfiguration = forall a. a -> Flag a
toFlag Bool
True,
configBenchmarks :: Flag Bool
configBenchmarks = forall a. a -> Flag a
toFlag Bool
False,
configTests :: Flag Bool
configTests = forall a. a -> Flag a
toFlag (OptionalStanza
TestStanzas OptionalStanza -> OptionalStanzaSet -> Bool
`optStanzaSetMember` OptionalStanzaSet
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)
(forall a b. a -> b -> a
const Bool
True)
Platform
platform CompilerInfo
cinfo [] GenericPackageDescription
gpkg of
Left [Dependency]
_ -> 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 forall a b. (a -> b) -> a -> b
$ do
ResolvedPkgLoc
loc <- forall a. JobLimit -> IO a -> IO a
withJobLimit JobLimit
fetchLimit 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 -> FilePath
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
installLocalPackage :: Verbosity
-> PackageIdentifier
-> ResolvedPkgLoc
-> FilePath
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
installLocalPackage Verbosity
verbosity PackageIdentifier
pkgid ResolvedPkgLoc
location FilePath
distPref Maybe FilePath -> IO BuildOutcome
installPkg =
case ResolvedPkgLoc
location of
LocalUnpackedPackage FilePath
dir ->
Maybe FilePath -> IO BuildOutcome
installPkg (forall a. a -> Maybe a
Just FilePath
dir)
RemoteSourceRepoPackage SourceRepoMaybe
_repo FilePath
dir ->
Maybe FilePath -> IO BuildOutcome
installPkg (forall a. a -> Maybe a
Just FilePath
dir)
LocalTarballPackage FilePath
tarballPath ->
Verbosity
-> PackageIdentifier
-> FilePath
-> FilePath
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
installLocalTarballPackage Verbosity
verbosity
PackageIdentifier
pkgid FilePath
tarballPath FilePath
distPref Maybe FilePath -> IO BuildOutcome
installPkg
RemoteTarballPackage URI
_ FilePath
tarballPath ->
Verbosity
-> PackageIdentifier
-> FilePath
-> FilePath
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
installLocalTarballPackage Verbosity
verbosity
PackageIdentifier
pkgid FilePath
tarballPath FilePath
distPref Maybe FilePath -> IO BuildOutcome
installPkg
RepoTarballPackage Repo
_ PackageIdentifier
_ FilePath
tarballPath ->
Verbosity
-> PackageIdentifier
-> FilePath
-> FilePath
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
installLocalTarballPackage Verbosity
verbosity
PackageIdentifier
pkgid FilePath
tarballPath FilePath
distPref Maybe FilePath -> IO BuildOutcome
installPkg
installLocalTarballPackage
:: Verbosity
-> PackageIdentifier -> FilePath -> FilePath
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
installLocalTarballPackage :: Verbosity
-> PackageIdentifier
-> FilePath
-> FilePath
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
installLocalTarballPackage Verbosity
verbosity PackageIdentifier
pkgid
FilePath
tarballPath FilePath
distPref Maybe FilePath -> IO BuildOutcome
installPkg = do
FilePath
tmp <- IO FilePath
getTemporaryDirectory
forall a.
Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory Verbosity
verbosity FilePath
tmp FilePath
"cabal-tmp" forall a b. (a -> b) -> a -> b
$ \FilePath
tmpDirPath ->
(SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
UnpackFailed forall a b. (a -> b) -> a -> b
$ do
let relUnpackedPath :: FilePath
relUnpackedPath = forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgid
absUnpackedPath :: FilePath
absUnpackedPath = FilePath
tmpDirPath FilePath -> FilePath -> FilePath
</> FilePath
relUnpackedPath
descFilePath :: FilePath
descFilePath = FilePath
absUnpackedPath
FilePath -> FilePath -> FilePath
</> forall a. Pretty a => a -> FilePath
prettyShow (forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgid) FilePath -> FilePath -> FilePath
<.> FilePath
"cabal"
Verbosity -> FilePath -> IO ()
info Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Extracting " forall a. [a] -> [a] -> [a]
++ FilePath
tarballPath
forall a. [a] -> [a] -> [a]
++ FilePath
" to " forall a. [a] -> [a] -> [a]
++ FilePath
tmpDirPath 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Package .cabal file not found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show FilePath
descFilePath
FilePath -> IO ()
maybeRenameDistDir FilePath
absUnpackedPath
Maybe FilePath -> IO BuildOutcome
installPkg (forall a. a -> Maybe a
Just FilePath
absUnpackedPath)
where
maybeRenameDistDir :: FilePath -> IO ()
maybeRenameDistDir :: FilePath -> IO ()
maybeRenameDistDir FilePath
absUnpackedPath = do
let distDirPath :: FilePath
distDirPath = FilePath
absUnpackedPath FilePath -> FilePath -> FilePath
</> FilePath
defaultDistPref
distDirPathTmp :: FilePath
distDirPathTmp = FilePath
absUnpackedPath FilePath -> FilePath -> FilePath
</> (FilePath
defaultDistPref forall a. [a] -> [a] -> [a]
++ FilePath
"-tmp")
distDirPathNew :: FilePath
distDirPathNew = FilePath
absUnpackedPath FilePath -> FilePath -> FilePath
</> FilePath
distPref
Bool
distDirExists <- FilePath -> IO Bool
doesDirectoryExist FilePath
distDirPath
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
distDirExists
Bool -> Bool -> Bool
&& (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ FilePath
distDirPath FilePath -> FilePath -> Bool
`equalFilePath` FilePath
distDirPathNew)) forall a b. (a -> b) -> a -> b
$ do
Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Renaming '" forall a. [a] -> [a] -> [a]
++ FilePath
distDirPath forall a. [a] -> [a] -> [a]
++ FilePath
"' to '"
forall a. [a] -> [a] -> [a]
++ FilePath
distDirPathTmp forall a. [a] -> [a] -> [a]
++ FilePath
"'."
FilePath -> FilePath -> IO ()
renameDirectory FilePath
distDirPath FilePath
distDirPathTmp
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
distDirPath forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
distDirPathNew) forall a b. (a -> b) -> a -> b
$
Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
False FilePath
distDirPath
Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Renaming '" forall a. [a] -> [a] -> [a]
++ FilePath
distDirPathTmp forall a. [a] -> [a] -> [a]
++ FilePath
"' to '"
forall a. [a] -> [a] -> [a]
++ FilePath
distDirPathNew 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
-> UseLogFile
-> 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
case PackageDescriptionOverride
pkgoverride of
PackageDescriptionOverride
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ByteString
pkgtxt -> do
let descFilePath :: FilePath
descFilePath = forall a. a -> Maybe a -> a
fromMaybe FilePath
"." Maybe FilePath
workingDir
FilePath -> FilePath -> FilePath
</> forall a. Pretty a => a -> FilePath
prettyShow (forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgid) FilePath -> FilePath -> FilePath
<.> FilePath
"cabal"
Verbosity -> FilePath -> IO ()
info Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
FilePath
"Updating " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> FilePath
prettyShow (forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgid) FilePath -> FilePath -> FilePath
<.> FilePath
"cabal"
forall a. [a] -> [a] -> [a]
++ FilePath
" with the latest revision from the index."
FilePath -> ByteString -> IO ()
writeFileAtomic FilePath
descFilePath ByteString
pkgtxt
ConfigFlags
configFlags' <- ConfigFlags -> IO ConfigFlags
addDefaultInstallDirs ConfigFlags
configFlags
let configureFlags :: Version -> ConfigFlags
configureFlags :: Version -> ConfigFlags
configureFlags = ConfigFlags -> Version -> ConfigFlags
filterConfigureFlags ConfigFlags
configFlags' {
configVerbosity :: Flag Verbosity
configVerbosity = forall a. a -> Flag a
toFlag Verbosity
verbosity'
}
Maybe FilePath
mLogPath <- IO (Maybe FilePath)
maybeLogPath
forall a. (FilePath -> IO ()) -> Maybe FilePath -> IO a -> IO a
logDirChange (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())) FilePath -> FilePath -> IO ()
appendFile Maybe FilePath
mLogPath) Maybe FilePath
workingDir forall a b. (a -> b) -> a -> b
$ do
(SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
ConfigureFailed forall a b. (a -> b) -> a -> b
$ do
ProgressPhase -> IO ()
noticeProgress ProgressPhase
ProgressStarting
forall {flags}.
CommandUI flags -> (Version -> flags) -> Maybe FilePath -> IO ()
setup CommandUI ConfigFlags
configureCommand Version -> ConfigFlags
configureFlags Maybe FilePath
mLogPath
(SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
BuildFailed forall a b. (a -> b) -> a -> b
$ do
ProgressPhase -> IO ()
noticeProgress ProgressPhase
ProgressBuilding
forall {flags}.
CommandUI flags -> (Version -> flags) -> Maybe FilePath -> IO ()
setup CommandUI BuildFlags
buildCommand' forall {p}. p -> BuildFlags
buildFlags Maybe FilePath
mLogPath
DocsResult
docsResult <- if Bool
shouldHaddock
then (do forall {flags}.
CommandUI flags -> (Version -> flags) -> Maybe FilePath -> IO ()
setup CommandUI HaddockFlags
haddockCommand forall {p}. p -> HaddockFlags
haddockFlags' Maybe FilePath
mLogPath
forall (m :: * -> *) a. Monad m => a -> m a
return DocsResult
DocsOk)
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` (\IOException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return DocsResult
DocsFailed)
forall a. IO a -> (ExitCode -> IO a) -> IO a
`catchExit` (\ExitCode
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return DocsResult
DocsFailed)
else forall (m :: * -> *) a. Monad m => a -> m a
return DocsResult
DocsNotTried
(SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
TestsFailed forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
testsEnabled Bool -> Bool -> Bool
&& PackageDescription -> Bool
PackageDescription.hasTests PackageDescription
pkg) forall a b. (a -> b) -> a -> b
$
forall {flags}.
CommandUI flags -> (Version -> flags) -> Maybe FilePath -> IO ()
setup CommandUI TestFlags
Cabal.testCommand Version -> TestFlags
testFlags' Maybe FilePath
mLogPath
let testsResult :: TestsResult
testsResult | Bool
testsEnabled = TestsResult
TestsOk
| Bool
otherwise = TestsResult
TestsNotTried
(SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
InstallFailed forall a b. (a -> b) -> a -> b
$ forall a. Lock -> IO a -> IO a
criticalSection Lock
installLock forall a b. (a -> b) -> a -> b
$ do
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 forall a b. (a -> b) -> a -> b
$ do
forall {flags}.
CommandUI flags -> (Version -> flags) -> Maybe FilePath -> IO ()
setup CommandUI CopyFlags
Cabal.copyCommand forall {p}. p -> CopyFlags
copyFlags Maybe FilePath
mLogPath
[InstalledPackageInfo]
ipkgs <- Maybe FilePath -> IO [InstalledPackageInfo]
genPkgConfs Maybe FilePath
mLogPath
let ipkgs' :: [InstalledPackageInfo]
ipkgs' = case [InstalledPackageInfo]
ipkgs of
[InstalledPackageInfo
ipkg] -> [InstalledPackageInfo
ipkg { installedUnitId :: UnitId
Installed.installedUnitId = UnitId
uid }]
[InstalledPackageInfo]
_ -> [InstalledPackageInfo]
ipkgs
let packageDBs :: PackageDBStack
packageDBs = Bool -> [Maybe PackageDB] -> PackageDBStack
interpretPackageDbFlags
(forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags))
(ConfigFlags -> [Maybe PackageDB]
configPackageDBs ConfigFlags
configFlags)
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [InstalledPackageInfo]
ipkgs' forall a b. (a -> b) -> a -> b
$ \InstalledPackageInfo
ipkg' ->
Verbosity
-> Compiler
-> ProgramDb
-> PackageDBStack
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
registerPackage Verbosity
verbosity Compiler
comp ProgramDb
progdb
PackageDBStack
packageDBs InstalledPackageInfo
ipkg'
RegisterOptions
defaultRegisterOptions
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (DocsResult
-> TestsResult -> Maybe InstalledPackageInfo -> BuildResult
BuildResult DocsResult
docsResult TestsResult
testsResult (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
==UnitId
uid)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId) [InstalledPackageInfo]
ipkgs')))
where
pkgid :: PackageIdentifier
pkgid = forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg
uid :: UnitId
uid = 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 = forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgid
isParallelBuild :: Bool
isParallelBuild = Int
numJobs forall a. Ord a => a -> a -> Bool
>= Int
2
noticeProgress :: ProgressPhase -> IO ()
noticeProgress ProgressPhase
phase = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isParallelBuild forall a b. (a -> b) -> a -> b
$
Verbosity -> ProgressPhase -> FilePath -> IO ()
progressMessage Verbosity
verbosity ProgressPhase
phase FilePath
dispname
buildFlags :: p -> BuildFlags
buildFlags p
_ = BuildFlags
emptyBuildFlags {
buildDistPref :: Flag FilePath
buildDistPref = ConfigFlags -> Flag FilePath
configDistPref ConfigFlags
configFlags,
buildVerbosity :: Flag Verbosity
buildVerbosity = forall a. a -> Flag a
toFlag Verbosity
verbosity'
}
shouldHaddock :: Bool
shouldHaddock = forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Bool
installDocumentation InstallFlags
installFlags)
haddockFlags' :: p -> HaddockFlags
haddockFlags' p
_ = HaddockFlags
haddockFlags {
haddockVerbosity :: Flag Verbosity
haddockVerbosity = forall a. a -> Flag a
toFlag Verbosity
verbosity',
haddockDistPref :: Flag FilePath
haddockDistPref = ConfigFlags -> Flag FilePath
configDistPref ConfigFlags
configFlags
}
testsEnabled :: Bool
testsEnabled = forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Bool
configTests ConfigFlags
configFlags)
Bool -> Bool -> Bool
&& forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (InstallFlags -> Flag Bool
installRunTests InstallFlags
installFlags)
testFlags' :: Version -> TestFlags
testFlags' = TestFlags -> Version -> TestFlags
filterTestFlags TestFlags
testFlags {
testDistPref :: Flag FilePath
Cabal.testDistPref = ConfigFlags -> Flag FilePath
configDistPref ConfigFlags
configFlags
}
copyFlags :: p -> CopyFlags
copyFlags p
_ = CopyFlags
Cabal.emptyCopyFlags {
copyDistPref :: Flag FilePath
Cabal.copyDistPref = ConfigFlags -> Flag FilePath
configDistPref ConfigFlags
configFlags,
copyDest :: Flag CopyDest
Cabal.copyDest = forall a. a -> Flag a
toFlag CopyDest
InstallDirs.NoCopyDest,
copyVerbosity :: Flag Verbosity
Cabal.copyVerbosity = forall a. a -> Flag a
toFlag Verbosity
verbosity'
}
shouldRegister :: Bool
shouldRegister = PackageDescription -> Bool
PackageDescription.hasLibs PackageDescription
pkg
registerFlags :: p -> RegisterFlags
registerFlags p
_ = RegisterFlags
Cabal.emptyRegisterFlags {
regDistPref :: Flag FilePath
Cabal.regDistPref = ConfigFlags -> Flag FilePath
configDistPref ConfigFlags
configFlags,
regVerbosity :: Flag Verbosity
Cabal.regVerbosity = forall a. a -> Flag a
toFlag Verbosity
verbosity'
}
verbosity' :: Verbosity
verbosity' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Verbosity
verbosity forall a b. (a, b) -> b
snd UseLogFile
useLogFile
tempTemplate :: FilePath -> FilePath
tempTemplate FilePath
name = FilePath
name forall a. [a] -> [a] -> [a]
++ FilePath
"-" forall a. [a] -> [a] -> [a]
++ 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ConfigFlags
configFlags' {
configInstallDirs :: InstallDirs (Flag PathTemplate)
configInstallDirs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Flag a
Cabal.Flag forall b c a. (b -> c) -> (a -> b) -> a -> c
.
PathTemplateEnv -> InstallDirTemplates -> InstallDirTemplates
InstallDirs.substituteInstallDirTemplates PathTemplateEnv
env forall a b. (a -> b) -> a -> b
$
forall a b c.
(a -> b -> c) -> InstallDirs a -> InstallDirs b -> InstallDirs c
InstallDirs.combineInstallDirs forall a. a -> Flag a -> a
fromFlagOrDefault
InstallDirTemplates
defInstallDirs (ConfigFlags -> InstallDirs (Flag PathTemplate)
configInstallDirs ConfigFlags
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 = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
defaultUserInstall
(ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags')
genPkgConfs :: Maybe FilePath
-> IO [Installed.InstalledPackageInfo]
genPkgConfs :: Maybe FilePath -> IO [InstalledPackageInfo]
genPkgConfs Maybe FilePath
mLogPath =
if Bool
shouldRegister then do
FilePath
tmp <- IO FilePath
getTemporaryDirectory
forall a.
Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory Verbosity
verbosity FilePath
tmp (FilePath -> FilePath
tempTemplate FilePath
"pkgConf") forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
let pkgConfDest :: FilePath
pkgConfDest = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"pkgConf"
registerFlags' :: p -> RegisterFlags
registerFlags' p
version = (forall {p}. p -> RegisterFlags
registerFlags p
version) {
regGenPkgConf :: Flag (Maybe FilePath)
Cabal.regGenPkgConf = forall a. a -> Flag a
toFlag (forall a. a -> Maybe a
Just FilePath
pkgConfDest)
}
forall {flags}.
CommandUI flags -> (Version -> flags) -> Maybe FilePath -> IO ()
setup CommandUI RegisterFlags
Cabal.registerCommand forall {p}. p -> RegisterFlags
registerFlags' Maybe FilePath
mLogPath
Bool
is_dir <- FilePath -> IO Bool
doesDirectoryExist FilePath
pkgConfDest
let notHidden :: FilePath -> Bool
notHidden = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
isHidden
isHidden :: FilePath -> Bool
isHidden FilePath
name = FilePath
"." forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
name
if Bool
is_dir
then forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (FilePath -> FilePath -> IO InstalledPackageInfo
readPkgConf FilePath
pkgConfDest) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
notHidden
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO [FilePath]
getDirectoryContents FilePath
pkgConfDest
else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO InstalledPackageInfo
readPkgConf FilePath
"." FilePath
pkgConfDest
else forall (m :: * -> *) a. Monad m => a -> m a
return []
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
</> FilePath
pkgConfFile)
case ByteString
-> Either (NonEmpty FilePath) ([FilePath], InstalledPackageInfo)
Installed.parseInstalledPackageInfo ByteString
pkgConfText of
Left NonEmpty FilePath
perrors -> forall {a}. FilePath -> IO a
pkgConfParseFailed forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty FilePath
perrors
Right ([FilePath]
warns, InstalledPackageInfo
pkgConf) -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
warns) forall a b. (a -> b) -> a -> b
$
Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines [FilePath]
warns
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageInfo
pkgConf
pkgConfParseFailed :: String -> IO a
pkgConfParseFailed :: forall {a}. FilePath -> IO a
pkgConfParseFailed FilePath
perror =
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Couldn't parse the output of 'setup register --gen-pkg-config':"
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show FilePath
perror
maybeLogPath :: IO (Maybe FilePath)
maybeLogPath :: IO (Maybe FilePath)
maybeLogPath =
case UseLogFile
useLogFile of
UseLogFile
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (PackageIdentifier -> UnitId -> FilePath
mkLogFileName, Verbosity
_) -> do
let logFileName :: FilePath
logFileName = PackageIdentifier -> UnitId -> FilePath
mkLogFileName (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg) UnitId
uid
logDir :: FilePath
logDir = FilePath -> FilePath
takeDirectory FilePath
logFileName
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
logDir) forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
logDir
Bool
logFileExists <- FilePath -> IO Bool
doesFileExist FilePath
logFileName
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
logFileExists forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
logFileName
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just FilePath
logFileName)
setup :: CommandUI flags -> (Version -> flags) -> Maybe FilePath -> IO ()
setup CommandUI flags
cmd Version -> flags
flags Maybe FilePath
mLogPath =
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
(forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\FilePath
path -> FilePath -> IOMode -> IO Handle
openFile FilePath
path IOMode
AppendMode) Maybe FilePath
mLogPath)
(forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Handle -> IO ()
hClose)
(\Maybe Handle
logFileHandle ->
forall flags.
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [FilePath])
-> IO ()
setupWrapper Verbosity
verbosity
SetupScriptOptions
scriptOptions { useLoggingHandle :: Maybe Handle
useLoggingHandle = Maybe Handle
logFileHandle
, useWorkingDir :: Maybe FilePath
useWorkingDir = Maybe FilePath
workingDir }
(forall a. a -> Maybe a
Just PackageDescription
pkg)
CommandUI flags
cmd Version -> flags
flags (forall a b. a -> b -> a
const []))
onFailure :: (SomeException -> BuildFailure) -> IO BuildOutcome -> IO BuildOutcome
onFailure :: (SomeException -> BuildFailure)
-> IO BuildOutcome -> IO BuildOutcome
onFailure SomeException -> BuildFailure
result IO BuildOutcome
action =
IO BuildOutcome
action forall a. IO a -> [Handler a] -> IO a
`catches`
[ forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \IOException
ioe -> forall e. Exception e => e -> IO BuildOutcome
handler (IOException
ioe :: IOException)
, forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \ExitCode
exit -> 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> BuildFailure
result forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> SomeException
toException
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 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
(forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags))
(PackageDescription -> Bool
PackageDescription.hasLibs PackageDescription
pkg)
forall a. Verbosity -> [FilePath] -> IO a -> IO a
Win32SelfUpgrade.possibleSelfUpgrade Verbosity
verbosity
(InstallDirTemplates -> [FilePath]
exeInstallPaths InstallDirTemplates
defaultDirs) IO a
action
where
pkgid :: PackageIdentifier
pkgid = forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg
(CompilerId CompilerFlavor
compFlavor Version
_) = CompilerInfo -> CompilerId
compilerInfoId CompilerInfo
cinfo
exeInstallPaths :: InstallDirTemplates -> [FilePath]
exeInstallPaths InstallDirTemplates
defaultDirs =
[ forall dir. InstallDirs dir -> dir
InstallDirs.bindir InstallDirs FilePath
absoluteDirs FilePath -> FilePath -> FilePath
</> 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 forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> FilePath
prettyShow (Executable -> UnqualComponentName
PackageDescription.exeName Executable
exe) 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 = 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 = forall a b c.
(a -> b -> c) -> InstallDirs a -> InstallDirs b -> InstallDirs c
InstallDirs.combineInstallDirs 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
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