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