Merge pull request #3510 from grayjay/issue-3489

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

+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

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

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

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

@@ -18,6 +18,7 @@ import Language.Haskell.Extension ( Extension(..)
                                   , KnownExtension(..), Language(..))
 
 -- cabal-install
+import Distribution.Solver.Types.OptionalStanza
 import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigDbFromList)
 import Distribution.Solver.Types.Settings
 import Distribution.Client.Dependency.Types
@@ -133,9 +134,9 @@ tests = [
         ]
     , testGroup "Independent goals" [
           runTest $ indep $ mkTest db16 "indepGoals1" ["A", "B"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("E", 1)])
-        , runTest $ indep $ mkTest db17 "indepGoals2" ["A", "B"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)])
-        , runTest $ indep $ mkTest db19 "indepGoals3" ["D", "E", "F"] anySolverFailure -- The target order is important.
-        , runTest $ indep $ mkTest db20 "indepGoals4" ["C", "A", "B"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2)])
+        , runTest $ testIndepGoals2 "indepGoals2"
+        , runTest $ testIndepGoals3 "indepGoals3"
+        , runTest $ testIndepGoals4 "indepGoals4"
         , runTest $ indep $ mkTest db23 "indepGoals5" ["X", "Y"] (SolverSuccess [("A", 1), ("A", 2), ("B", 1), ("C", 1), ("C", 2), ("X", 1), ("Y", 1)])
         , runTest $ indep $ mkTest db24 "indepGoals6" ["X", "Y"] (SolverSuccess [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("X", 1), ("Y", 1)])
         ]
@@ -154,15 +155,20 @@ tests = [
         ]
     ]
   where
-    -- | Combinator to turn on --independent-goals behavior, i.e. solve
-    -- for the goals as if we were solving for each goal independently.
-    -- (This doesn't really work well at the moment, see #2842)
-    indep test      = test { testIndepGoals = IndependentGoals True }
     soft prefs test = test { testSoftConstraints = prefs }
     mkvrThis        = V.thisVersion . makeV
     mkvrOrEarlier   = V.orEarlierVersion . makeV
     makeV v         = V.Version [v,0,0] []
 
+-- | Combinator to turn on --independent-goals behavior, i.e. solve
+-- for the goals as if we were solving for each goal independently.
+-- (This doesn't really work well at the moment, see #2842)
+indep :: SolverTest -> SolverTest
+indep test = test { testIndepGoals = IndependentGoals True }
+
+goalOrder :: [ExampleVar] -> SolverTest -> SolverTest
+goalOrder order test = test { testGoalOrder = Just order }
+
 {-------------------------------------------------------------------------------
   Solver tests
 -------------------------------------------------------------------------------}
@@ -172,6 +178,7 @@ data SolverTest = SolverTest {
   , testTargets        :: [String]
   , testResult         :: SolverResult
   , testIndepGoals     :: IndependentGoals
+  , testGoalOrder      :: Maybe [ExampleVar]
   , testSoftConstraints :: [ExPreference]
   , testDb             :: ExampleDb
   , testSupportedExts  :: Maybe [Extension]
@@ -246,6 +253,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 +267,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)
@@ -602,23 +610,41 @@ db16 = [
   , Right $ exAv "E" 1 []
   ]
 
--- | This database checks that when the solver discovers a constraint on a
+-- | This test checks that when the solver discovers a constraint on a
 -- package's version after choosing to link that package, it can backtrack to
 -- try alternative versions for the linked-to package. See pull request #3327.
 --
 -- When A and B are installed as independent goals, their dependencies on C
 -- must be linked. Since C depends on D, A and B's dependencies on D must also
--- be linked. This test relies on the fact that the solver chooses D-2 for both
--- 0.D and 1.D before it encounters the test suites' constraints. The solver
--- must backtrack to try D-1 for both 0.D and 1.D.
-db17 :: ExampleDb
-db17 = [
-    Right $ exAv "A" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1]
-  , Right $ exAv "B" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1]
-  , Right $ exAv "C" 1 [ExAny "D"]
-  , Right $ exAv "D" 1 []
-  , Right $ exAv "D" 2 []
-  ]
+-- be linked. This test fixes the goal order so that the solver chooses D-2 for
+-- both 0.D and 1.D before it encounters the test suites' constraints. The
+-- solver must backtrack to try D-1 for both 0.D and 1.D.
+testIndepGoals2 :: String -> SolverTest
+testIndepGoals2 name =
+    goalOrder goals $ indep $
+    mkTest db name ["A", "B"] $
+    SolverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)]
+  where
+    db :: ExampleDb
+    db = [
+        Right $ exAv "A" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1]
+      , Right $ exAv "B" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1]
+      , Right $ exAv "C" 1 [ExAny "D"]
+      , Right $ exAv "D" 1 []
+      , Right $ exAv "D" 2 []
+      ]
+
+    goals :: [ExampleVar]
+    goals = [
+        P (Indep 0) "A"
+      , P (Indep 0) "C"
+      , P (Indep 0) "D"
+      , P (Indep 1) "B"
+      , P (Indep 1) "C"
+      , P (Indep 1) "D"
+      , S (Indep 1) "B" TestStanzas
+      , S (Indep 0) "A" TestStanzas
+      ]
 
 -- | Issue #2834
 -- When both A and B are installed as independent goals, their dependencies on
@@ -676,34 +702,76 @@ db18 = [
 -- >   \ | \ / | /
 -- >    \|  V  |/
 -- >     D  F  E
-db19 :: ExampleDb
-db19 = [
-    Right $ exAv "A" 1 [ExAny "C"]
-  , Right $ exAv "B" 1 [ExAny "C"]
-  , Right $ exAv "C" 1 []
-  , Right $ exAv "C" 2 []
-  , Right $ exAv "D" 1 [ExAny "A", ExFix "C" 1]
-  , Right $ exAv "E" 1 [ExAny "B", ExFix "C" 2]
-  , Right $ exAv "F" 1 [ExAny "A", ExAny "B"]
-  ]
+testIndepGoals3 :: String -> SolverTest
+testIndepGoals3 name =
+    goalOrder goals $ indep $
+    mkTest db name ["D", "E", "F"] anySolverFailure
+  where
+    db :: ExampleDb
+    db = [
+        Right $ exAv "A" 1 [ExAny "C"]
+      , Right $ exAv "B" 1 [ExAny "C"]
+      , Right $ exAv "C" 1 []
+      , Right $ exAv "C" 2 []
+      , Right $ exAv "D" 1 [ExAny "A", ExFix "C" 1]
+      , Right $ exAv "E" 1 [ExAny "B", ExFix "C" 2]
+      , Right $ exAv "F" 1 [ExAny "A", ExAny "B"]
+      ]
+
+    goals :: [ExampleVar]
+    goals = [
+        P (Indep 0) "D"
+      , P (Indep 0) "C"
+      , P (Indep 0) "A"
+      , P (Indep 1) "E"
+      , P (Indep 1) "C"
+      , P (Indep 1) "B"
+      , P (Indep 2) "F"
+      , P (Indep 2) "B"
+      , P (Indep 2) "C"
+      , P (Indep 2) "A"
+      ]
 
--- | This database tests that the solver correctly backjumps when dependencies
+-- | This test checks that the solver correctly backjumps when dependencies
 -- of linked packages are not linked. It is an example where the conflict set
 -- from enforcing the single instance restriction is not sufficient. See pull
 -- request #3327.