Commit a391ddba authored by kristenk's avatar kristenk
Browse files

Add goal order parameter to the dependency solver

parent 847ed4ea
......@@ -54,6 +54,7 @@ module Distribution.Client.Dependency (
setStrongFlags,
setMaxBackjumps,
setEnableBackjumping,
setGoalOrder,
addSourcePackages,
hideInstalledPackagesSpecificByUnitId,
hideInstalledPackagesSpecificBySourcePackageId,
......@@ -119,6 +120,7 @@ import Distribution.Solver.Types.InstalledPreference
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackageConstraint
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.PackagePreferences
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
......@@ -128,6 +130,7 @@ import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SolverId
import Distribution.Solver.Types.SolverPackage
import Distribution.Solver.Types.SourcePackage
import Distribution.Solver.Types.Variable
import Data.List
( foldl', sort, sortBy, nubBy, maximumBy, intercalate, nub )
......@@ -161,7 +164,10 @@ data DepResolverParams = DepResolverParams {
depResolverShadowPkgs :: ShadowPkgs,
depResolverStrongFlags :: StrongFlags,
depResolverMaxBackjumps :: Maybe Int,
depResolverEnableBackjumping :: EnableBackjumping
depResolverEnableBackjumping :: EnableBackjumping,
-- | Function to override the solver's goal-ordering heuristics.
depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
}
showDepResolverParams :: DepResolverParams -> String
......@@ -233,7 +239,8 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex =
depResolverShadowPkgs = ShadowPkgs False,
depResolverStrongFlags = StrongFlags False,
depResolverMaxBackjumps = Nothing,
depResolverEnableBackjumping = EnableBackjumping True
depResolverEnableBackjumping = EnableBackjumping True,
depResolverGoalOrder = Nothing
}
addTargets :: [PackageName]
......@@ -308,6 +315,14 @@ setEnableBackjumping b params =
depResolverEnableBackjumping = b
}
setGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
-> DepResolverParams
-> DepResolverParams
setGoalOrder order params =
params {
depResolverGoalOrder = order
}
-- | Some packages are specific to a given compiler version and should never be
-- upgraded.
dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams
......@@ -607,7 +622,7 @@ resolveDependencies platform comp pkgConfigDB solver params =
Step (showDepResolverParams finalparams)
$ fmap (validateSolverResult platform comp indGoals)
$ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls
shadowing strFlags maxBkjumps enableBj)
shadowing strFlags maxBkjumps enableBj order)
platform comp installedPkgIndex sourcePkgIndex
pkgConfigDB preferences constraints targets
where
......@@ -623,7 +638,8 @@ resolveDependencies platform comp pkgConfigDB solver params =
shadowing
strFlags
maxBkjumps
enableBj) = dontUpgradeNonUpgradeablePackages
enableBj
order) = dontUpgradeNonUpgradeablePackages
-- TODO:
-- The modular solver can properly deal with broken
-- packages and won't select them. So the
......@@ -858,7 +874,7 @@ resolveWithoutDependencies :: DepResolverParams
resolveWithoutDependencies (DepResolverParams targets constraints
prefs defpref installedPkgIndex sourcePkgIndex
_reorderGoals _indGoals _avoidReinstalls
_shadowing _strFlags _maxBjumps _enableBj) =
_shadowing _strFlags _maxBjumps _enableBj _order) =
collectEithers (map selectPackage targets)
where
selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage
......
......@@ -35,6 +35,7 @@ module Distribution.Solver.Modular.Dependency (
, GoalReason(..)
, QGoalReason
, ResetVar(..)
, goalToVar
, goalVarToConflictSet
, varToConflictSet
, goalReasonToVars
......@@ -361,6 +362,9 @@ instance ResetVar Dep where
instance ResetVar Var where
resetVar = const
goalToVar :: Goal a -> Var a
goalToVar (Goal v _) = v
-- | Compute a singleton conflict set from a goal, containing just
-- the goal variable.
--
......
......@@ -13,10 +13,12 @@ module Distribution.Solver.Modular.Preference
, preferPackagePreferences
, preferReallyEasyGoalChoices
, requireInstalled
, sortGoals
) where
-- Reordering or pruning the tree in order to prefer or make certain choices.
import Data.Function (on)
import qualified Data.List as L
import qualified Data.Map as M
#if !MIN_VERSION_base(4,8,0)
......@@ -35,6 +37,7 @@ import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackageConstraint
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.PackagePreferences
import Distribution.Solver.Types.Variable
import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Flag
......@@ -275,6 +278,21 @@ avoidReinstalls p = trav go
x
go x = x
-- | Sort all goals using the provided function.
sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> Tree a -> Tree a
sortGoals variableOrder = trav go
where
go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys goalOrder xs)
go x = x
goalOrder :: Goal QPN -> Goal QPN -> Ordering
goalOrder = variableOrder `on` (varToVariable . goalToVar)
varToVariable :: Var QPN -> Variable QPN
varToVariable (P qpn) = PackageVar qpn
varToVariable (F (FN (PI qpn _) fn)) = FlagVar qpn fn
varToVariable (S (SN (PI qpn _) stanza)) = StanzaVar qpn stanza
-- | Always choose the first goal in the list next, abandoning all
-- other choices.
--
......
......@@ -19,6 +19,7 @@ import Distribution.Solver.Types.PackagePreferences
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.Variable
import Distribution.Solver.Modular.Assignment
import Distribution.Solver.Modular.Builder
......@@ -56,7 +57,8 @@ data SolverConfig = SolverConfig {
shadowPkgs :: ShadowPkgs,
strongFlags :: StrongFlags,
maxBackjumps :: Maybe Int,
enableBackjumping :: EnableBackjumping
enableBackjumping :: EnableBackjumping,
goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
}
-- | Run all solver phases.
......@@ -103,13 +105,20 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
where
explorePhase = backjumpAndExplore (enableBackjumping sc)
detectCycles = traceTree "cycles.json" id . detectCyclesPhase
heuristicsPhase = (if asBool (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)
traceTree "heuristics.json" id .
P.deferWeakFlagChoices .
P.deferSetupChoices .
P.preferBaseGoalChoice
heuristicsPhase =
let heuristicsTree = traceTree "heuristics.json" id
in case goalOrder sc of
Nothing -> (if asBool (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)
heuristicsTree .
P.deferWeakFlagChoices .
P.deferSetupChoices .
P.preferBaseGoalChoice
Just order -> P.firstGoal .
heuristicsTree .
P.sortGoals order
preferencesPhase = P.preferLinked .
P.preferPackagePreferences userPrefs
validationPhase = traceTree "validated.json" id .
......
module Distribution.Solver.Types.Variable where
import Distribution.Solver.Types.OptionalStanza
import Distribution.PackageDescription (FlagName)
-- | Variables used by the dependency solver. This type is similar to the
-- internal 'Var' type, except that flags and stanzas are associated with
-- package names instead of package instances.
data Variable qpn =
PackageVar qpn
| FlagVar qpn FlagName
| StanzaVar qpn OptionalStanza
deriving Eq
......@@ -281,6 +281,7 @@ executable cabal
Distribution.Solver.Types.SolverId
Distribution.Solver.Types.SolverPackage
Distribution.Solver.Types.SourcePackage
Distribution.Solver.Types.Variable
Distribution.Solver.Modular
Distribution.Solver.Modular.Assignment
Distribution.Solver.Modular.Builder
......
......@@ -11,6 +11,8 @@ module UnitTests.Distribution.Solver.Modular.DSL (
, ExamplePkgName
, ExampleAvailable(..)
, ExampleInstalled(..)
, ExampleQualifier(..)
, ExampleVar(..)
, exAv
, exInst
, exFlag
......@@ -23,9 +25,10 @@ module UnitTests.Distribution.Solver.Modular.DSL (
-- base
import Data.Either (partitionEithers)
import Data.Maybe (catMaybes)
import Data.List (nub)
import Data.Maybe (catMaybes, isNothing)
import Data.List (elemIndex, nub)
import Data.Monoid
import Data.Ord (comparing)
import Data.Version
import qualified Data.Map as Map
......@@ -52,10 +55,12 @@ import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
import qualified Distribution.Solver.Types.PackageIndex as CI.PackageIndex
import qualified Distribution.Solver.Types.PackagePath as P
import qualified Distribution.Solver.Types.PkgConfigDb as PC
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SolverPackage
import Distribution.Solver.Types.SourcePackage
import Distribution.Solver.Types.Variable
{-------------------------------------------------------------------------------
Example package database DSL
......@@ -143,6 +148,17 @@ data ExampleAvailable = ExAv {
, exAvDeps :: ComponentDeps [ExampleDependency]
} deriving Show
data ExampleVar =
P ExampleQualifier ExamplePkgName
| F ExampleQualifier ExamplePkgName ExampleFlagName
| S ExampleQualifier ExamplePkgName OptionalStanza
data ExampleQualifier =
None
| Indep Int
| Setup ExamplePkgName
| IndepSetup Int ExamplePkgName
-- | Constructs an 'ExampleAvailable' package for the 'ExampleDb',
-- given:
--
......@@ -398,10 +414,11 @@ exResolve :: ExampleDb
-> IndependentGoals
-> ReorderGoals
-> EnableBackjumping
-> Maybe [ExampleVar]
-> [ExPreference]
-> ([String], Either String CI.InstallPlan.SolverInstallPlan)
exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder
enableBj prefs
enableBj vars prefs
= runProgress $ resolveDependencies C.buildPlatform
compiler pkgConfigDb
solver
......@@ -427,10 +444,34 @@ exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder
$ setReorderGoals reorder
$ setMaxBackjumps mbj
$ setEnableBackjumping enableBj
$ setGoalOrder goalOrder
$ standardInstallPolicy instIdx avaiIdx targets'
toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown
toPref (ExPref n v) = PackageVersionPreference (C.PackageName n) v
goalOrder :: Maybe (Variable P.QPN -> Variable P.QPN -> Ordering)
goalOrder = (orderFromList . map toVariable) `fmap` vars
-- Sort elements in the list ahead of elements not in the list. Otherwise,
-- follow the order in the list.
orderFromList :: Eq a => [a] -> a -> a -> Ordering
orderFromList xs =
comparing $ \x -> let i = elemIndex x xs in (isNothing i, i)
toVariable :: ExampleVar -> Variable P.QPN
toVariable (P q pn) = PackageVar (toQPN q pn)
toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.FlagName fn)
toVariable (S q pn stanza) = StanzaVar (toQPN q pn) stanza
toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN
toQPN q pn = P.Q pp (C.PackageName pn)
where
pp = case q of
None -> P.PackagePath P.DefaultNamespace P.Unqualified
Indep x -> P.PackagePath (P.Independent x) P.Unqualified
Setup p -> P.PackagePath P.DefaultNamespace (P.Setup (C.PackageName p))
IndepSetup x p -> P.PackagePath (P.Independent x) (P.Setup (C.PackageName p))
extractInstallPlan :: CI.InstallPlan.SolverInstallPlan
-> [(ExamplePkgName, ExamplePkgVersion)]
extractInstallPlan = catMaybes . map confPkg . CI.InstallPlan.toList
......
......@@ -102,7 +102,7 @@ solve enableBj reorder indep solver targets (TestDb db) =
-- The backjump limit prevents individual tests from using
-- too much time and memory.
(Just defaultMaxBackjumps)
indep reorder enableBj []
indep reorder enableBj Nothing []
failure :: String -> Failure
failure msg
......@@ -223,12 +223,12 @@ arbitraryComponentDep :: TestDb -> Gen (ComponentDep [ExampleDependency])
arbitraryComponentDep db = do
comp <- arbitrary
deps <- case comp of
ComponentSetup -> smallListOf (arbitraryExDep db Setup)
_ -> boundedListOf 5 (arbitraryExDep db NonSetup)
ComponentSetup -> smallListOf (arbitraryExDep db SetupDep)
_ -> boundedListOf 5 (arbitraryExDep db NonSetupDep)
return (comp, deps)
-- | Location of an 'ExampleDependency'. It determines which values are valid.
data ExDepLocation = Setup | NonSetup
data ExDepLocation = SetupDep | NonSetupDep
arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency
arbitraryExDep db@(TestDb pkgs) level =
......@@ -247,13 +247,13 @@ arbitraryExDep db@(TestDb pkgs) level =
]
in oneof $
case level of
NonSetup -> flag : other
Setup -> other
NonSetupDep -> flag : other
SetupDep -> other
arbitraryDeps :: TestDb -> Gen Dependencies
arbitraryDeps db = frequency
[ (1, return NotBuildable)
, (20, Buildable <$> smallListOf (arbitraryExDep db NonSetup))
, (20, Buildable <$> smallListOf (arbitraryExDep db NonSetupDep))
]
arbitraryFlagName :: Gen String
......
......@@ -172,6 +172,7 @@ data SolverTest = SolverTest {
, testTargets :: [String]
, testResult :: SolverResult
, testIndepGoals :: IndependentGoals
, testGoalOrder :: Maybe [ExampleVar]
, testSoftConstraints :: [ExPreference]
, testDb :: ExampleDb
, testSupportedExts :: Maybe [Extension]
......@@ -246,6 +247,7 @@ mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest {
, testTargets = targets
, testResult = result
, testIndepGoals = IndependentGoals False
, testGoalOrder = Nothing
, testSoftConstraints = []
, testDb = db
, testSupportedExts = exts
......@@ -259,7 +261,7 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
let (_msgs, result) = exResolve testDb testSupportedExts
testSupportedLangs testPkgConfigDb testTargets
Modular Nothing testIndepGoals (ReorderGoals False)
(EnableBackjumping True) testSoftConstraints
(EnableBackjumping True) testGoalOrder 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