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

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