1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DeriveGeneric #-} 3{-# LANGUAGE StandaloneDeriving #-} 4{-# OPTIONS_GHC -fno-warn-orphans #-} 5 6module UnitTests.Distribution.Solver.Modular.QuickCheck (tests) where 7 8import Prelude () 9import Distribution.Client.Compat.Prelude 10 11import Control.Arrow ((&&&)) 12import Control.DeepSeq (force) 13import Data.Either (lefts) 14import Data.Function (on) 15import Data.Hashable (Hashable(..)) 16import Data.List (groupBy, isInfixOf) 17import Data.Ord (comparing) 18 19import Text.Show.Pretty (parseValue, valToStr) 20 21import Test.Tasty (TestTree) 22import Test.Tasty.QuickCheck 23 24import Distribution.Types.Flag (FlagName) 25import Distribution.Utils.ShortText (ShortText) 26 27import Distribution.Client.Setup (defaultMaxBackjumps) 28 29import Distribution.Types.PackageName 30import Distribution.Types.UnqualComponentName 31 32import qualified Distribution.Solver.Types.ComponentDeps as CD 33import Distribution.Solver.Types.ComponentDeps 34 ( Component(..), ComponentDep, ComponentDeps ) 35import Distribution.Solver.Types.OptionalStanza 36import Distribution.Solver.Types.PackageConstraint 37import qualified Distribution.Solver.Types.PackagePath as P 38import Distribution.Solver.Types.PkgConfigDb 39 (pkgConfigDbFromList) 40import Distribution.Solver.Types.Settings 41import Distribution.Solver.Types.Variable 42import Distribution.Verbosity 43import Distribution.Version 44 45import UnitTests.Distribution.Solver.Modular.DSL 46import UnitTests.Distribution.Solver.Modular.QuickCheck.Utils 47 ( testPropertyWithSeed ) 48 49tests :: [TestTree] 50tests = [ 51 -- This test checks that certain solver parameters do not affect the 52 -- existence of a solution. It runs the solver twice, and only sets those 53 -- parameters on the second run. The test also applies parameters that 54 -- can affect the existence of a solution to both runs. 55 testPropertyWithSeed "target and goal order do not affect solvability" $ 56 \test targetOrder mGoalOrder1 mGoalOrder2 indepGoals -> 57 let r1 = solve' mGoalOrder1 test 58 r2 = solve' mGoalOrder2 test { testTargets = targets2 } 59 solve' goalOrder = 60 solve (EnableBackjumping True) (FineGrainedConflicts True) 61 (ReorderGoals False) (CountConflicts True) indepGoals 62 (getBlind <$> goalOrder) 63 targets = testTargets test 64 targets2 = case targetOrder of 65 SameOrder -> targets 66 ReverseOrder -> reverse targets 67 in counterexample (showResults r1 r2) $ 68 noneReachedBackjumpLimit [r1, r2] ==> 69 isRight (resultPlan r1) === isRight (resultPlan r2) 70 71 , testPropertyWithSeed 72 "solvable without --independent-goals => solvable with --independent-goals" $ 73 \test reorderGoals -> 74 let r1 = solve' (IndependentGoals False) test 75 r2 = solve' (IndependentGoals True) test 76 solve' indep = 77 solve (EnableBackjumping True) (FineGrainedConflicts True) 78 reorderGoals (CountConflicts True) indep Nothing 79 in counterexample (showResults r1 r2) $ 80 noneReachedBackjumpLimit [r1, r2] ==> 81 isRight (resultPlan r1) `implies` isRight (resultPlan r2) 82 83 , testPropertyWithSeed "backjumping does not affect solvability" $ 84 \test reorderGoals indepGoals -> 85 let r1 = solve' (EnableBackjumping True) test 86 r2 = solve' (EnableBackjumping False) test 87 solve' enableBj = 88 solve enableBj (FineGrainedConflicts False) reorderGoals 89 (CountConflicts True) indepGoals Nothing 90 in counterexample (showResults r1 r2) $ 91 noneReachedBackjumpLimit [r1, r2] ==> 92 isRight (resultPlan r1) === isRight (resultPlan r2) 93 94 , testPropertyWithSeed "fine-grained conflicts does not affect solvability" $ 95 \test reorderGoals indepGoals -> 96 let r1 = solve' (FineGrainedConflicts True) test 97 r2 = solve' (FineGrainedConflicts False) test 98 solve' fineGrainedConflicts = 99 solve (EnableBackjumping True) fineGrainedConflicts 100 reorderGoals (CountConflicts True) indepGoals Nothing 101 in counterexample (showResults r1 r2) $ 102 noneReachedBackjumpLimit [r1, r2] ==> 103 isRight (resultPlan r1) === isRight (resultPlan r2) 104 105 -- The next two tests use --no-count-conflicts, because the goal order used 106 -- with --count-conflicts depends on the total set of conflicts seen by the 107 -- solver. The solver explores more of the tree and encounters more 108 -- conflicts when it doesn't backjump. The different goal orders can lead to 109 -- different solutions and cause the test to fail. 110 -- TODO: Find a faster way to randomly sort goals, and then use a random 111 -- goal order in these tests. 112 113 , testPropertyWithSeed 114 "backjumping does not affect the result (with static goal order)" $ 115 \test reorderGoals indepGoals -> 116 let r1 = solve' (EnableBackjumping True) test 117 r2 = solve' (EnableBackjumping False) test 118 solve' enableBj = 119 solve enableBj (FineGrainedConflicts False) reorderGoals 120 (CountConflicts False) indepGoals Nothing 121 in counterexample (showResults r1 r2) $ 122 noneReachedBackjumpLimit [r1, r2] ==> 123 resultPlan r1 === resultPlan r2 124 125 , testPropertyWithSeed 126 "fine-grained conflicts does not affect the result (with static goal order)" $ 127 \test reorderGoals indepGoals -> 128 let r1 = solve' (FineGrainedConflicts True) test 129 r2 = solve' (FineGrainedConflicts False) test 130 solve' fineGrainedConflicts = 131 solve (EnableBackjumping True) fineGrainedConflicts 132 reorderGoals (CountConflicts False) indepGoals Nothing 133 in counterexample (showResults r1 r2) $ 134 noneReachedBackjumpLimit [r1, r2] ==> 135 resultPlan r1 === resultPlan r2 136 ] 137 where 138 noneReachedBackjumpLimit :: [Result] -> Bool 139 noneReachedBackjumpLimit = 140 not . any (\r -> resultPlan r == Left BackjumpLimitReached) 141 142 showResults :: Result -> Result -> String 143 showResults r1 r2 = showResult 1 r1 ++ showResult 2 r2 144 145 showResult :: Int -> Result -> String 146 showResult n result = 147 unlines $ ["", "Run " ++ show n ++ ":"] 148 ++ resultLog result 149 ++ ["result: " ++ show (resultPlan result)] 150 151 implies :: Bool -> Bool -> Bool 152 implies x y = not x || y 153 154 isRight :: Either a b -> Bool 155 isRight (Right _) = True 156 isRight _ = False 157 158newtype VarOrdering = VarOrdering { 159 unVarOrdering :: Variable P.QPN -> Variable P.QPN -> Ordering 160 } 161 162solve :: EnableBackjumping 163 -> FineGrainedConflicts 164 -> ReorderGoals 165 -> CountConflicts 166 -> IndependentGoals 167 -> Maybe VarOrdering 168 -> SolverTest 169 -> Result 170solve enableBj fineGrainedConflicts reorder countConflicts indep goalOrder test = 171 let (lg, result) = 172 runProgress $ exResolve (unTestDb (testDb test)) Nothing Nothing 173 (pkgConfigDbFromList []) 174 (map unPN (testTargets test)) 175 -- The backjump limit prevents individual tests from using 176 -- too much time and memory. 177 (Just defaultMaxBackjumps) 178 countConflicts fineGrainedConflicts 179 (MinimizeConflictSet False) indep reorder 180 (AllowBootLibInstalls False) OnlyConstrainedNone enableBj 181 (SolveExecutables True) (unVarOrdering <$> goalOrder) 182 (testConstraints test) (testPreferences test) normal 183 (EnableAllTests False) 184 185 failure :: String -> Failure 186 failure msg 187 | "Backjump limit reached" `isInfixOf` msg = BackjumpLimitReached 188 | otherwise = OtherFailure 189 in Result { 190 resultLog = lg 191 , resultPlan = 192 -- Force the result so that we check for internal errors when we check 193 -- for success or failure. See D.C.Dependency.validateSolverResult. 194 force $ either (Left . failure) (Right . extractInstallPlan) result 195 } 196 197-- | How to modify the order of the input targets. 198data TargetOrder = SameOrder | ReverseOrder 199 deriving Show 200 201instance Arbitrary TargetOrder where 202 arbitrary = elements [SameOrder, ReverseOrder] 203 204 shrink SameOrder = [] 205 shrink ReverseOrder = [SameOrder] 206 207data Result = Result { 208 resultLog :: [String] 209 , resultPlan :: Either Failure [(ExamplePkgName, ExamplePkgVersion)] 210 } 211 212data Failure = BackjumpLimitReached | OtherFailure 213 deriving (Eq, Generic, Show) 214 215instance NFData Failure 216 217-- | Package name. 218newtype PN = PN { unPN :: String } 219 deriving (Eq, Ord, Show) 220 221instance Arbitrary PN where 222 arbitrary = PN <$> elements ("base" : [[pn] | pn <- ['A'..'G']]) 223 224-- | Package version. 225newtype PV = PV { unPV :: Int } 226 deriving (Eq, Ord, Show) 227 228instance Arbitrary PV where 229 arbitrary = PV <$> elements [1..10] 230 231type TestPackage = Either ExampleInstalled ExampleAvailable 232 233getName :: TestPackage -> PN 234getName = PN . either exInstName exAvName 235 236getVersion :: TestPackage -> PV 237getVersion = PV . either exInstVersion exAvVersion 238 239data SolverTest = SolverTest { 240 testDb :: TestDb 241 , testTargets :: [PN] 242 , testConstraints :: [ExConstraint] 243 , testPreferences :: [ExPreference] 244 } 245 246-- | Pretty-print the test when quickcheck calls 'show'. 247instance Show SolverTest where 248 show test = 249 let str = "SolverTest {testDb = " ++ show (testDb test) 250 ++ ", testTargets = " ++ show (testTargets test) 251 ++ ", testConstraints = " ++ show (testConstraints test) 252 ++ ", testPreferences = " ++ show (testPreferences test) 253 ++ "}" 254 in maybe str valToStr $ parseValue str 255 256instance Arbitrary SolverTest where 257 arbitrary = do 258 db <- arbitrary 259 let pkgVersions = nub $ map (getName &&& getVersion) (unTestDb db) 260 pkgs = nub $ map fst pkgVersions 261 Positive n <- arbitrary 262 targets <- randomSubset n pkgs 263 constraints <- case pkgVersions of 264 [] -> return [] 265 _ -> boundedListOf 1 $ arbitraryConstraint pkgVersions 266 prefs <- case pkgVersions of 267 [] -> return [] 268 _ -> boundedListOf 3 $ arbitraryPreference pkgVersions 269 return (SolverTest db targets constraints prefs) 270 271 shrink test = 272 [test { testDb = db } | db <- shrink (testDb test)] 273 ++ [test { testTargets = targets } | targets <- shrink (testTargets test)] 274 ++ [test { testConstraints = cs } | cs <- shrink (testConstraints test)] 275 ++ [test { testPreferences = prefs } | prefs <- shrink (testPreferences test)] 276 277-- | Collection of source and installed packages. 278newtype TestDb = TestDb { unTestDb :: ExampleDb } 279 deriving Show 280 281instance Arbitrary TestDb where 282 arbitrary = do 283 -- Avoid cyclic dependencies by grouping packages by name and only 284 -- allowing each package to depend on packages in the groups before it. 285 groupedPkgs <- shuffle . groupBy ((==) `on` fst) . nub . sort =<< 286 boundedListOf 10 arbitrary 287 db <- foldM nextPkgs (TestDb []) groupedPkgs 288 TestDb <$> shuffle (unTestDb db) 289 where 290 nextPkgs :: TestDb -> [(PN, PV)] -> Gen TestDb 291 nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> traverse (nextPkg db) pkgs 292 293 nextPkg :: TestDb -> (PN, PV) -> Gen TestPackage 294 nextPkg db (pn, v) = do 295 installed <- arbitrary 296 if installed 297 then Left <$> arbitraryExInst pn v (lefts $ unTestDb db) 298 else Right <$> arbitraryExAv pn v db 299 300 shrink (TestDb pkgs) = map TestDb $ shrink pkgs 301 302arbitraryExAv :: PN -> PV -> TestDb -> Gen ExampleAvailable 303arbitraryExAv pn v db = 304 (\cds -> ExAv (unPN pn) (unPV v) cds []) <$> arbitraryComponentDeps pn db 305 306arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled 307arbitraryExInst pn v pkgs = do 308 pkgHash <- vectorOf 10 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] 309 numDeps <- min 3 <$> arbitrary 310 deps <- randomSubset numDeps pkgs 311 return $ ExInst (unPN pn) (unPV v) pkgHash (map exInstHash deps) 312 313arbitraryComponentDeps :: PN -> TestDb -> Gen (ComponentDeps [ExampleDependency]) 314arbitraryComponentDeps _ (TestDb []) = return $ CD.fromLibraryDeps [] 315arbitraryComponentDeps pn db = do 316 -- dedupComponentNames removes components with duplicate names, for example, 317 -- 'ComponentExe x' and 'ComponentTest x', and then CD.fromList combines 318 -- duplicate unnamed components. 319 cds <- CD.fromList . dedupComponentNames . filter (isValid . fst) 320 <$> boundedListOf 5 (arbitraryComponentDep db) 321 return $ if isCompleteComponentDeps cds 322 then cds 323 else -- Add a library if the ComponentDeps isn't complete. 324 CD.fromLibraryDeps [] <> cds 325 where 326 isValid :: Component -> Bool 327 isValid (ComponentSubLib name) = name /= mkUnqualComponentName (unPN pn) 328 isValid _ = True 329 330 dedupComponentNames = 331 nubBy ((\x y -> isJust x && isJust y && x == y) `on` componentName . fst) 332 333 componentName :: Component -> Maybe UnqualComponentName 334 componentName ComponentLib = Nothing 335 componentName ComponentSetup = Nothing 336 componentName (ComponentSubLib n) = Just n 337 componentName (ComponentFLib n) = Just n 338 componentName (ComponentExe n) = Just n 339 componentName (ComponentTest n) = Just n 340 componentName (ComponentBench n) = Just n 341 342-- | Returns true if the ComponentDeps forms a complete package, i.e., it 343-- contains a library, exe, test, or benchmark. 344isCompleteComponentDeps :: ComponentDeps a -> Bool 345isCompleteComponentDeps = any (completesPkg . fst) . CD.toList 346 where 347 completesPkg ComponentLib = True 348 completesPkg (ComponentExe _) = True 349 completesPkg (ComponentTest _) = True 350 completesPkg (ComponentBench _) = True 351 completesPkg (ComponentSubLib _) = False 352 completesPkg (ComponentFLib _) = False 353 completesPkg ComponentSetup = False 354 355arbitraryComponentDep :: TestDb -> Gen (ComponentDep [ExampleDependency]) 356arbitraryComponentDep db = do 357 comp <- arbitrary 358 deps <- case comp of 359 ComponentSetup -> smallListOf (arbitraryExDep db SetupDep) 360 _ -> boundedListOf 5 (arbitraryExDep db NonSetupDep) 361 return (comp, deps) 362 363-- | Location of an 'ExampleDependency'. It determines which values are valid. 364data ExDepLocation = SetupDep | NonSetupDep 365 366arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency 367arbitraryExDep db@(TestDb pkgs) level = 368 let flag = ExFlagged <$> arbitraryFlagName 369 <*> arbitraryDeps db 370 <*> arbitraryDeps db 371 other = 372 -- Package checks require dependencies on "base" to have bounds. 373 let notBase = filter ((/= PN "base") . getName) pkgs 374 in [ExAny . unPN <$> elements (map getName notBase) | not (null notBase)] 375 ++ [ 376 -- existing version 377 let fixed pkg = ExFix (unPN $ getName pkg) (unPV $ getVersion pkg) 378 in fixed <$> elements pkgs 379 380 -- random version of an existing package 381 , ExFix . unPN . getName <$> elements pkgs <*> (unPV <$> arbitrary) 382 ] 383 in oneof $ 384 case level of 385 NonSetupDep -> flag : other 386 SetupDep -> other 387 388arbitraryDeps :: TestDb -> Gen Dependencies 389arbitraryDeps db = frequency 390 [ (1, return NotBuildable) 391 , (20, Buildable <$> smallListOf (arbitraryExDep db NonSetupDep)) 392 ] 393 394arbitraryFlagName :: Gen String 395arbitraryFlagName = (:[]) <$> elements ['A'..'E'] 396 397arbitraryConstraint :: [(PN, PV)] -> Gen ExConstraint 398arbitraryConstraint pkgs = do 399 (PN pn, v) <- elements pkgs 400 let anyQualifier = ScopeAnyQualifier (mkPackageName pn) 401 oneof [ 402 ExVersionConstraint anyQualifier <$> arbitraryVersionRange v 403 , ExStanzaConstraint anyQualifier <$> sublistOf [TestStanzas, BenchStanzas] 404 ] 405 406arbitraryPreference :: [(PN, PV)] -> Gen ExPreference 407arbitraryPreference pkgs = do 408 (PN pn, v) <- elements pkgs 409 oneof [ 410 ExStanzaPref pn <$> sublistOf [TestStanzas, BenchStanzas] 411 , ExPkgPref pn <$> arbitraryVersionRange v 412 ] 413 414arbitraryVersionRange :: PV -> Gen VersionRange 415arbitraryVersionRange (PV v) = 416 let version = mkSimpleVersion v 417 in elements [ 418 thisVersion version 419 , notThisVersion version 420 , earlierVersion version 421 , orLaterVersion version 422 , noVersion 423 ] 424 425instance Arbitrary ReorderGoals where 426 arbitrary = ReorderGoals <$> arbitrary 427 428 shrink (ReorderGoals reorder) = [ReorderGoals False | reorder] 429 430instance Arbitrary IndependentGoals where 431 arbitrary = IndependentGoals <$> arbitrary 432 433 shrink (IndependentGoals indep) = [IndependentGoals False | indep] 434 435instance Arbitrary UnqualComponentName where 436 -- The "component-" prefix prevents component names and build-depends 437 -- dependency names from overlapping. 438 -- TODO: Remove the prefix once the QuickCheck tests support dependencies on 439 -- internal libraries. 440 arbitrary = 441 mkUnqualComponentName <$> (\c -> "component-" ++ [c]) <$> elements "ABC" 442 443instance Arbitrary Component where 444 arbitrary = oneof [ return ComponentLib 445 , ComponentSubLib <$> arbitrary 446 , ComponentExe <$> arbitrary 447 , ComponentFLib <$> arbitrary 448 , ComponentTest <$> arbitrary 449 , ComponentBench <$> arbitrary 450 , return ComponentSetup 451 ] 452 453 shrink ComponentLib = [] 454 shrink _ = [ComponentLib] 455 456instance Arbitrary ExampleInstalled where 457 arbitrary = error "arbitrary not implemented: ExampleInstalled" 458 459 shrink ei = [ ei { exInstBuildAgainst = deps } 460 | deps <- shrinkList shrinkNothing (exInstBuildAgainst ei)] 461 462instance Arbitrary ExampleAvailable where 463 arbitrary = error "arbitrary not implemented: ExampleAvailable" 464 465 shrink ea = [ea { exAvDeps = deps } | deps <- shrink (exAvDeps ea)] 466 467instance (Arbitrary a, Monoid a) => Arbitrary (ComponentDeps a) where 468 arbitrary = error "arbitrary not implemented: ComponentDeps" 469 470 shrink = filter isCompleteComponentDeps . map CD.fromList . shrink . CD.toList 471 472instance Arbitrary ExampleDependency where 473 arbitrary = error "arbitrary not implemented: ExampleDependency" 474 475 shrink (ExAny _) = [] 476 shrink (ExFix "base" _) = [] -- preserve bounds on base 477 shrink (ExFix pn _) = [ExAny pn] 478 shrink (ExFlagged flag th el) = 479 deps th ++ deps el 480 ++ [ExFlagged flag th' el | th' <- shrink th] 481 ++ [ExFlagged flag th el' | el' <- shrink el] 482 where 483 deps NotBuildable = [] 484 deps (Buildable ds) = ds 485 shrink dep = error $ "Dependency not handled: " ++ show dep 486 487instance Arbitrary Dependencies where 488 arbitrary = error "arbitrary not implemented: Dependencies" 489 490 shrink NotBuildable = [Buildable []] 491 shrink (Buildable deps) = map Buildable (shrink deps) 492 493instance Arbitrary ExConstraint where 494 arbitrary = error "arbitrary not implemented: ExConstraint" 495 496 shrink (ExStanzaConstraint scope stanzas) = 497 [ExStanzaConstraint scope stanzas' | stanzas' <- shrink stanzas] 498 shrink (ExVersionConstraint scope vr) = 499 [ExVersionConstraint scope vr' | vr' <- shrink vr] 500 shrink _ = [] 501 502instance Arbitrary ExPreference where 503 arbitrary = error "arbitrary not implemented: ExPreference" 504 505 shrink (ExStanzaPref pn stanzas) = 506 [ExStanzaPref pn stanzas' | stanzas' <- shrink stanzas] 507 shrink (ExPkgPref pn vr) = [ExPkgPref pn vr' | vr' <- shrink vr] 508 509instance Arbitrary OptionalStanza where 510 arbitrary = error "arbitrary not implemented: OptionalStanza" 511 512 shrink BenchStanzas = [TestStanzas] 513 shrink TestStanzas = [] 514 515instance Arbitrary VersionRange where 516 arbitrary = error "arbitrary not implemented: VersionRange" 517 518 shrink vr = [noVersion | vr /= noVersion] 519 520-- Randomly sorts solver variables using 'hash'. 521-- TODO: Sorting goals with this function is very slow. 522instance Arbitrary VarOrdering where 523 arbitrary = do 524 f <- arbitrary :: Gen (Int -> Int) 525 return $ VarOrdering (comparing (f . hash)) 526 527instance Hashable pn => Hashable (Variable pn) 528instance Hashable a => Hashable (P.Qualified a) 529instance Hashable P.PackagePath 530instance Hashable P.Qualifier 531instance Hashable P.Namespace 532instance Hashable OptionalStanza 533instance Hashable FlagName 534instance Hashable PackageName 535instance Hashable ShortText 536 537deriving instance Generic (Variable pn) 538deriving instance Generic (P.Qualified a) 539deriving instance Generic P.PackagePath 540deriving instance Generic P.Namespace 541deriving instance Generic P.Qualifier 542 543randomSubset :: Int -> [a] -> Gen [a] 544randomSubset n xs = take n <$> shuffle xs 545 546boundedListOf :: Int -> Gen a -> Gen [a] 547boundedListOf n gen = take n <$> listOf gen 548 549-- | Generates lists with average length less than 1. 550smallListOf :: Gen a -> Gen [a] 551smallListOf gen = 552 frequency [ (fr, vectorOf n gen) 553 | (fr, n) <- [(3, 0), (5, 1), (2, 2)]] 554