Commit df953acf authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Change the DependencyResolver type to take a per-package version pref

And add a few global package version pref policies and use them in
ordinary install and upgrade. For install we use a policy that says
that we prefer the latest version of a package that we specifically
request and prefer the installed version of any other package. For
upgrade we simple always prefer the latest version. One can imageine
other policies where we prefer the latest version for only some
interesting subset of packages and installed otherwise.
No resolvers actually make use of this preference yet.
parent df947224
......@@ -15,6 +15,7 @@
module Hackage.Dependency (
resolveDependencies,
resolveDependenciesWithProgress,
PackagesVersionPreference(..),
upgradableDependencies,
) where
......@@ -29,7 +30,8 @@ import Hackage.InstallPlan (InstallPlan)
import Hackage.Types
( UnresolvedDependency(..), AvailablePackage(..) )
import Hackage.Dependency.Types
( DependencyResolver, Progress(..), foldProgress )
( PackageName, DependencyResolver, PackageVersionPreference(..)
, Progress(..), foldProgress )
import Distribution.Package
( PackageIdentifier(..), packageVersion, packageName
, Dependency(..), Package(..), PackageFixedDeps(..) )
......@@ -44,37 +46,62 @@ import Hackage.Utils (mergeBy, MergeResult(..))
import Data.List (maximumBy)
import Data.Monoid (Monoid(mempty))
import qualified Data.Set as Set
import Data.Set (Set)
import Control.Exception (assert)
defaultResolver :: DependencyResolver a
defaultResolver = naiveResolver
--for the brave: try the new topDownResolver, but only with --dry-run !!!
-- | Global policy for the versions of all packages.
--
data PackagesVersionPreference =
-- | Always prefer the latest version irrespective of any existing
-- installed version.
--
-- * This is the standard policy for upgrade.
--
PreferAllLatest
-- | Always prefer the installed versions over ones that would need to be
-- installed. Secondarily, prefer latest versions (eg the latest installed
-- version or if there are none then the latest available version).
| PreferAllInstalled
-- | Prefer the latest version for packages that are explicitly requested
-- but prefers the installed version for any other packages.
--
-- * This is the standard policy for install.
--
| PreferLatestForSelected
resolveDependencies :: OS
-> Arch
-> CompilerId
-> Maybe (PackageIndex InstalledPackageInfo)
-> PackageIndex AvailablePackage
-> PackagesVersionPreference
-> [UnresolvedDependency]
-> Either String (InstallPlan a)
resolveDependencies os arch comp installed available deps =
resolveDependencies os arch comp installed available pref deps =
foldProgress (flip const) Left Right $
resolveDependenciesWithProgress os arch comp installed available deps
resolveDependenciesWithProgress os arch comp installed available pref deps
resolveDependenciesWithProgress :: OS
-> Arch
-> CompilerId
-> Maybe (PackageIndex InstalledPackageInfo)
-> PackageIndex AvailablePackage
-> PackagesVersionPreference
-> [UnresolvedDependency]
-> Progress String String (InstallPlan a)
resolveDependenciesWithProgress os arch comp (Just installed) available deps =
dependencyResolver defaultResolver
os arch comp installed available deps
resolveDependenciesWithProgress os arch comp (Just installed) =
dependencyResolver defaultResolver os arch comp installed
resolveDependenciesWithProgress os arch comp Nothing available deps =
dependencyResolver bogusResolver
os arch comp mempty available deps
resolveDependenciesWithProgress os arch comp Nothing =
dependencyResolver bogusResolver os arch comp mempty
hideBrokenPackages :: PackageFixedDeps p => PackageIndex p -> PackageIndex p
hideBrokenPackages index =
......@@ -95,12 +122,14 @@ dependencyResolver
-> OS -> Arch -> CompilerId
-> PackageIndex InstalledPackageInfo
-> PackageIndex AvailablePackage
-> PackagesVersionPreference
-> [UnresolvedDependency]
-> Progress String String (InstallPlan a)
dependencyResolver resolver os arch comp installed available =
dependencyResolver resolver os arch comp installed available pref deps =
let installed' = hideBrokenPackages installed
available' = hideBasePackage available
in fmap toPlan . resolver os arch comp installed' available'
in fmap toPlan
$ resolver os arch comp installed' available' preference deps
where
toPlan pkgs =
......@@ -111,6 +140,26 @@ dependencyResolver resolver os arch comp installed available =
: "The proposed (invalid) plan contained the following problems:"
: map InstallPlan.showPlanProblem problems
preference = interpretPackagesVersionPreference initialPkgNames pref
initialPkgNames = Set.fromList
[ name | UnresolvedDependency (Dependency name _) _ <- deps ]
-- | Give an interpretation to the global 'PackagesVersionPreference' as
-- specific per-package 'PackageVersionPreference'.
--
interpretPackagesVersionPreference :: Set PackageName
-> PackagesVersionPreference
-> (PackageName -> PackageVersionPreference)
interpretPackagesVersionPreference selected pref = case pref of
PreferAllLatest -> const PreferLatest
PreferAllInstalled -> const PreferInstalled
PreferLatestForSelected -> \pkgname ->
-- When you say cabal install foo, what you really mean is, prefer the
-- latest version of foo, but the installed version of everything else:
if pkgname `Set.member` selected
then PreferLatest
else PreferInstalled
-- | Given the list of installed packages and available packages, figure
-- out which packages can be upgraded.
--
......
......@@ -39,7 +39,7 @@ import Data.List (maximumBy)
-- We just pretend that everything is installed and hope for the best.
--
bogusResolver :: DependencyResolver a
bogusResolver os arch comp _ available deps =
bogusResolver os arch comp _ available _ deps =
case unzipEithers (map resolveFromAvailable deps) of
(ok, []) -> Done ok
(_ , missing) -> Fail $ "Unresolved dependencies: "
......
......@@ -49,7 +49,7 @@ import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid(mappend))
naiveResolver :: DependencyResolver a
naiveResolver os arch comp installed available deps =
naiveResolver os arch comp installed available _ deps =
packagesToInstall installed
[ resolveDependency os arch comp installed available dep flags
| UnresolvedDependency dep flags <- deps]
......
......@@ -25,7 +25,8 @@ import Hackage.Types
( UnresolvedDependency(..), AvailablePackage(..)
, ConfiguredPackage(..) )
import Hackage.Dependency.Types
( DependencyResolver, Progress(..), foldProgress )
( PackageName, DependencyResolver, PackageVersionPreference(..)
, Progress(..), foldProgress )
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
......@@ -186,7 +187,7 @@ search configure constraints =
-- the standard 'DependencyResolver' interface.
--
topDownResolver :: DependencyResolver a
topDownResolver = (((((mapMessages .).).).).) . topDownResolver'
topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver'
where
mapMessages :: Progress Log Failure a -> Progress String String a
mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done
......@@ -196,9 +197,10 @@ topDownResolver = (((((mapMessages .).).).).) . topDownResolver'
topDownResolver' :: OS -> Arch -> CompilerId
-> PackageIndex InstalledPackageInfo
-> PackageIndex AvailablePackage
-> (PackageName -> PackageVersionPreference)
-> [UnresolvedDependency]
-> Progress Log Failure [PlanPackage a]
topDownResolver' os arch comp installed available deps =
topDownResolver' os arch comp installed available _ deps =
fmap (uncurry finalise)
. (\cs -> search (configurePackage os arch comp) cs initialPkgNames)
=<< constrainTopLevelDeps deps constraints
......
......@@ -25,8 +25,6 @@ import Distribution.PackageDescription
-- * The various kinds of packages
-- ------------------------------------------------------------
type PackageName = String
type SelectablePackage
= InstalledOrAvailable InstalledPackage UnconfiguredPackage
......
......@@ -11,7 +11,9 @@
-- Common types for dependency resolution.
-----------------------------------------------------------------------------
module Hackage.Dependency.Types (
PackageName,
DependencyResolver,
PackageVersionPreference(..),
Progress(..),
foldProgress,
) where
......@@ -31,6 +33,8 @@ import Distribution.System
import Prelude hiding (fail)
type PackageName = String
-- | A dependency resolver is a function that works out an installation plan
-- given the set of installed and available packages and a set of deps to
-- solve for.
......@@ -44,9 +48,18 @@ type DependencyResolver a = OS
-> CompilerId
-> PackageIndex InstalledPackageInfo
-> PackageIndex AvailablePackage
-> (PackageName -> PackageVersionPreference)
-> [UnresolvedDependency]
-> Progress String String [InstallPlan.PlanPackage a]
-- | A per-package preference on the version. It is a soft constraint that the
-- 'DependencyResolver' should try to respect where possible.
--
-- It is not specified if preferences on some packages are more important than
-- others.
--
data PackageVersionPreference = PreferInstalled | PreferLatest
-- | A type to represent the unfolding of an expensive long running
-- calculation that may fail. We may get intermediate steps before the final
-- retult which may be used to indicate progress and/or logging messages.
......
......@@ -26,7 +26,8 @@ import Network.HTTP (ConnError(..), Response(..))
import Hackage.Types
( UnresolvedDependency (..), AvailablePackage(..)
, AvailablePackageSource(..), Repo(..), repoURL )
import Hackage.Dependency (resolveDependencies)
import Hackage.Dependency
( resolveDependencies, PackagesVersionPreference(..) )
import qualified Hackage.IndexUtils as IndexUtils
import qualified Hackage.InstallPlan as InstallPlan
import Hackage.HttpUtils (getHTTP)
......@@ -132,8 +133,8 @@ fetch verbosity packageDB repos comp conf deps
= do installed <- getInstalledPackages verbosity comp packageDB conf
available <- fmap mconcat (mapM (IndexUtils.readRepoIndex verbosity) repos)
deps' <- IndexUtils.disambiguateDependencies available deps
case resolveDependencies buildOS buildArch
(compilerId comp) installed available deps' of
case resolveDependencies buildOS buildArch (compilerId comp)
installed available PreferLatestForSelected deps' of
Left message -> die message
Right pkgs -> do
ps <- filterM (fmap not . isFetched)
......
......@@ -26,7 +26,9 @@ import System.Directory
( getTemporaryDirectory, doesFileExist )
import System.FilePath ((</>),(<.>))
import Hackage.Dependency (resolveDependenciesWithProgress, upgradableDependencies)
import Hackage.Dependency
( resolveDependenciesWithProgress, PackagesVersionPreference(..)
, upgradableDependencies )
import Hackage.Dependency.Types (Progress(..), foldProgress)
import Hackage.Fetch (fetchPackage)
-- import qualified Hackage.Info as Info
......@@ -192,7 +194,7 @@ planLocalPackage verbosity comp configFlags installed available = do
}
return $ resolveDependenciesWithProgress buildOS buildArch (compilerId comp)
installed' available' [localPkgDep]
installed' available' PreferLatestForSelected [localPkgDep]
-- | Make an 'InstallPlan' for the given dependencies.
--
......@@ -200,11 +202,12 @@ planRepoPackages :: Compiler -> [UnresolvedDependency] -> Planner
planRepoPackages comp deps installed available = do
deps' <- IndexUtils.disambiguateDependencies available deps
return $ resolveDependenciesWithProgress buildOS buildArch (compilerId comp)
installed available deps'
installed available PreferLatestForSelected deps'
planUpgradePackages :: Compiler -> Planner
planUpgradePackages comp (Just installed) available = return $
resolveDependenciesWithProgress buildOS buildArch (compilerId comp) (Just installed) available
resolveDependenciesWithProgress buildOS buildArch (compilerId comp)
(Just installed) available PreferAllLatest
[ UnresolvedDependency dep []
| dep <- upgradableDependencies installed available ]
planUpgradePackages comp _ _ =
......
Supports Markdown
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