Commit 8a1e9268 authored by Andres Löh's avatar Andres Löh
Browse files

Merge pull request #3369 from grayjay/solver-backjump-test

Add quickcheck test to compare dependency solving with and without backjumping
parents a5f0301f c9ad3c87
......@@ -52,6 +52,7 @@ module Distribution.Client.Dependency (
setShadowPkgs,
setStrongFlags,
setMaxBackjumps,
setEnableBackjumping,
addSourcePackages,
hideInstalledPackagesSpecificByUnitId,
hideInstalledPackagesSpecificBySourcePackageId,
......@@ -77,6 +78,7 @@ import Distribution.Client.Types
, OptionalStanza(..), enableStanzas )
import Distribution.Client.Dependency.Types
( PreSolver(..), Solver(..), DependencyResolver, ResolverPackage(..)
, EnableBackjumping(..)
, PackageConstraint(..), showPackageConstraint
, LabeledPackageConstraint(..), unlabelPackageConstraint
, ConstraintSource(..), showConstraintSource
......@@ -150,7 +152,8 @@ data DepResolverParams = DepResolverParams {
depResolverAvoidReinstalls :: Bool,
depResolverShadowPkgs :: Bool,
depResolverStrongFlags :: Bool,
depResolverMaxBackjumps :: Maybe Int
depResolverMaxBackjumps :: Maybe Int,
depResolverEnableBackjumping :: EnableBackjumping
}
showDepResolverParams :: DepResolverParams -> String
......@@ -221,7 +224,8 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex =
depResolverAvoidReinstalls = False,
depResolverShadowPkgs = False,
depResolverStrongFlags = False,
depResolverMaxBackjumps = Nothing
depResolverMaxBackjumps = Nothing,
depResolverEnableBackjumping = EnableBackjumping True
}
addTargets :: [PackageName]
......@@ -290,6 +294,12 @@ setMaxBackjumps n params =
depResolverMaxBackjumps = n
}
setEnableBackjumping :: EnableBackjumping -> DepResolverParams -> DepResolverParams
setEnableBackjumping b params =
params {
depResolverEnableBackjumping = b
}
-- | Some packages are specific to a given compiler version and should never be
-- upgraded.
dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams
......@@ -572,7 +582,7 @@ resolveDependencies platform comp pkgConfigDB solver params =
Step (showDepResolverParams finalparams)
$ fmap (validateSolverResult platform comp indGoals)
$ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls
shadowing strFlags maxBkjumps)
shadowing strFlags maxBkjumps enableBj)
platform comp installedPkgIndex sourcePkgIndex
pkgConfigDB preferences constraints targets
where
......@@ -587,7 +597,8 @@ resolveDependencies platform comp pkgConfigDB solver params =
noReinstalls
shadowing
strFlags
maxBkjumps) = dontUpgradeNonUpgradeablePackages
maxBkjumps
enableBj) = dontUpgradeNonUpgradeablePackages
-- TODO:
-- The modular solver can properly deal with broken
-- packages and won't select them. So the
......@@ -822,7 +833,7 @@ resolveWithoutDependencies :: DepResolverParams
resolveWithoutDependencies (DepResolverParams targets constraints
prefs defpref installedPkgIndex sourcePkgIndex
_reorderGoals _indGoals _avoidReinstalls
_shadowing _strFlags _maxBjumps) =
_shadowing _strFlags _maxBjumps _enableBj) =
collectEithers (map selectPackage targets)
where
selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage
......
......@@ -39,15 +39,17 @@ import qualified Distribution.Client.Dependency.Types as T
-- with the (virtual) option not to choose anything for the current
-- variable. See also the comments for 'avoidSet'.
--
backjump :: F.Foldable t => Var QPN -> ConflictSet QPN -> t (ConflictSetLog a) -> ConflictSetLog a
backjump var initial xs = F.foldr combine logBackjump xs initial
backjump :: F.Foldable t => T.EnableBackjumping -> Var QPN
-> ConflictSet QPN -> t (ConflictSetLog a) -> ConflictSetLog a
backjump (T.EnableBackjumping enableBj) var initial xs =
F.foldr combine logBackjump xs initial
where
combine :: ConflictSetLog a
-> (ConflictSet QPN -> ConflictSetLog a)
-> ConflictSet QPN -> ConflictSetLog a
combine (T.Done x) _ _ = T.Done x
combine (T.Fail cs) f csAcc
| not (var `CS.member` cs) = logBackjump cs
| enableBj && not (var `CS.member` cs) = logBackjump cs
| otherwise = f (csAcc `CS.union` cs)
combine (T.Step m ms) f cs = T.Step m (combine ms f cs)
......@@ -58,27 +60,28 @@ type ConflictSetLog = T.Progress Message (ConflictSet QPN)
-- | A tree traversal that simultaneously propagates conflict sets up
-- the tree from the leaves and creates a log.
exploreLog :: Tree QGoalReason -> (Assignment -> ConflictSetLog (Assignment, RevDepMap))
exploreLog = cata go
exploreLog :: T.EnableBackjumping -> Tree QGoalReason
-> (Assignment -> ConflictSetLog (Assignment, RevDepMap))
exploreLog enableBj = cata go
where
go :: TreeF QGoalReason (Assignment -> ConflictSetLog (Assignment, RevDepMap))
-> (Assignment -> ConflictSetLog (Assignment, RevDepMap))
go (FailF c fr) _ = failWith (Failure c fr) c
go (DoneF rdm) a = succeedWith Success (a, rdm)
go (PChoiceF qpn gr ts) (A pa fa sa) =
backjump (P qpn) (avoidSet (P qpn) gr) $ -- try children in order,
backjump enableBj (P qpn) (avoidSet (P qpn) gr) $ -- try children in order,
P.mapWithKey -- when descending ...
(\ i@(POption k _) r -> tryWith (TryP qpn i) $ -- log and ...
r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice
ts
go (FChoiceF qfn gr _ _ ts) (A pa fa sa) =
backjump (F qfn) (avoidSet (F qfn) gr) $ -- try children in order,
backjump enableBj (F qfn) (avoidSet (F qfn) gr) $ -- try children in order,
P.mapWithKey -- when descending ...
(\ k r -> tryWith (TryF qfn k) $ -- log and ...
r (A pa (M.insert qfn k fa) sa)) -- record the pkg choice
ts
go (SChoiceF qsn gr _ ts) (A pa fa sa) =
backjump (S qsn) (avoidSet (S qsn) gr) $ -- try children in order,
backjump enableBj (S qsn) (avoidSet (S qsn) gr) $ -- try children in order,
P.mapWithKey -- when descending ...
(\ k r -> tryWith (TryS qsn k) $ -- log and ...
r (A pa fa (M.insert qsn k sa))) -- record the pkg choice
......@@ -116,8 +119,10 @@ avoidSet var gr =
CS.fromList (var : goalReasonToVars gr)
-- | Interface.
backjumpAndExplore :: Tree QGoalReason -> Log Message (Assignment, RevDepMap)
backjumpAndExplore t = toLog $ exploreLog t (A M.empty M.empty M.empty)
backjumpAndExplore :: T.EnableBackjumping
-> Tree QGoalReason -> Log Message (Assignment, RevDepMap)
backjumpAndExplore enableBj t =
toLog $ exploreLog enableBj t (A M.empty M.empty M.empty)
where
toLog :: T.Progress step fail done -> Log step done
toLog = T.foldProgress T.Step (const (T.Fail ())) T.Done
......@@ -31,7 +31,8 @@ data SolverConfig = SolverConfig {
avoidReinstalls :: Bool,
shadowPkgs :: Bool,
strongFlags :: Bool,
maxBackjumps :: Maybe Int
maxBackjumps :: Maybe Int,
enableBackjumping :: EnableBackjumping
}
-- | Run all solver phases.
......@@ -76,7 +77,7 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
prunePhase $
buildPhase
where
explorePhase = backjumpAndExplore
explorePhase = backjumpAndExplore (enableBackjumping sc)
heuristicsPhase = (if preferEasyGoalChoices sc
then P.preferEasyGoalChoices -- also leaves just one choice
else P.firstGoal) . -- after doing goal-choice heuristics, commit to the first choice (saves space)
......
......@@ -16,6 +16,7 @@
module Distribution.Client.Dependency.Types (
PreSolver(..),
Solver(..),
EnableBackjumping(..),
DependencyResolver,
ResolverPackage(..),
......@@ -105,6 +106,9 @@ instance Text PreSolver where
"choose" -> return Choose
_ -> Parse.pfail
newtype EnableBackjumping = EnableBackjumping Bool
deriving Show
-- | 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.
......
......@@ -398,9 +398,11 @@ exResolve :: ExampleDb
-> Maybe Int
-> IndepGoals
-> ReorderGoals
-> EnableBackjumping
-> [ExPreference]
-> ([String], Either String CI.InstallPlan.SolverInstallPlan)
exResolve db exts langs pkgConfigDb targets solver mbj (IndepGoals indepGoals) (ReorderGoals reorder) prefs
exResolve db exts langs pkgConfigDb targets solver mbj (IndepGoals indepGoals)
(ReorderGoals reorder) enableBj prefs
= runProgress $ resolveDependencies C.buildPlatform
compiler pkgConfigDb
solver
......@@ -425,6 +427,7 @@ exResolve db exts langs pkgConfigDb targets solver mbj (IndepGoals indepGoals) (
$ setIndependentGoals indepGoals
$ setReorderGoals reorder
$ setMaxBackjumps mbj
$ setEnableBackjumping enableBj
$ standardInstallPolicy instIdx avaiIdx targets'
toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown
toPref (ExPref n v) = PackageVersionPreference (C.PackageName n) v
......
......@@ -21,7 +21,7 @@ import Test.Tasty.QuickCheck
import qualified Distribution.Client.ComponentDeps as CD
import Distribution.Client.ComponentDeps ( Component(..)
, ComponentDep, ComponentDeps)
import Distribution.Client.Dependency.Types (Solver(..))
import Distribution.Client.Dependency.Types (EnableBackjumping(..), Solver(..))
import Distribution.Client.PkgConfigDb (pkgConfigDbFromList)
import Distribution.Client.Setup (defaultMaxBackjumps)
......@@ -35,8 +35,10 @@ tests = [
-- can affect the existence of a solution to both runs.
testProperty "target order and --reorder-goals do not affect solvability" $
\(SolverTest db targets) targetOrder reorderGoals indepGoals solver ->
let r1 = solve (ReorderGoals False) indepGoals solver targets db
r2 = solve reorderGoals indepGoals solver targets2 db
let r1 = solve' (ReorderGoals False) targets db
r2 = solve' reorderGoals targets2 db
solve' reorder = solve (EnableBackjumping True) reorder
indepGoals solver
targets2 = case targetOrder of
SameOrder -> targets
ReverseOrder -> reverse targets
......@@ -47,11 +49,22 @@ tests = [
, testProperty
"solvable without --independent-goals => solvable with --independent-goals" $
\(SolverTest db targets) reorderGoals solver ->
let r1 = solve reorderGoals (IndepGoals False) solver targets db
r2 = solve reorderGoals (IndepGoals True) solver targets db
let r1 = solve' (IndepGoals False) targets db
r2 = solve' (IndepGoals True) targets db
solve' indep = solve (EnableBackjumping True)
reorderGoals indep solver
in counterexample (showResults r1 r2) $
noneReachedBackjumpLimit [r1, r2] ==>
isRight (resultPlan r1) `implies` isRight (resultPlan r2)
, testProperty "backjumping does not affect solvability" $
\(SolverTest db targets) reorderGoals indepGoals ->
let r1 = solve' (EnableBackjumping True) targets db
r2 = solve' (EnableBackjumping False) targets db
solve' enableBj = solve enableBj reorderGoals indepGoals Modular
in counterexample (showResults r1 r2) $
noneReachedBackjumpLimit [r1, r2] ==>
isRight (resultPlan r1) === isRight (resultPlan r2)
]
where
noneReachedBackjumpLimit :: [Result] -> Bool
......@@ -74,8 +87,9 @@ tests = [
isRight (Right _) = True
isRight _ = False
solve :: ReorderGoals -> IndepGoals -> Solver -> [PN] -> TestDb -> Result
solve reorder indep solver targets (TestDb db) =
solve :: EnableBackjumping -> ReorderGoals -> IndepGoals
-> Solver -> [PN] -> TestDb -> Result
solve enableBj reorder indep solver targets (TestDb db) =
let (lg, result) =
exResolve db Nothing Nothing
(pkgConfigDbFromList [])
......@@ -84,7 +98,7 @@ solve reorder indep solver targets (TestDb db) =
-- The backjump limit prevents individual tests from using
-- too much time and memory.
(Just defaultMaxBackjumps)
indep reorder []
indep reorder enableBj []
failure :: String -> Failure
failure msg
......
......@@ -19,7 +19,7 @@ import Language.Haskell.Extension ( Extension(..)
-- cabal-install
import Distribution.Client.PkgConfigDb (PkgConfigDb, pkgConfigDbFromList)
import Distribution.Client.Dependency.Types (Solver(Modular))
import Distribution.Client.Dependency.Types (EnableBackjumping(..), Solver(Modular))
import UnitTests.Distribution.Client.Dependency.Modular.DSL
import UnitTests.Options
......@@ -244,7 +244,7 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
let (_msgs, result) = exResolve testDb testSupportedExts
testSupportedLangs testPkgConfigDb testTargets
Modular Nothing testIndepGoals (ReorderGoals False)
testSoftConstraints
(EnableBackjumping True) testSoftConstraints
when showSolverLog $ mapM_ putStrLn _msgs
case result of
Left err -> assertBool ("Unexpected error:\n" ++ err) (check testResult err)
......
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