Add a goal order parameter to the dependency solver

cabal-install/Distribution/Client/Dependency.hs

@@ -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

cabal-install/Distribution/Solver/Modular/Dependency.hs

@@ -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.
 --

cabal-install/Distribution/Solver/Modular/Preference.hs

@@ -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
@@ -191,8 +194,8 @@ processPackageConstraintS s c b' (LabeledPackageConstraint pc src) r = go pc
 -- by selectively disabling choices that have been ruled out by global user
 -- constraints.
 enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint]
-                          -> Tree QGoalReason
-                          -> Tree QGoalReason
+                          -> Tree a
+                          -> Tree a
 enforcePackageConstraints pcs = trav go
   where
     go (PChoiceF qpn@(Q pp pn)              gr      ts) =
@@ -220,7 +223,7 @@ enforcePackageConstraints pcs = trav go
 -- be run after user preferences have been enforced. For manual flags,
 -- it checks if a user choice has been made. If not, it disables all but
 -- the first choice.
-enforceManualFlags :: Tree QGoalReason -> Tree QGoalReason
+enforceManualFlags :: Tree a -> Tree a
 enforceManualFlags = trav go
   where
     go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $
@@ -234,7 +237,7 @@ enforceManualFlags = trav go
     go x                                                   = x
 
 -- | Require installed packages.
-requireInstalled :: (PN -> Bool) -> Tree QGoalReason -> Tree QGoalReason
+requireInstalled :: (PN -> Bool) -> Tree a -> Tree a
 requireInstalled p = trav go
   where
     go (PChoiceF v@(Q _ pn) gr cs)
@@ -258,7 +261,7 @@ requireInstalled p = trav go
 -- they are, perhaps this should just result in trying to reinstall those other
 -- packages as well. However, doing this all neatly in one pass would require to
 -- change the builder, or at least to change the goal set after building.
-avoidReinstalls :: (PN -> Bool) -> Tree QGoalReason -> Tree QGoalReason
+avoidReinstalls :: (PN -> Bool) -> Tree a -> Tree a
 avoidReinstalls p = trav go
   where
     go (PChoiceF qpn@(Q _ pn) gr cs)
@@ -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.
 --
@@ -371,10 +389,10 @@ type EnforceSIR = Reader (Map (PI PN) QPN)
 -- (that is, package name + package version) there can be at most one qualified
 -- goal resolving to that instance (there may be other goals _linking_ to that
 -- instance however).
-enforceSingleInstanceRestriction :: Tree QGoalReason -> Tree QGoalReason
+enforceSingleInstanceRestriction :: Tree a -> Tree a
 enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go
   where
-    go :: TreeF QGoalReason (EnforceSIR (Tree QGoalReason)) -> EnforceSIR (Tree QGoalReason)
+    go :: TreeF a (EnforceSIR (Tree a)) -> EnforceSIR (Tree a)
 
     -- We just verify package choices.
     go (PChoiceF qpn gr cs) =
@@ -383,7 +401,7 @@ enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go
       innM _otherwise
 
     -- The check proper
-    goP :: QPN -> POption -> EnforceSIR (Tree QGoalReason) -> EnforceSIR (Tree QGoalReason)
+    goP :: QPN -> POption -> EnforceSIR (Tree a) -> EnforceSIR (Tree a)
     goP qpn@(Q _ pn) (POption i linkedTo) r = do
       let inst = PI pn i
       env <- ask

cabal-install/Distribution/Solver/Modular/Solver.hs

@@ -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,15 +105,22 @@ 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 .
-                       P.preferLinked
-    preferencesPhase = P.preferPackagePreferences userPrefs
+    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 .
                        P.enforceManualFlags . -- can only be done after user constraints
                        P.enforcePackageConstraints userConstraints .

cabal-install/Distribution/Solver/Types/Variable.hs

@@ -0,0 +1,14 @@
+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

cabal-install/cabal-install.cabal

@@ -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

cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs

@@ -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