Commit 99dc4056 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

Instead of pruning, make an install plan for the whole environment.

Previously, we used a hack for reinstalling reverse dependencies: we created an
install plan for the sandboxed package and the modified add-source deps and then
pruned the sandboxed package from it. This missed those revdeps that the
sandboxed package didn't depend on and also broke the sandboxed package if it
was installed in the sandboxed package DB (see #1229).

This commit replaces that hack with a more principled approach: we create a plan
for the whole environment (all packages installed in the sandbox), constraining
the modified add-source deps to be reinstalled and the already installed
packages to be preferably not.

Fixes #1229.
parent bc8bb400
......@@ -33,6 +33,9 @@ module Distribution.Client.Dependency (
standardInstallPolicy,
PackageSpecifier(..),
-- ** Sandbox policy
sandboxInstallPolicy,
-- ** Extra policy options
dontUpgradeBasePackage,
hideBrokenInstalledPackages,
......@@ -70,13 +73,15 @@ import Distribution.Client.Dependency.Types
, PackagePreferences(..), InstalledPreference(..)
, PackagesPreferenceDefault(..)
, Progress(..), foldProgress )
import Distribution.Client.Sandbox.Types
( SandboxPackageInfo(..) )
import Distribution.Client.Targets
import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.Package
( PackageName(..), PackageId, Package(..), packageVersion
( PackageName(..), PackageId, Package(..), packageName, packageVersion
, InstalledPackageId, Dependency(Dependency))
import Distribution.Version
( Version(..), VersionRange, anyVersion, withinRange
( Version(..), VersionRange, anyVersion, thisVersion, withinRange
, simplifyVersionRange )
import Distribution.Compiler
( CompilerId(..), CompilerFlavor(..) )
......@@ -316,6 +321,41 @@ standardInstallPolicy
$ basicDepResolverParams
installedPkgIndex sourcePkgIndex
sandboxInstallPolicy :: SandboxPackageInfo
-> InstalledPackageIndex.PackageIndex
-> SourcePackageDb
-> [PackageSpecifier SourcePackage]
-> DepResolverParams
sandboxInstallPolicy
(SandboxPackageInfo modifiedDeps otherDeps allSandboxPkgs)
installedPkgIndex sourcePackageDb pkgSpecifiers
= addPreferences [ PackageInstalledPreference n PreferInstalled
| n <- installedNotModified ]
. addTargets installedNotModified
. addConstraints
[ PackageConstraintVersion (packageName pkg)
(thisVersion (packageVersion pkg)) | pkg <- modifiedDeps ++ otherDeps ]
. addTargets [ packageName pkg | pkg <- modifiedDeps ]
. hideInstalledPackagesSpecificBySourcePackageId
[ packageId pkg | pkg <- modifiedDeps ]
-- We don't need to add source packages for add-source deps to the
-- 'installedPkgIndex' since 'getSourcePackages' did that for us.
$ standardInstallPolicy installedPkgIndex sourcePackageDb pkgSpecifiers
where
installedPkgIds =
map fst . InstalledPackageIndex.allPackagesBySourcePackageId
$ allSandboxPkgs
modifiedPkgIds = map packageId modifiedDeps
installedNotModified = [ packageName pkg | pkg <- installedPkgIds,
pkg `notElem` modifiedPkgIds ]
-- ------------------------------------------------------------
-- * Interface to the standard resolver
......
......@@ -66,7 +66,7 @@ import Distribution.Client.Setup
, ConfigExFlags(..), InstallFlags(..) )
import Distribution.Client.Config
( defaultCabalDir )
import Distribution.Client.Sandbox.Types ( isUseSandbox )
import Distribution.Client.Sandbox.Types ( SandboxPackageInfo(..), isUseSandbox )
import Distribution.Client.Tar (extractTarGzFile)
import Distribution.Client.Types as Source
import Distribution.Client.BuildReports.Types
......@@ -154,6 +154,7 @@ install
-> Compiler
-> Platform
-> ProgramConfiguration
-> Maybe SandboxPackageInfo
-> GlobalFlags
-> ConfigFlags
-> ConfigExFlags
......@@ -161,18 +162,18 @@ install
-> HaddockFlags
-> [UserTarget]
-> IO ()
install verbosity packageDBs repos comp platform conf
install verbosity packageDBs repos comp platform conf mSandboxPkgInfo
globalFlags configFlags configExFlags installFlags haddockFlags
userTargets0 = do
installContext <- makeInstallContext verbosity args userTargets0
installContext <- makeInstallContext verbosity args (Just userTargets0)
installPlan <- foldProgress logMsg die return =<<
makeInstallPlan verbosity args installContext
processInstallPlan verbosity args installContext installPlan
where
args :: InstallArgs
args = (packageDBs, repos, comp, platform, conf,
args = (packageDBs, repos, comp, platform, conf, mSandboxPkgInfo,
globalFlags, configFlags, configExFlags, installFlags,
haddockFlags)
......@@ -191,6 +192,7 @@ type InstallArgs = ( PackageDBStack
, Compiler
, Platform
, ProgramConfiguration
, Maybe SandboxPackageInfo
, GlobalFlags
, ConfigFlags
, ConfigExFlags
......@@ -198,24 +200,32 @@ type InstallArgs = ( PackageDBStack
, HaddockFlags )
-- | Make an install context given install arguments.
makeInstallContext :: Verbosity -> InstallArgs -> [UserTarget]
makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]
-> IO InstallContext
makeInstallContext verbosity
(packageDBs, repos, comp, _, conf,
globalFlags, _, _, _, _) userTargets0 = do
(packageDBs, repos, comp, _, conf,_,
globalFlags, _, _, _, _) mUserTargets = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repos
let -- For install, if no target is given it means we use the
-- current directory as the single target
userTargets | null userTargets0 = [UserTargetLocalDir "."]
| otherwise = userTargets0
pkgSpecifiers <- resolveUserTargets verbosity
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets
(userTargets, pkgSpecifiers) <- case mUserTargets of
Nothing ->
-- We want to distinguish between the case where the user has given an
-- empty list of targets on the command-line and the case where we
-- specifically want to have an empty list of targets.
return ([], [])
Just userTargets0 -> do
-- For install, if no target is given it means we use the current
-- directory as the single target.
let userTargets | null userTargets0 = [UserTargetLocalDir "."]
| otherwise = userTargets0
pkgSpecifiers <- resolveUserTargets verbosity
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets
return (userTargets, pkgSpecifiers)
return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers)
......@@ -223,7 +233,7 @@ makeInstallContext verbosity
makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext
-> IO (Progress String String InstallPlan)
makeInstallPlan verbosity
(_, _, comp, platform, _,
(_, _, comp, platform, _, mSandboxPkgInfo,
_, configFlags, configExFlags, installFlags,
_)
(installedPkgIndex, sourcePkgDb,
......@@ -232,15 +242,16 @@ makeInstallPlan verbosity
solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))
(compilerId comp)
notice verbosity "Resolving dependencies..."
return $ planPackages comp platform solver configFlags configExFlags
installFlags installedPkgIndex sourcePkgDb pkgSpecifiers
return $ planPackages comp platform mSandboxPkgInfo solver
configFlags configExFlags installFlags
installedPkgIndex sourcePkgDb pkgSpecifiers
-- | Given an install plan, perform the actual installations.
processInstallPlan :: Verbosity -> InstallArgs -> InstallContext
-> InstallPlan
-> IO ()
processInstallPlan verbosity
args@(_, _, _, _, _, _, _, _, installFlags, _)
args@(_,_, _, _, _, _, _, _, _, installFlags, _)
(installedPkgIndex, sourcePkgDb,
userTargets, pkgSpecifiers) installPlan = do
checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb
......@@ -259,6 +270,7 @@ processInstallPlan verbosity
planPackages :: Compiler
-> Platform
-> Maybe SandboxPackageInfo
-> Solver
-> ConfigFlags
-> ConfigExFlags
......@@ -267,7 +279,8 @@ planPackages :: Compiler
-> SourcePackageDb
-> [PackageSpecifier SourcePackage]
-> Progress String String InstallPlan
planPackages comp platform solver configFlags configExFlags installFlags
planPackages comp platform mSandboxPkgInfo solver
configFlags configExFlags installFlags
installedPkgIndex sourcePkgDb pkgSpecifiers =
resolveDependencies
......@@ -317,7 +330,8 @@ planPackages comp platform solver configFlags configExFlags installFlags
. (if reinstall then reinstallTargets else id)
$ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
$ (maybe standardInstallPolicy sandboxInstallPolicy mSandboxPkgInfo)
installedPkgIndex sourcePkgDb pkgSpecifiers
stanzas = concat
[ if testsEnabled then [TestStanzas] else []
......@@ -602,7 +616,7 @@ postInstallActions :: Verbosity
-> InstallPlan
-> IO ()
postInstallActions verbosity
(packageDBs, _, comp, platform, conf, globalFlags, configFlags
(packageDBs, _, comp, platform, conf, _, globalFlags, configFlags
, _, installFlags, _)
targets installPlan = do
......@@ -799,7 +813,7 @@ performInstallations :: Verbosity
-> InstallPlan
-> IO InstallPlan
performInstallations verbosity
(packageDBs, _, comp, _, conf,
(packageDBs, _, comp, _, conf,_,
globalFlags, configFlags, configExFlags, installFlags, haddockFlags)
installedPkgIndex installPlan = do
......
......@@ -49,8 +49,7 @@ import Distribution.Client.IndexUtils ( BuildTreeRefType(..) )
import Distribution.Client.Install ( InstallArgs,
makeInstallContext,
makeInstallPlan,
processInstallPlan,
pruneInstallPlan )
processInstallPlan )
import Distribution.Client.Sandbox.PackageEnvironment
( PackageEnvironment(..), IncludeComments(..), PackageEnvironmentType(..)
, createPackageEnvironment, classifyPackageEnvironment
......@@ -58,11 +57,10 @@ import Distribution.Client.Sandbox.PackageEnvironment
, commentPackageEnvironment, showPackageEnvironmentWithComments
, sandboxPackageEnvironmentFile, updatePackageEnvironment
, userPackageEnvironmentFile )
import Distribution.Client.Sandbox.Types ( UseSandbox(..) )
import Distribution.Client.Targets ( UserTarget(..)
, readUserTargets
, resolveUserTargets )
import Distribution.Client.Types ( SourcePackageDb(..) )
import Distribution.Client.Sandbox.Types ( SandboxPackageInfo(..)
, UseSandbox(..) )
import Distribution.Client.Types ( PackageLocation(..)
, SourcePackage(..) )
import Distribution.Client.Utils ( inDir, tryCanonicalizePath )
import Distribution.PackageDescription.Configuration
( flattenPackageDescription )
......@@ -74,11 +72,11 @@ import Distribution.Simple.Configure ( configCompilerAux
, getPackageDBContents )
import Distribution.Simple.PreProcess ( knownSuffixHandlers )
import Distribution.Simple.Program ( ProgramConfiguration )
import Distribution.Simple.Setup ( Flag(..)
, fromFlag, fromFlagOrDefault )
import Distribution.Simple.Setup ( Flag(..), fromFlagOrDefault )
import Distribution.Simple.SrcDist ( prepareTree )
import Distribution.Simple.Utils ( die, debug, notice, info, warn
, debugNoWrap, defaultPackageDesc
, findPackageDesc
, intercalate, topHandlerWith
, createDirectoryIfMissingVerbose )
import Distribution.Package ( Package(..) )
......@@ -90,6 +88,7 @@ import Distribution.Compat.FilePerms ( setFileHidden )
import qualified Distribution.Client.Sandbox.Index as Index
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import qualified Distribution.Simple.Register as Register
import qualified Data.Map as M
import Control.Exception ( assert, bracket_ )
import Control.Monad ( forM, liftM2, unless, when )
import Data.Bits ( shiftL, shiftR, xor )
......@@ -469,7 +468,7 @@ reinstallAddSourceDeps :: Verbosity
reinstallAddSourceDeps verbosity config configFlags' configExFlags
installFlags globalFlags sandboxDir = topHandler' $ do
let configFlags = configFlags'
{ configDistPref = Flag (sandboxBuildDir sandboxDir) }
{ configDistPref = Flag (sandboxBuildDir sandboxDir) }
indexFile <- tryGetIndexFilePath config
buildTreeRefs <- Index.listBuildTreeRefs verbosity
Index.DontListIgnored Index.OnlyLinks indexFile
......@@ -482,53 +481,80 @@ reinstallAddSourceDeps verbosity config configFlags' configExFlags
withModifiedDeps verbosity sandboxDir compId platform $ \modifiedDeps -> do
assert (null $ modifiedDeps \\ buildTreeRefs) (return ())
unless (null modifiedDeps) $ do
let targetNames = (".":modifiedDeps)
targetsToPrune = [UserTargetLocalDir "."]
notice verbosity "Installing add-source dependencies..."
targets <- readUserTargets verbosity targetNames
let args :: InstallArgs
args = ((configPackageDB' configFlags)
,(globalRepos globalFlags)
,comp, platform, conf
,globalFlags, configFlags, configExFlags, installFlags
,mempty)
logMsg message rest = debugNoWrap verbosity message >> rest
-- Using the low-level install interface instead of the high-level
-- 'install' action allows us to make changes to the install plan before
-- processing it. Here we need to prune the "." target from the install
-- plan. The same mechanism is used to implement 'install
-- --only-dependencies'.
withSandboxBinDirOnSearchPath sandboxDir $ do
installContext@(_,sourcePkgDb,_,_) <-
makeInstallContext verbosity args targets
toPrune <- resolveUserTargets verbosity
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
targetsToPrune
installPlan <- foldProgress logMsg die return =<<
(fmap (\p -> p >>= if not . null $ targetsToPrune
then pruneInstallPlan toPrune
else return)
$ makeInstallPlan verbosity args installContext)
processInstallPlan verbosity args installContext installPlan
writeIORef retVal ReinstalledSomeDeps
sandboxPkgInfo <- makeSandboxPackageInfo verbosity configFlags
comp conf buildTreeRefs modifiedDeps
let modifiedAndInstalledDeps = modifiedAddSourceDependencies
sandboxPkgInfo
unless (null modifiedAndInstalledDeps) $ do
notice verbosity "Installing add-source dependencies..."
let args :: InstallArgs
args = ((configPackageDB' configFlags)
,(globalRepos globalFlags)
,comp, platform, conf, Just sandboxPkgInfo
,globalFlags, configFlags, configExFlags, installFlags
,mempty)
-- This can actually be replaced by a call to 'install', but we use a
-- lower-level API because of layer separation reasons. Additionally,
-- we might want to extend this in the future.
withSandboxBinDirOnSearchPath sandboxDir $ do
installContext <- makeInstallContext verbosity args Nothing
installPlan <- foldProgress logMsg die return =<<
makeInstallPlan verbosity args installContext
processInstallPlan verbosity args installContext installPlan
writeIORef retVal ReinstalledSomeDeps
readIORef retVal
where
logMsg message rest = debugNoWrap verbosity message >> rest
topHandler' = topHandlerWith $ \_ -> do
warn verbosity "Couldn't reinstall some add-source dependencies."
-- Here we can't know whether any deps have been reinstalled, so we have
-- to be conservative.
return ReinstalledSomeDeps
-- | Given a list of all add-source deps and a list of modified add-source deps,
-- produce a 'SandboxPackageInfo'.
makeSandboxPackageInfo :: Verbosity -> ConfigFlags
-> Compiler -> ProgramConfiguration
-> [FilePath] -> [FilePath]
-> IO SandboxPackageInfo
makeSandboxPackageInfo verbosity configFlags comp conf
allAddSourceDeps modifiedAddSourceDeps = do
-- List all packages installed in the sandbox.
installedPkgIndex <- getInstalledPackagesInSandbox verbosity
configFlags comp conf
-- Get the package descriptions of all add-source deps.
depsCabalFiles <- mapM findPackageDesc allAddSourceDeps
depsPkgDescs <- mapM (readPackageDescription verbosity) depsCabalFiles
let depsMap = M.fromList (zip allAddSourceDeps depsPkgDescs)
-- Get the package ids of modified (and installed) add-source deps.
let isInstalled pkgid = not . null
. InstalledPackageIndex.lookupSourcePackageId installedPkgIndex $ pkgid
isModified path = path `elem` modifiedAddSourceDeps
modifiedDepsMap = M.filterWithKey
(\path pkgDesc -> isInstalled (packageId pkgDesc) && isModified path )
depsMap
modifiedDeps = M.assocs modifiedDepsMap
-- Get the package ids of the remaining add-source deps (some are possibly not
-- installed).
let otherDeps = M.assocs (depsMap `M.difference` modifiedDepsMap)
return $ SandboxPackageInfo (map toSourcePackage modifiedDeps)
(map toSourcePackage otherDeps) installedPkgIndex
where
toSourcePackage (path, pkgDesc) = SourcePackage
(packageId pkgDesc) pkgDesc (LocalUnpackedPackage path) Nothing
-- | Check if a sandbox is present and call @reinstallAddSourceDeps@ in that
-- case.
maybeReinstallAddSourceDeps :: Verbosity
......
......@@ -8,9 +8,13 @@
-----------------------------------------------------------------------------
module Distribution.Client.Sandbox.Types (
UseSandbox(..), isUseSandbox, whenUsingSandbox
UseSandbox(..), isUseSandbox, whenUsingSandbox,
SandboxPackageInfo(..)
) where
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import Distribution.Client.Types (SourcePackage)
import Data.Monoid
-- | Are we using a sandbox?
......@@ -34,3 +38,20 @@ isUseSandbox NoSandbox = False
whenUsingSandbox :: UseSandbox -> (FilePath -> IO ()) -> IO ()
whenUsingSandbox NoSandbox _ = return ()
whenUsingSandbox (UseSandbox sandboxDir) act = act sandboxDir
-- | Data about the packages installed in the sandbox that is passed from
-- 'reinstallAddSourceDeps' to the solver.
data SandboxPackageInfo = SandboxPackageInfo {
modifiedAddSourceDependencies :: [SourcePackage],
-- ^ Modified add-source deps that we want to reinstall. These are guaranteed
-- to be already installed in the sandbox.
otherAddSourceDependencies :: [SourcePackage],
-- ^ Remaining add-source deps. Some of these may be not installed in the
-- sandbox.
otherInstalledSandboxPackages :: InstalledPackageIndex.PackageIndex
-- ^ All packages installed in the sandbox. Intersection with
-- 'modifiedAddSourceDependencies' and/or 'otherAddSourceDependencies' can be
-- non-empty.
}
......@@ -512,8 +512,9 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
install verbosity
(configPackageDB' configFlags'')
(globalRepos globalFlags')
comp platform conf globalFlags' configFlags'' configExFlags'
installFlags' haddockFlags
comp platform conf
Nothing -- FIXME
globalFlags' configFlags'' configExFlags' installFlags' haddockFlags
targets
testAction :: (TestFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment