testsuite: Add userConstraints modifier

This allows you to add constraints to solver tests using the
UserConstraintSource syntax, which is useful when you want to check how
these UserConstraintSources are interpreted and influence the solver.

Author: mpickering

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

@@ -68,6 +68,7 @@ import qualified Distribution.Package as C hiding
   )
 import qualified Distribution.PackageDescription as C
 import qualified Distribution.PackageDescription.Check as C
+import Distribution.Parsec
 import qualified Distribution.Simple.PackageIndex as C.PackageIndex
 import Distribution.Simple.Setup (BooleanFlag (..))
 import qualified Distribution.System as C
@@ -80,6 +81,7 @@ import Language.Haskell.Extension (Extension (..), Language (..))
 -- cabal-install
 import Distribution.Client.Dependency
 import qualified Distribution.Client.SolverInstallPlan as CI.SolverInstallPlan
+import Distribution.Client.Targets
 import Distribution.Client.Types
 
 import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
@@ -794,6 +796,7 @@ exResolve
   -> SolveExecutables
   -> Maybe (Variable P.QPN -> Variable P.QPN -> Ordering)
   -> [ExConstraint]
+  -> [String]
   -> [ExPreference]
   -> C.Verbosity
   -> EnableAllTests
@@ -817,6 +820,7 @@ exResolve
   solveExes
   goalOrder
   constraints
+  userConstraints
   prefs
   verbosity
   enableAllTests =
@@ -847,23 +851,24 @@ exResolve
         | otherwise = []
       targets' = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets
       params =
-        addConstraints (fmap toConstraint constraints) $
-          addConstraints (fmap toLpc enableTests) $
-            addPreferences (fmap toPref prefs) $
-              setCountConflicts countConflicts $
-                setFineGrainedConflicts fineGrainedConflicts $
-                  setMinimizeConflictSet minimizeConflictSet $
-                    setIndependentGoals indepGoals $
-                      (if asBool prefOldest then setPreferenceDefault PreferAllOldest else id) $
-                        setReorderGoals reorder $
-                          setMaxBackjumps mbj $
-                            setAllowBootLibInstalls allowBootLibInstalls $
-                              setOnlyConstrained onlyConstrained $
-                                setEnableBackjumping enableBj $
-                                  setSolveExecutables solveExes $
-                                    setGoalOrder goalOrder $
-                                      setSolverVerbosity verbosity $
-                                        standardInstallPolicy instIdx avaiIdx targets'
+        addConstraints (map parseConstraint userConstraints) $
+          addConstraints (fmap toConstraint constraints) $
+            addConstraints (fmap toLpc enableTests) $
+              addPreferences (fmap toPref prefs) $
+                setCountConflicts countConflicts $
+                  setFineGrainedConflicts fineGrainedConflicts $
+                    setMinimizeConflictSet minimizeConflictSet $
+                      setIndependentGoals indepGoals $
+                        (if asBool prefOldest then setPreferenceDefault PreferAllOldest else id) $
+                          setReorderGoals reorder $
+                            setMaxBackjumps mbj $
+                              setAllowBootLibInstalls allowBootLibInstalls $
+                                setOnlyConstrained onlyConstrained $
+                                  setEnableBackjumping enableBj $
+                                    setSolveExecutables solveExes $
+                                      setGoalOrder goalOrder $
+                                        setSolverVerbosity verbosity $
+                                          standardInstallPolicy instIdx avaiIdx targets'
       toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown
 
       toConstraint (ExVersionConstraint scope v) =
@@ -873,6 +878,12 @@ exResolve
       toConstraint (ExStanzaConstraint scope stanzas) =
         toLpc $ PackageConstraint scope (PackagePropertyStanzas stanzas)
 
+      parseConstraint :: String -> LabeledPackageConstraint
+      parseConstraint str =
+        case explicitEitherParsec parsec str of
+          Left err -> error ("Bad user constraint: " ++ err)
+          Right user_constraint -> toLpc (userToPackageConstraint user_constraint)
+
       toPref (ExPkgPref n v) = PackageVersionPreference (C.mkPackageName n) v
       toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas
 

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

@@ -15,6 +15,7 @@ module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils
   , disableSolveExecutables
   , goalOrder
   , constraints
+  , userConstraints
   , preferences
   , setVerbose
   , enableAllTests
@@ -95,6 +96,9 @@ goalOrder order test = test{testGoalOrder = Just order}
 constraints :: [ExConstraint] -> SolverTest -> SolverTest
 constraints cs test = test{testConstraints = cs}
 
+userConstraints :: [String] -> SolverTest -> SolverTest
+userConstraints cs test = test{testUserConstraints = cs}
+
 preferences :: [ExPreference] -> SolverTest -> SolverTest
 preferences prefs test = test{testSoftConstraints = prefs}
 
@@ -126,6 +130,7 @@ data SolverTest = SolverTest
   , testGoalOrder :: Maybe [ExampleVar]
   , testConstraints :: [ExConstraint]
   , testSoftConstraints :: [ExPreference]
+  , testUserConstraints :: [String]
   , testVerbosity :: Verbosity
   , testDb :: ExampleDb
   , testSupportedExts :: Maybe [Extension]
@@ -228,6 +233,7 @@ mkTestExtLangPC exts langs mPkgConfigDb db label targets result =
     , testSolveExecutables = SolveExecutables True
     , testGoalOrder = Nothing
     , testConstraints = []
+    , testUserConstraints = []
     , testSoftConstraints = []
     , testVerbosity = normal
     , testDb = db
@@ -260,6 +266,7 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
             testSolveExecutables
             (sortGoals <$> testGoalOrder)
             testConstraints
+            testUserConstraints
             testSoftConstraints
             testVerbosity
             testEnableAllTests

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

@@ -244,6 +244,7 @@ solve enableBj fineGrainedConflicts reorder countConflicts indep prefOldest goal
             (SolveExecutables True)
             (unVarOrdering <$> goalOrder)
             (testConstraints test)
+            []
             (testPreferences test)
             normal
             (EnableAllTests False)