Commit d5ea0dfc authored by Mikhail Glushenkov's avatar Mikhail Glushenkov

Solver support for '--allow-newer'.

Implemented by going through all packages in the 'depResolverSourcePkgIndex' and
applying 'relaxUpperBound' to the dependencies listed in 'build-depends'.

Known issue:
'build-depends: a < 3 && >= 2; if (someFlag): build-depends: a >= 5 && < 6'
gets converted to
'build-depends: >= 2; if (someFlag): build-depends: a >= 5'
(4 is now allowed where it previously wasn't).

Example:

    $ cabal install --dry-run ./tst
    Resolving dependencies...
    In order, the following would be installed (use -v for more details):
    array-0.3.0.3 (latest: 0.5.0.0)
    tst-0.1.0.0 (latest: 0.1.1)

    $ cabal install --dry-run --allow-newer=array ./tst
    Resolving dependencies...
    In order, the following would be installed (use -v for more details):
    tst-0.1.0.0 (latest: 0.1.1)
parent 7d0cefeb
......@@ -55,6 +55,7 @@ module Distribution.Client.Dependency (
hideInstalledPackagesSpecificByInstalledPackageId,
hideInstalledPackagesSpecificBySourcePackageId,
hideInstalledPackagesAllVersions,
relaxUpperBounds
) where
import Distribution.Client.Dependency.TopDown
......@@ -70,7 +71,7 @@ import Distribution.Client.Types
, SourcePackage(..) )
import Distribution.Client.Dependency.Types
( PreSolver(..), Solver(..), DependencyResolver, PackageConstraint(..)
, PackagePreferences(..), InstalledPreference(..)
, AllowNewer(..), PackagePreferences(..), InstalledPreference(..)
, PackagesPreferenceDefault(..)
, Progress(..), foldProgress )
import Distribution.Client.Sandbox.Types
......@@ -80,9 +81,14 @@ import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.Package
( PackageName(..), PackageId, Package(..), packageName, packageVersion
, InstalledPackageId, Dependency(Dependency))
import qualified Distribution.PackageDescription as PD
( PackageDescription(..), GenericPackageDescription(..)
, Library(..), Executable(..), TestSuite(..), Benchmark(..), CondTree)
import Distribution.PackageDescription (BuildInfo(targetBuildDepends))
import Distribution.PackageDescription.Configuration (mapCondTree)
import Distribution.Version
( Version(..), VersionRange, anyVersion, thisVersion, withinRange
, simplifyVersionRange )
, relaxUpperBound, simplifyVersionRange )
import Distribution.Compiler
( CompilerId(..), CompilerFlavor(..) )
import Distribution.System
......@@ -284,6 +290,88 @@ hideBrokenInstalledPackages params =
. InstalledPackageIndex.brokenPackages
$ depResolverInstalledPkgIndex params
-- | Relax upper bounds in dependencies using the policy specified by the
-- 'AllowNewer' argument (all/some/none).
relaxUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams
relaxUpperBounds allowNewer params =
params {
-- NB: It's important to apply 'relaxUpperBounds' after
-- 'addSourcePackages'. Otherwise, the packages inserted by
-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.
depResolverSourcePkgIndex = sourcePkgIndex'
}
where
sourcePkgIndex = depResolverSourcePkgIndex params
sourcePkgIndex' = case allowNewer of
AllowNewerNone -> sourcePkgIndex
AllowNewerAll -> fmap relaxAllPackageDeps sourcePkgIndex
AllowNewerSome pkgs -> fmap (relaxSomePackageDeps pkgs) sourcePkgIndex
relaxAllPackageDeps :: SourcePackage -> SourcePackage
relaxAllPackageDeps = onAllBuildDepends doRelax
where
doRelax (Dependency pkgName verRange) =
Dependency pkgName (relaxUpperBound verRange)
relaxSomePackageDeps :: [PackageName] -> SourcePackage -> SourcePackage
relaxSomePackageDeps pkgNames = onAllBuildDepends doRelax
where
doRelax d@(Dependency pkgName verRange)
| pkgName `elem` pkgNames = Dependency pkgName
(relaxUpperBound verRange)
| otherwise = d
-- Walk a 'GenericPackageDescription' and apply 'f' to all 'build-depends'
-- fields.
onAllBuildDepends :: (Dependency -> Dependency)
-> SourcePackage -> SourcePackage
onAllBuildDepends f srcPkg = srcPkg'
where
gpd = packageDescription srcPkg
pd = PD.packageDescription gpd
condLib = PD.condLibrary gpd
condExes = PD.condExecutables gpd
condTests = PD.condTestSuites gpd
condBenchs = PD.condBenchmarks gpd
f' = onBuildInfo f
onBuildInfo g bi = bi
{ targetBuildDepends = map g (targetBuildDepends bi) }
onLibrary lib = lib { PD.libBuildInfo = f' $ PD.libBuildInfo lib }
onExecutable exe = exe { PD.buildInfo = f' $ PD.buildInfo exe }
onTestSuite tst = tst { PD.testBuildInfo = f' $ PD.testBuildInfo tst }
onBenchmark bmk = bmk { PD.benchmarkBuildInfo =
f' $ PD.benchmarkBuildInfo bmk }
srcPkg' = srcPkg { packageDescription = gpd' }
gpd' = gpd {
PD.packageDescription = pd',
PD.condLibrary = condLib',
PD.condExecutables = condExes',
PD.condTestSuites = condTests',
PD.condBenchmarks = condBenchs'
}
pd' = pd {
PD.buildDepends = map f (PD.buildDepends pd),
PD.library = fmap onLibrary (PD.library pd),
PD.executables = map onExecutable (PD.executables pd),
PD.testSuites = map onTestSuite (PD.testSuites pd),
PD.benchmarks = map onBenchmark (PD.benchmarks pd)
}
condLib' = fmap (onCondTree onLibrary) condLib
condExes' = map (mapSnd $ onCondTree onExecutable) condExes
condTests' = map (mapSnd $ onCondTree onTestSuite) condTests
condBenchs' = map (mapSnd $ onCondTree onBenchmark) condBenchs
mapSnd :: (a -> b) -> (c,a) -> (c,b)
mapSnd = fmap
onCondTree :: (a -> b) -> PD.CondTree v [Dependency] a
-> PD.CondTree v [Dependency] b
onCondTree g = mapCondTree g (map f) id
upgradeDependencies :: DepResolverParams -> DepResolverParams
upgradeDependencies = setPreferenceDefault PreferAllLatest
......@@ -425,7 +513,6 @@ resolveDependencies platform comp solver params =
preferences = interpretPackagesPreference
(Set.fromList targets) defpref prefs
-- | Make an install plan from the output of the dep resolver.
-- It checks that the plan is valid, or it's an error in the dep resolver.
--
......
......@@ -17,6 +17,7 @@ module Distribution.Client.Dependency.Types (
Solver(..),
DependencyResolver,
AllowNewer(..),
PackageConstraint(..),
PackagePreferences(..),
InstalledPreference(..),
......@@ -167,6 +168,22 @@ data PackagesPreferenceDefault =
--
| PreferLatestForSelected
-- | Policy for relaxing upper bounds in dependencies. For example, given
-- 'build-depends: array >= 0.3 && < 0.5', are we allowed to relax the upper
-- bound and choose a version of 'array' that is greater or equal to 0.5? By
-- default the upper bounds are always strictly honored.
data AllowNewer =
-- | Default: honor the upper bounds in all dependencies, never choose
-- versions newer than allowed.
AllowNewerNone
-- | Ignore upper bounds in dependencies on the given packages.
| AllowNewerSome [PackageName]
-- | Ignore upper bounds in dependencies on all packages.
| AllowNewerAll
-- | 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.
......
......@@ -334,6 +334,8 @@ planPackages comp platform mSandboxPkgInfo solver
. setPreferenceDefault (if upgradeDeps then PreferAllLatest
else PreferLatestForSelected)
. relaxUpperBounds allowNewer
. addPreferences
-- preferences from the config file or command line
[ PackageVersionPreference name ver
......@@ -377,6 +379,7 @@ planPackages comp platform mSandboxPkgInfo solver
maxBackjumps = fromFlag (installMaxBackjumps installFlags)
upgradeDeps = fromFlag (installUpgradeDeps installFlags)
onlyDeps = fromFlag (installOnlyDeps installFlags)
allowNewer = fromFlag (installAllowNewer installFlags)
-- | Remove the provided targets from the install plan.
pruneInstallPlan :: Package pkg => [PackageSpecifier pkg] -> InstallPlan
......
......@@ -89,6 +89,9 @@ newtype PackageIndex pkg = PackageIndex
deriving (Show, Read)
instance Functor PackageIndex where
fmap f (PackageIndex m) = PackageIndex (fmap (map f) m)
instance Package pkg => Monoid (PackageIndex pkg) where
mempty = PackageIndex Map.empty
mappend = merge
......
......@@ -18,7 +18,6 @@ module Distribution.Client.Setup
, buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)
, testCommand, benchmarkCommand
, installCommand, InstallFlags(..), installOptions, defaultInstallFlags
, AllowNewer(..)
, listCommand, ListFlags(..)
, updateCommand
, upgradeCommand
......@@ -45,7 +44,7 @@ import Distribution.Client.Types
import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.Dependency.Types
( PreSolver(..) )
( AllowNewer(..), PreSolver(..) )
import qualified Distribution.Client.Init.Types as IT
( InitFlags(..), PackageType(..) )
import Distribution.Client.Targets
......@@ -66,8 +65,7 @@ import Distribution.Simple.InstallDirs
import Distribution.Version
( Version(Version), anyVersion, thisVersion )
import Distribution.Package
( PackageIdentifier, PackageName, packageName, packageVersion
, Dependency(..) )
( PackageIdentifier, packageName, packageVersion, Dependency(..) )
import Distribution.PackageDescription
( RepoKind(..) )
import Distribution.Text
......@@ -835,9 +833,6 @@ defaultInstallFlags = InstallFlags {
where
docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html")
data AllowNewer = AllowNewerNone | AllowNewerSome [PackageName] | AllowNewerAll
deriving (Eq, Show)
allowNewerParser :: ReadE AllowNewer
allowNewerParser = ReadE $ \s ->
case s of
......
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