Newer
Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module UnitTests.Distribution.Client.Dependency.Modular.QuickCheck (tests) where
import Control.Monad (foldM)
import Data.Either (lefts)
import Data.Function (on)
import Data.List (groupBy, nub, sort)
import Data.Maybe (isJust)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<*>))
import Data.Monoid (Monoid)
#endif
import Text.Show.Pretty (parseValue, valToStr)
import Test.Tasty (TestTree)
import Test.Tasty.QuickCheck
import qualified Distribution.Client.ComponentDeps as CD
import Distribution.Client.ComponentDeps ( Component(..)
, ComponentDep, ComponentDeps)
import Distribution.Client.Dependency.Types (Solver(..))
import Distribution.Client.PkgConfigDb (pkgConfigDbFromList)
import UnitTests.Distribution.Client.Dependency.Modular.DSL
tests :: [TestTree]
tests = [
-- This test checks that certain solver parameters do not affect the
-- existence of a solution. It runs the solver twice, and only sets those
-- parameters on the second run. The test also applies parameters that
-- can affect the existence of a solution to both runs.
testProperty "target order and --reorder-goals do not affect solvability" $
\(SolverTest db targets) targetOrder reorderGoals indepGoals solver ->
let r1 = solve (ReorderGoals False) indepGoals solver targets db
r2 = solve reorderGoals indepGoals solver targets2 db
targets2 = case targetOrder of
SameOrder -> targets
ReverseOrder -> reverse targets
in counterexample (showResults r1 r2) $
isJust (resultPlan r1) === isJust (resultPlan r2)
, testProperty
"solvable without --independent-goals => solvable with --independent-goals" $
\(SolverTest db targets) reorderGoals solver ->
let r1 = solve reorderGoals (IndepGoals False) solver targets db
r2 = solve reorderGoals (IndepGoals True) solver targets db
in counterexample (showResults r1 r2) $
isJust (resultPlan r1) `implies` isJust (resultPlan r2)
]
where
showResults :: Result -> Result -> String
showResults r1 r2 = showResult 1 r1 ++ showResult 2 r2
showResult :: Int -> Result -> String
showResult n result =
unlines $ ["", "Run " ++ show n ++ ":"]
++ resultLog result
++ ["result: " ++ show (resultPlan result)]
implies :: Bool -> Bool -> Bool
implies x y = not x || y
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
solve :: ReorderGoals -> IndepGoals -> Solver -> [PN] -> TestDb -> Result
solve reorder indep solver targets (TestDb db) =
let (lg, result) =
exResolve db Nothing Nothing
(pkgConfigDbFromList [])
(map unPN targets)
solver indep reorder []
in Result {
resultLog = lg
, resultPlan =
case result of
Left _ -> Nothing
Right plan -> Just (extractInstallPlan plan)
}
-- | How to modify the order of the input targets.
data TargetOrder = SameOrder | ReverseOrder
deriving Show
instance Arbitrary TargetOrder where
arbitrary = elements [SameOrder, ReverseOrder]
shrink SameOrder = []
shrink ReverseOrder = [SameOrder]
data Result = Result {
resultLog :: [String]
, resultPlan :: Maybe [(ExamplePkgName, ExamplePkgVersion)]
}
-- | Package name.
newtype PN = PN { unPN :: String }
deriving (Eq, Ord, Show)
instance Arbitrary PN where
arbitrary = PN <$> elements ("base" : [[pn] | pn <- ['A'..'G']])
-- | Package version.
newtype PV = PV { unPV :: Int }
deriving (Eq, Ord, Show)
instance Arbitrary PV where
arbitrary = PV <$> elements [1..10]
type TestPackage = Either ExampleInstalled ExampleAvailable
getName :: TestPackage -> PN
getName = PN . either exInstName exAvName
getVersion :: TestPackage -> PV
getVersion = PV . either exInstVersion exAvVersion
data SolverTest = SolverTest {
testDb :: TestDb
, testTargets :: [PN]
}
-- | Pretty-print the test when quickcheck calls 'show'.
instance Show SolverTest where
show test =
let str = "SolverTest {testDb = " ++ show (testDb test)
++ ", testTargets = " ++ show (testTargets test) ++ "}"
in maybe str valToStr $ parseValue str
instance Arbitrary SolverTest where
arbitrary = do
db <- arbitrary
let pkgs = nub $ map getName (unTestDb db)
Positive n <- arbitrary
targets <- randomSubset n pkgs
return (SolverTest db targets)
shrink test =
[test { testDb = db } | db <- shrink (testDb test)]
++ [test { testTargets = targets } | targets <- shrink (testTargets test)]
-- | Collection of source and installed packages.
newtype TestDb = TestDb { unTestDb :: ExampleDb }
deriving Show
instance Arbitrary TestDb where
arbitrary = do
-- Avoid cyclic dependencies by grouping packages by name and only
-- allowing each package to depend on packages in the groups before it.
groupedPkgs <- shuffle . groupBy ((==) `on` fst) . nub . sort =<<
boundedListOf 10 arbitrary
db <- foldM nextPkgs (TestDb []) groupedPkgs
TestDb <$> shuffle (unTestDb db)
where
nextPkgs :: TestDb -> [(PN, PV)] -> Gen TestDb
nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> mapM (nextPkg db) pkgs
nextPkg :: TestDb -> (PN, PV) -> Gen TestPackage
nextPkg db (pn, v) = do
installed <- arbitrary
if installed
then Left <$> arbitraryExInst pn v (lefts $ unTestDb db)
else Right <$> arbitraryExAv pn v db
shrink (TestDb pkgs) = map TestDb $ shrink pkgs
arbitraryExAv :: PN -> PV -> TestDb -> Gen ExampleAvailable
arbitraryExAv pn v db =
ExAv (unPN pn) (unPV v) <$> arbitraryComponentDeps db
arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled
arbitraryExInst pn v pkgs = do
hash <- vectorOf 10 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']
numDeps <- min 3 <$> arbitrary
deps <- randomSubset numDeps pkgs
return $ ExInst (unPN pn) (unPV v) hash (map exInstHash deps)
arbitraryComponentDeps :: TestDb -> Gen (ComponentDeps [ExampleDependency])
arbitraryComponentDeps (TestDb []) = return $ CD.fromList []
arbitraryComponentDeps db =
-- CD.fromList combines duplicate components.
CD.fromList <$> boundedListOf 3 (arbitraryComponentDep db)
arbitraryComponentDep :: TestDb -> Gen (ComponentDep [ExampleDependency])
arbitraryComponentDep db = do
comp <- arbitrary
deps <- case comp of
ComponentSetup -> smallListOf (arbitraryExDep db Setup)
_ -> boundedListOf 5 (arbitraryExDep db NonSetup)
return (comp, deps)
-- | Location of an 'ExampleDependency'. It determines which values are valid.
data ExDepLocation = Setup | NonSetup
arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency
arbitraryExDep db@(TestDb pkgs) level =
let flag = ExFlag <$> arbitraryFlagName
<*> arbitraryDeps db
<*> arbitraryDeps db
ExAny . unPN <$> elements (map getName pkgs)
-- existing version
, let fixed pkg = ExFix (unPN $ getName pkg) (unPV $ getVersion pkg)
in fixed <$> elements pkgs
-- random version of an existing package
, ExFix . unPN . getName <$> elements pkgs <*> (unPV <$> arbitrary)
]
in oneof $
case level of
NonSetup -> flag : other
Setup -> other
arbitraryDeps :: TestDb -> Gen Dependencies
arbitraryDeps db = frequency
[ (1, return NotBuildable)
, (20, Buildable <$> smallListOf (arbitraryExDep db NonSetup))
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
]
arbitraryFlagName :: Gen String
arbitraryFlagName = (:[]) <$> elements ['A'..'E']
arbitraryComponentName :: Gen String
arbitraryComponentName = (:[]) <$> elements "ABC"
instance Arbitrary ReorderGoals where
arbitrary = ReorderGoals <$> arbitrary
shrink (ReorderGoals reorder) = [ReorderGoals False | reorder]
instance Arbitrary IndepGoals where
arbitrary = IndepGoals <$> arbitrary
shrink (IndepGoals indep) = [IndepGoals False | indep]
instance Arbitrary Solver where
arbitrary = frequency [ (1, return TopDown)
, (5, return Modular) ]
shrink Modular = []
shrink TopDown = [Modular]
instance Arbitrary Component where
arbitrary = oneof [ ComponentLib <$> arbitraryComponentName
, ComponentExe <$> arbitraryComponentName
, ComponentTest <$> arbitraryComponentName
, ComponentBench <$> arbitraryComponentName
, return ComponentSetup
]
shrink (ComponentLib "") = []
shrink _ = [ComponentLib ""]
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
instance Arbitrary ExampleInstalled where
arbitrary = error "arbitrary not implemented: ExampleInstalled"
shrink ei = [ ei { exInstBuildAgainst = deps }
| deps <- shrinkList shrinkNothing (exInstBuildAgainst ei)]
instance Arbitrary ExampleAvailable where
arbitrary = error "arbitrary not implemented: ExampleAvailable"
shrink ea = [ea { exAvDeps = deps } | deps <- shrink (exAvDeps ea)]
instance (Arbitrary a, Monoid a) => Arbitrary (ComponentDeps a) where
arbitrary = error "arbitrary not implemented: ComponentDeps"
shrink = map CD.fromList . shrink . CD.toList
instance Arbitrary ExampleDependency where
arbitrary = error "arbitrary not implemented: ExampleDependency"
shrink (ExAny _) = []
shrink (ExFix pn _) = [ExAny pn]
shrink (ExFlag flag th el) =
deps th ++ deps el
++ [ExFlag flag th' el | th' <- shrink th]
++ [ExFlag flag th el' | el' <- shrink el]
where
deps NotBuildable = []
deps (Buildable ds) = ds
shrink dep = error $ "Dependency not handled: " ++ show dep
instance Arbitrary Dependencies where
arbitrary = error "arbitrary not implemented: Dependencies"
shrink NotBuildable = [Buildable []]
shrink (Buildable deps) = map Buildable (shrink deps)
randomSubset :: Int -> [a] -> Gen [a]
randomSubset n xs = take n <$> shuffle xs
boundedListOf :: Int -> Gen a -> Gen [a]
boundedListOf n gen = take n <$> listOf gen
-- | Generates lists with average length less than 1.
smallListOf :: Gen a -> Gen [a]
smallListOf gen =
frequency [ (fr, vectorOf n gen)
| (fr, n) <- [(3, 0), (5, 1), (2, 2)]]