Merge pull request #3929 from grayjay/stanza-preference-tests

Add unit tests for solver stanza preferences.

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

 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 -- | DSL for testing the modular solver
 module UnitTests.Distribution.Solver.Modular.DSL (
     ExampleDependency(..)
@@ -14,6 +15,7 @@ module UnitTests.Distribution.Solver.Modular.DSL (
   , ExampleInstalled(..)
   , ExampleQualifier(..)
   , ExampleVar(..)
+  , EnableAllTests(..)
   , exAv
   , exInst
   , exFlag
@@ -42,6 +44,7 @@ import qualified Distribution.Package              as C
   hiding (HasUnitId(..))
 import qualified Distribution.PackageDescription   as C
 import qualified Distribution.Simple.PackageIndex  as C.PackageIndex
+import           Distribution.Simple.Setup (BooleanFlag(..))
 import qualified Distribution.System               as C
 import qualified Distribution.Version              as C
 import Language.Haskell.Extension (Extension(..), Language)
@@ -152,7 +155,9 @@ exFlag :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency]
        -> ExampleDependency
 exFlag n t e = ExFlag n (Buildable t) (Buildable e)
 
-data ExPreference = ExPref String ExampleVersionRange
+data ExPreference =
+    ExPkgPref ExamplePkgName ExampleVersionRange
+  | ExStanzaPref ExamplePkgName [OptionalStanza]
 
 data ExampleAvailable = ExAv {
     exAvName    :: ExamplePkgName
@@ -171,6 +176,10 @@ data ExampleQualifier =
   | Setup ExamplePkgName
   | IndepSetup Int ExamplePkgName
 
+-- | Whether to enable tests in all packages in a test case.
+newtype EnableAllTests = EnableAllTests Bool
+  deriving BooleanFlag
+
 -- | Constructs an 'ExampleAvailable' package for the 'ExampleDb',
 -- given:
 --
@@ -467,9 +476,10 @@ exResolve :: ExampleDb
           -> EnableBackjumping
           -> Maybe [ExampleVar]
           -> [ExPreference]
+          -> EnableAllTests
           -> Progress String String CI.SolverInstallPlan.SolverInstallPlan
 exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder
-          enableBj vars prefs
+          enableBj vars prefs enableAllTests
     = resolveDependencies C.buildPlatform compiler pkgConfigDb solver params
   where
     defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag
@@ -482,9 +492,11 @@ exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder
                        packageIndex       = exAvIdx avai
                      , packagePreferences = Map.empty
                      }
-    enableTests  = fmap (\p -> PackageConstraintStanzas
-                              (C.mkPackageName p) [TestStanzas])
-                       (exDbPkgs db)
+    enableTests
+        | asBool enableAllTests = fmap (\p -> PackageConstraintStanzas
+                                              (C.mkPackageName p) [TestStanzas])
+                                       (exDbPkgs db)
+        | otherwise             = []
     targets'     = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets
     params       =   addPreferences (fmap toPref prefs)
                    $ addConstraints (fmap toLpc enableTests)
@@ -495,7 +507,9 @@ exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder
                    $ setGoalOrder goalOrder
                    $ standardInstallPolicy instIdx avaiIdx targets'
     toLpc     pc = LabeledPackageConstraint pc ConstraintSourceUnknown
-    toPref (ExPref n v) = PackageVersionPreference (C.mkPackageName n) v
+
+    toPref (ExPkgPref n v)          = PackageVersionPreference (C.mkPackageName n) v
+    toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas
 
     goalOrder :: Maybe (Variable P.QPN -> Variable P.QPN -> Ordering)
     goalOrder = (orderFromList . map toVariable) `fmap` vars

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

@@ -106,7 +106,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 Nothing []
+                  indep reorder enableBj Nothing [] (EnableAllTests True)
 
       failure :: String -> Failure
       failure msg

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

@@ -55,15 +55,15 @@ tests = [
         , runTest $ indep $ mkTest db18 "linkFlags3"  ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)])
         ]
     , testGroup "Stanzas" [
-          runTest $         mkTest db5 "simpleTest1" ["C"]      (solverSuccess [("A", 2), ("C", 1)])
-        , runTest $         mkTest db5 "simpleTest2" ["D"]      anySolverFailure
-        , runTest $         mkTest db5 "simpleTest3" ["E"]      (solverSuccess [("A", 1), ("E", 1)])
-        , runTest $         mkTest db5 "simpleTest4" ["F"]      anySolverFailure -- TODO
-        , runTest $         mkTest db5 "simpleTest5" ["G"]      (solverSuccess [("A", 2), ("G", 1)])
-        , runTest $         mkTest db5 "simpleTest6" ["E", "G"] anySolverFailure
-        , runTest $ indep $ mkTest db5 "simpleTest7" ["E", "G"] (solverSuccess [("A", 1), ("A", 2), ("E", 1), ("G", 1)])
-        , runTest $         mkTest db6 "depsWithTests1" ["C"]      (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
-        , runTest $ indep $ mkTest db6 "depsWithTests2" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)])
+          runTest $         enableAllTests $ mkTest db5 "simpleTest1" ["C"]      (solverSuccess [("A", 2), ("C", 1)])
+        , runTest $         enableAllTests $ mkTest db5 "simpleTest2" ["D"]      anySolverFailure
+        , runTest $         enableAllTests $ mkTest db5 "simpleTest3" ["E"]      (solverSuccess [("A", 1), ("E", 1)])
+        , runTest $         enableAllTests $ mkTest db5 "simpleTest4" ["F"]      anySolverFailure -- TODO
+        , runTest $         enableAllTests $ mkTest db5 "simpleTest5" ["G"]      (solverSuccess [("A", 2), ("G", 1)])
+        , runTest $         enableAllTests $ mkTest db5 "simpleTest6" ["E", "G"] anySolverFailure
+        , runTest $ indep $ enableAllTests $ mkTest db5 "simpleTest7" ["E", "G"] (solverSuccess [("A", 1), ("A", 2), ("E", 1), ("G", 1)])
+        , runTest $         enableAllTests $ mkTest db6 "depsWithTests1" ["C"]      (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
+        , runTest $ indep $ enableAllTests $ mkTest db6 "depsWithTests2" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)])
         ]
     , testGroup "Setup dependencies" [
           runTest $         mkTest db7  "setupDeps1" ["B"] (solverSuccess [("A", 2), ("B", 1)])
@@ -110,23 +110,36 @@ tests = [
         , runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (solverSuccess [("A",1),("B",1),("C",1)])
         ]
 
-     , testGroup "Soft Constraints" [
-          runTest $ soft [ ExPref "A" $ mkvrThis 1]      $ mkTest db13 "selectPreferredVersionSimple" ["A"] (solverSuccess [("A", 1)])
-        , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionSimple2" ["A"] (solverSuccess [("A", 2)])
-        , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 2
-                         , ExPref "A" $ mkvrOrEarlier 1] $ mkTest db13 "selectPreferredVersionMultiple" ["A"] (solverSuccess [("A", 1)])
-        , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 1
-                         , ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple2" ["A"] (solverSuccess [("A", 1)])
-        , runTest $ soft [ ExPref "A" $ mkvrThis 1
-                         , ExPref "A" $ mkvrThis 2] $ mkTest db13 "selectPreferredVersionMultiple3" ["A"] (solverSuccess [("A", 2)])
-        , runTest $ soft [ ExPref "A" $ mkvrThis 1
-                         , ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple4" ["A"] (solverSuccess [("A", 1)])
+     , testGroup "Package Preferences" [
+          runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1]      $ mkTest db13 "selectPreferredVersionSimple" ["A"] (solverSuccess [("A", 1)])
+        , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionSimple2" ["A"] (solverSuccess [("A", 2)])
+        , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 2
+                                , ExPkgPref "A" $ mkvrOrEarlier 1] $ mkTest db13 "selectPreferredVersionMultiple" ["A"] (solverSuccess [("A", 1)])
+        , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 1
+                                , ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple2" ["A"] (solverSuccess [("A", 1)])
+        , runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1
+                                , ExPkgPref "A" $ mkvrThis 2] $ mkTest db13 "selectPreferredVersionMultiple3" ["A"] (solverSuccess [("A", 2)])
+        , runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1
+                                , ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple4" ["A"] (solverSuccess [("A", 1)])
+        ]
+     , testGroup "Stanza Preferences" [
+          runTest $
+          mkTest dbStanzaPreferences1 "disable tests by default" ["pkg"] $
+          solverSuccess [("pkg", 1)]
+
+        , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $
+          mkTest dbStanzaPreferences1 "enable tests with testing preference" ["pkg"] $
+          solverSuccess [("pkg", 1), ("test-dep", 1)]
+
+        , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $
+          mkTest dbStanzaPreferences2 "disable testing when it's not possible" ["pkg"] $
+          solverSuccess [("pkg", 1)]
         ]
      , testGroup "Buildable Field" [
           testBuildable "avoid building component with unknown dependency" (ExAny "unknown")
         , testBuildable "avoid building component with unknown extension" (ExExt (UnknownExtension "unknown"))
         , testBuildable "avoid building component with unknown language" (ExLang (UnknownLanguage "unknown"))
-        , runTest $ mkTest dbBuildable1 "choose flags that set buildable to false" ["pkg"] (solverSuccess [("flag1-false", 1), ("flag2-true", 1), ("pkg", 1)])
+        , runTest $ enableAllTests $ mkTest dbBuildable1 "choose flags that set buildable to false" ["pkg"] (solverSuccess [("flag1-false", 1), ("flag2-true", 1), ("pkg", 1)])
         , runTest $ mkTest dbBuildable2 "choose version that sets buildable to false" ["A"] (solverSuccess [("A", 1), ("B", 2)])
          ]
     , testGroup "Pkg-config dependencies" [
@@ -179,7 +192,6 @@ tests = [
         ]
     ]
   where
-    soft prefs test = test { testSoftConstraints = prefs }
     mkvrThis        = V.thisVersion . makeV
     mkvrOrEarlier   = V.orEarlierVersion . makeV
     makeV v         = V.mkVersion [v,0,0]
@@ -192,6 +204,12 @@ indep test = test { testIndepGoals = IndependentGoals True }
 goalOrder :: [ExampleVar] -> SolverTest -> SolverTest
 goalOrder order test = test { testGoalOrder = Just order }
 
+preferences :: [ExPreference] -> SolverTest -> SolverTest
+preferences prefs test = test { testSoftConstraints = prefs }
+
+enableAllTests :: SolverTest -> SolverTest
+enableAllTests test = test { testEnableAllTests = EnableAllTests True }
+
 data GoalOrder = FixedGoalOrder | DefaultGoalOrder
 
 {-------------------------------------------------------------------------------
@@ -209,6 +227,7 @@ data SolverTest = SolverTest {
   , testSupportedExts  :: Maybe [Extension]
   , testSupportedLangs :: Maybe [Language]
   , testPkgConfigDb    :: PkgConfigDb
+  , testEnableAllTests :: EnableAllTests
   }
 
 -- | Expected result of a solver test.
@@ -296,6 +315,7 @@ mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest {
   , testSupportedExts  = exts
   , testSupportedLangs = langs
   , testPkgConfigDb    = pkgConfigDbFromList pkgConfigDb
+  , testEnableAllTests = EnableAllTests False
   }
 
 runTest :: SolverTest -> TF.TestTree
@@ -305,6 +325,7 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
                      testSupportedLangs testPkgConfigDb testTargets
                      Modular Nothing testIndepGoals (ReorderGoals False)
                      (EnableBackjumping True) testGoalOrder testSoftConstraints
+                     testEnableAllTests
           printMsg msg = if showSolverLog
                          then putStrLn msg
                          else return ()
@@ -586,6 +607,17 @@ db13 = [
   , Right $ exAv "A" 3 []
   ]
 
+dbStanzaPreferences1 :: ExampleDb
+dbStanzaPreferences1 = [
+    Right $ exAv "pkg" 1 [] `withTest` ExTest "test" [ExAny "test-dep"]
+  , Right $ exAv "test-dep" 1 []
+  ]
+
+dbStanzaPreferences2 :: ExampleDb
+dbStanzaPreferences2 = [
+    Right $ exAv "pkg" 1 [] `withTest` ExTest "test" [ExAny "unknown"]
+  ]
+
 -- | Database with some cycles
 --
 -- * Simplest non-trivial cycle: A -> B and B -> A
@@ -667,7 +699,7 @@ db16 = [
 testIndepGoals2 :: String -> SolverTest
 testIndepGoals2 name =
     goalOrder goals $ indep $
-    mkTest db name ["A", "B"] $
+    enableAllTests $ mkTest db name ["A", "B"] $
     solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)]
   where
     db :: ExampleDb
@@ -792,7 +824,7 @@ testIndepGoals3 name =
 testIndepGoals4 :: String -> SolverTest
 testIndepGoals4 name =
     goalOrder goals $ indep $
-    mkTest db name ["A", "B", "C"] $
+    enableAllTests $ mkTest db name ["A", "B", "C"] $
     solverSuccess [("A",1), ("B",1), ("C",1), ("D",1), ("E",1), ("E",2)]
   where
     db :: ExampleDb
@@ -947,7 +979,8 @@ dbLangs1 = [
 -- depend on "false-dep".
 testBuildable :: String -> ExampleDependency -> TestTree
 testBuildable testName unavailableDep =
-    runTest $ mkTestExtLangPC (Just []) (Just []) [] db testName ["pkg"] expected
+    runTest $ enableAllTests $
+    mkTestExtLangPC (Just []) (Just []) [] db testName ["pkg"] expected
   where
     expected = solverSuccess [("false-dep", 1), ("pkg", 1)]
     db = [