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

   1 {-# LANGUAGE RecordWildCards #-}
   2
   3 -- | Utilities for creating HUnit test cases with the solver DSL.
   4 module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils
   5   ( SolverTest
   6   , SolverResult (..)
   7   , maxBackjumps
   8   , disableFineGrainedConflicts
   9   , minimizeConflictSet
  10   , independentGoals
  11   , preferOldest
  12   , allowBootLibInstalls
  13   , onlyConstrained
  14   , disableBackjumping
  15   , disableSolveExecutables
  16   , goalOrder
  17   , constraints
  18   , preferences
  19   , setVerbose
  20   , enableAllTests
  21   , solverSuccess
  22   , solverFailure
  23   , anySolverFailure
  24   , mkTest
  25   , mkTestExts
  26   , mkTestLangs
  27   , mkTestPCDepends
  28   , mkTestExtLangPC
  29   , runTest
  30   ) where
  31
  32 import Distribution.Solver.Compat.Prelude
  33 import Prelude ()
  34
  35 import Data.List (elemIndex)
  36
  37 -- test-framework
  38 import Test.Tasty as TF
  39 import Test.Tasty.HUnit (assertBool, assertEqual, testCase)
  40
  41 -- Cabal
  42 import qualified Distribution.PackageDescription as C
  43 import Distribution.Verbosity
  44 import Language.Haskell.Extension (Extension (..), Language (..))
  45
  46 -- cabal-install
  47
  48 import Distribution.Client.Dependency (foldProgress)
  49 import qualified Distribution.Solver.Types.PackagePath as P
  50 import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb (..), pkgConfigDbFromList)
  51 import Distribution.Solver.Types.Settings
  52 import Distribution.Solver.Types.Variable
  53 import UnitTests.Distribution.Solver.Modular.DSL
  54 import UnitTests.Options
  55
  56 maxBackjumps :: Maybe Int -> SolverTest -> SolverTest
  57 maxBackjumps mbj test = test{testMaxBackjumps = mbj}
  58
  59 disableFineGrainedConflicts :: SolverTest -> SolverTest
  60 disableFineGrainedConflicts test =
  61   test{testFineGrainedConflicts = FineGrainedConflicts False}
  62
  63 minimizeConflictSet :: SolverTest -> SolverTest
  64 minimizeConflictSet test =
  65   test{testMinimizeConflictSet = MinimizeConflictSet True}
  66
  67 -- | Combinator to turn on --independent-goals behavior, i.e. solve
  68 -- for the goals as if we were solving for each goal independently.
  69 independentGoals :: SolverTest -> SolverTest
  70 independentGoals test = test{testIndepGoals = IndependentGoals True}
  71
  72 -- | Combinator to turn on --prefer-oldest
  73 preferOldest :: SolverTest -> SolverTest
  74 preferOldest test = test{testPreferOldest = PreferOldest True}
  75
  76 allowBootLibInstalls :: SolverTest -> SolverTest
  77 allowBootLibInstalls test =
  78   test{testAllowBootLibInstalls = AllowBootLibInstalls True}
  79
  80 onlyConstrained :: SolverTest -> SolverTest
  81 onlyConstrained test =
  82   test{testOnlyConstrained = OnlyConstrainedAll}
  83
  84 disableBackjumping :: SolverTest -> SolverTest
  85 disableBackjumping test =
  86   test{testEnableBackjumping = EnableBackjumping False}
  87
  88 disableSolveExecutables :: SolverTest -> SolverTest
  89 disableSolveExecutables test =
  90   test{testSolveExecutables = SolveExecutables False}
  91
  92 goalOrder :: [ExampleVar] -> SolverTest -> SolverTest
  93 goalOrder order test = test{testGoalOrder = Just order}
  94
  95 constraints :: [ExConstraint] -> SolverTest -> SolverTest
  96 constraints cs test = test{testConstraints = cs}
  97
  98 preferences :: [ExPreference] -> SolverTest -> SolverTest
  99 preferences prefs test = test{testSoftConstraints = prefs}
 100
 101 -- | Increase the solver's verbosity. This is necessary for test cases that
 102 -- check the contents of the verbose log.
 103 setVerbose :: SolverTest -> SolverTest
 104 setVerbose test = test{testVerbosity = verbose}
 105
 106 enableAllTests :: SolverTest -> SolverTest
 107 enableAllTests test = test{testEnableAllTests = EnableAllTests True}
 108
 109 {-------------------------------------------------------------------------------
 110   Solver tests
 111 -------------------------------------------------------------------------------}
 112
 113 data SolverTest = SolverTest
 114   { testLabel :: String
 115   , testTargets :: [String]
 116   , testResult :: SolverResult
 117   , testMaxBackjumps :: Maybe Int
 118   , testFineGrainedConflicts :: FineGrainedConflicts
 119   , testMinimizeConflictSet :: MinimizeConflictSet
 120   , testIndepGoals :: IndependentGoals
 121   , testPreferOldest :: PreferOldest
 122   , testAllowBootLibInstalls :: AllowBootLibInstalls
 123   , testOnlyConstrained :: OnlyConstrained
 124   , testEnableBackjumping :: EnableBackjumping
 125   , testSolveExecutables :: SolveExecutables
 126   , testGoalOrder :: Maybe [ExampleVar]
 127   , testConstraints :: [ExConstraint]
 128   , testSoftConstraints :: [ExPreference]
 129   , testVerbosity :: Verbosity
 130   , testDb :: ExampleDb
 131   , testSupportedExts :: Maybe [Extension]
 132   , testSupportedLangs :: Maybe [Language]
 133   , testPkgConfigDb :: Maybe PkgConfigDb
 134   , testEnableAllTests :: EnableAllTests
 135   }
 136
 137 -- | Expected result of a solver test.
 138 data SolverResult = SolverResult
 139   { resultLogPredicate :: [String] -> Bool
 140   -- ^ The solver's log should satisfy this predicate. Note that we also print
 141   -- the log, so evaluating a large log here can cause a space leak.
 142   , resultErrorMsgPredicateOrPlan :: Either (String -> Bool) [(String, Int)]
 143   -- ^ Fails with an error message satisfying the predicate, or succeeds with
 144   -- the given plan.
 145   }
 146
 147 solverSuccess :: [(String, Int)] -> SolverResult
 148 solverSuccess = SolverResult (const True) . Right
 149
 150 solverFailure :: (String -> Bool) -> SolverResult
 151 solverFailure = SolverResult (const True) . Left
 152
 153 -- | Can be used for test cases where we just want to verify that
 154 -- they fail, but do not care about the error message.
 155 anySolverFailure :: SolverResult
 156 anySolverFailure = solverFailure (const True)
 157
 158 -- | Makes a solver test case, consisting of the following components:
 159 --
 160 --      1. An 'ExampleDb', representing the package database (both
 161 --         installed and remote) we are doing dependency solving over,
 162 --      2. A 'String' name for the test,
 163 --      3. A list '[String]' of package names to solve for
 164 --      4. The expected result, either 'Nothing' if there is no
 165 --         satisfying solution, or a list '[(String, Int)]' of
 166 --         packages to install, at which versions.
 167 --
 168 -- See 'UnitTests.Distribution.Solver.Modular.DSL' for how
 169 -- to construct an 'ExampleDb', as well as definitions of 'db1' etc.
 170 -- in this file.
 171 mkTest
 172   :: ExampleDb
 173   -> String
 174   -> [String]
 175   -> SolverResult
 176   -> SolverTest
 177 mkTest = mkTestExtLangPC Nothing Nothing (Just [])
 178
 179 mkTestExts
 180   :: [Extension]
 181   -> ExampleDb
 182   -> String
 183   -> [String]
 184   -> SolverResult
 185   -> SolverTest
 186 mkTestExts exts = mkTestExtLangPC (Just exts) Nothing (Just [])
 187
 188 mkTestLangs
 189   :: [Language]
 190   -> ExampleDb
 191   -> String
 192   -> [String]
 193   -> SolverResult
 194   -> SolverTest
 195 mkTestLangs langs = mkTestExtLangPC Nothing (Just langs) (Just [])
 196
 197 mkTestPCDepends
 198   :: Maybe [(String, String)]
 199   -> ExampleDb
 200   -> String
 201   -> [String]
 202   -> SolverResult
 203   -> SolverTest
 204 mkTestPCDepends mPkgConfigDb = mkTestExtLangPC Nothing Nothing mPkgConfigDb
 205
 206 mkTestExtLangPC
 207   :: Maybe [Extension]
 208   -> Maybe [Language]
 209   -> Maybe [(String, String)]
 210   -> ExampleDb
 211   -> String
 212   -> [String]
 213   -> SolverResult
 214   -> SolverTest
 215 mkTestExtLangPC exts langs mPkgConfigDb db label targets result =
 216   SolverTest
 217     { testLabel = label
 218     , testTargets = targets
 219     , testResult = result
 220     , testMaxBackjumps = Nothing
 221     , testFineGrainedConflicts = FineGrainedConflicts True
 222     , testMinimizeConflictSet = MinimizeConflictSet False
 223     , testIndepGoals = IndependentGoals False
 224     , testPreferOldest = PreferOldest False
 225     , testAllowBootLibInstalls = AllowBootLibInstalls False
 226     , testOnlyConstrained = OnlyConstrainedNone
 227     , testEnableBackjumping = EnableBackjumping True
 228     , testSolveExecutables = SolveExecutables True
 229     , testGoalOrder = Nothing
 230     , testConstraints = []
 231     , testSoftConstraints = []
 232     , testVerbosity = normal
 233     , testDb = db
 234     , testSupportedExts = exts
 235     , testSupportedLangs = langs
 236     , testPkgConfigDb = pkgConfigDbFromList <$> mPkgConfigDb
 237     , testEnableAllTests = EnableAllTests False
 238     }
 239
 240 runTest :: SolverTest -> TF.TestTree
 241 runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
 242   testCase testLabel $ do
 243     let progress =
 244           exResolve
 245             testDb
 246             testSupportedExts
 247             testSupportedLangs
 248             testPkgConfigDb
 249             testTargets
 250             testMaxBackjumps
 251             (CountConflicts True)
 252             testFineGrainedConflicts
 253             testMinimizeConflictSet
 254             testIndepGoals
 255             testPreferOldest
 256             (ReorderGoals False)
 257             testAllowBootLibInstalls
 258             testOnlyConstrained
 259             testEnableBackjumping
 260             testSolveExecutables
 261             (sortGoals <$> testGoalOrder)
 262             testConstraints
 263             testSoftConstraints
 264             testVerbosity
 265             testEnableAllTests
 266         printMsg msg = when showSolverLog $ putStrLn msg
 267         msgs = foldProgress (:) (const []) (const []) progress
 268     assertBool ("Unexpected solver log:\n" ++ unlines msgs) $
 269       resultLogPredicate testResult $
 270         concatMap lines msgs
 271     result <- foldProgress ((>>) . printMsg) (return . Left) (return . Right) progress
 272     case result of
 273       Left err ->
 274         assertBool
 275           ("Unexpected error:\n" ++ err)
 276           (checkErrorMsg testResult err)
 277       Right plan -> assertEqual "" (toMaybe testResult) (Just (extractInstallPlan plan))
 278   where
 279     toMaybe :: SolverResult -> Maybe [(String, Int)]
 280     toMaybe = either (const Nothing) Just . resultErrorMsgPredicateOrPlan
 281
 282     checkErrorMsg :: SolverResult -> String -> Bool
 283     checkErrorMsg result msg =
 284       case resultErrorMsgPredicateOrPlan result of
 285         Left f -> f msg
 286         Right _ -> False
 287
 288     sortGoals
 289       :: [ExampleVar]
 290       -> Variable P.QPN
 291       -> Variable P.QPN
 292       -> Ordering
 293     sortGoals = orderFromList . map toVariable
 294
 295     -- Sort elements in the list ahead of elements not in the list. Otherwise,
 296     -- follow the order in the list.
 297     orderFromList :: Eq a => [a] -> a -> a -> Ordering
 298     orderFromList xs =
 299       comparing $ \x -> let i = elemIndex x xs in (isNothing i, i)
 300
 301     toVariable :: ExampleVar -> Variable P.QPN
 302     toVariable (P q pn) = PackageVar (toQPN q pn)
 303     toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.mkFlagName fn)
 304     toVariable (S q pn stanza) = StanzaVar (toQPN q pn) stanza
 305
 306     toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN
 307     toQPN q pn = P.Q pp (C.mkPackageName pn)
 308       where
 309         pp = case q of
 310           QualNone -> P.PackagePath P.DefaultNamespace P.QualToplevel
 311           QualIndep p ->
 312             P.PackagePath
 313               (P.Independent $ C.mkPackageName p)
 314               P.QualToplevel
 315           QualSetup s ->
 316             P.PackagePath
 317               P.DefaultNamespace
 318               (P.QualSetup (C.mkPackageName s))
 319           QualIndepSetup p s ->
 320             P.PackagePath
 321               (P.Independent $ C.mkPackageName p)
 322               (P.QualSetup (C.mkPackageName s))
 323           QualExe p1 p2 ->
 324             P.PackagePath
 325               P.DefaultNamespace
 326               (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2))