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