Commit ce9e82cc authored by kristenk's avatar kristenk
Browse files

Start adding solver quickcheck tests

parent 692d8bf4
......@@ -73,11 +73,13 @@ script:
- cp Setup.hs ./dist/setup/setup.hs
- ghc --make -odir ./dist/setup -hidir ./dist/setup -i -i. ./dist/setup/setup.hs -o ./dist/setup/setup -Wall -Werror -threaded # the command cabal-install would use to build setup
- cabal install happy
- cabal install --only-dependencies --enable-tests --enable-benchmarks
- ./dist/setup/setup configure --user --ghc-option=-Werror --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging
- ./dist/setup/setup build
- ./dist/setup/setup haddock # see https://github.com/haskell/cabal/issues/2198
- ./dist/setup/setup test --show-details=streaming --test-option=--hide-successes
- ./dist/setup/setup test unit-tests --show-details=streaming --test-option=--hide-successes
- ./dist/setup/setup test integration-tests --show-details=streaming --test-option=--hide-successes
- cabal check
- cabal sdist
- install_from_tarball
......
......@@ -20,6 +20,7 @@ build_script:
- Setup install
- cd ..\cabal-install
- ghc --make -threaded -i -i. Setup.hs -Wall -Werror
- echo "" | ..\cabal install happy
- echo "" | ..\cabal install --only-dependencies --enable-tests
- ..\cabal configure --user --ghc-option=-Werror --enable-tests
- ..\cabal build
......
......@@ -335,6 +335,62 @@ Test-Suite unit-tests
ghc-options: -threaded
default-language: Haskell2010
-- Slow solver tests
Test-Suite solver-quickcheck
type: exitcode-stdio-1.0
main-is: SolverQuickCheck.hs
hs-source-dirs: tests, .
ghc-options: -Wall -fwarn-tabs
other-modules:
UnitTests.Distribution.Client.Dependency.Modular.DSL
UnitTests.Distribution.Client.Dependency.Modular.QuickCheck
build-depends:
base,
array,
bytestring,
Cabal,
containers,
mtl,
pretty,
process,
directory,
filepath,
hashable,
stm,
tar,
time,
HTTP,
zlib,
binary,
random,
hackage-security,
tasty,
tasty-quickcheck,
QuickCheck >= 2.8.2,
pretty-show
if flag(old-directory)
build-depends: old-time
if flag(network-uri)
build-depends: network-uri >= 2.6, network >= 2.6
else
build-depends: network-uri < 2.6, network < 2.6
if impl(ghc < 7.6)
build-depends: ghc-prim >= 0.2 && < 0.3
if os(windows)
build-depends: Win32
else
build-depends: unix
if arch(arm)
cc-options: -DCABAL_NO_THREADED
else
ghc-options: -threaded
default-language: Haskell2010
test-suite integration-tests
type: exitcode-stdio-1.0
hs-source-dirs: tests
......
module Main where
import Test.Tasty
import qualified UnitTests.Distribution.Client.Dependency.Modular.QuickCheck
tests :: TestTree
tests =
testGroup "Solver QuickCheck"
[ testGroup "UnitTests.Distribution.Client.Dependency.Modular.QuickCheck"
UnitTests.Distribution.Client.Dependency.Modular.QuickCheck.tests
]
main :: IO ()
main = defaultMain tests
......@@ -7,6 +7,11 @@ module UnitTests.Distribution.Client.Dependency.Modular.DSL (
, ExampleDb
, ExampleVersionRange
, ExamplePkgVersion
, ExamplePkgName
, ExampleAvailable(..)
, ExampleInstalled(..)
, IndepGoals(..)
, ReorderGoals(..)
, exAv
, exInst
, exFlag
......@@ -92,7 +97,9 @@ type ExamplePkgHash = String -- for example "installed" packages
type ExampleFlagName = String
type ExampleTestName = String
type ExampleVersionRange = C.VersionRange
data Dependencies = NotBuildable | Buildable [ExampleDependency]
deriving Show
data ExampleDependency =
-- | Simple dependency on any version
......@@ -115,6 +122,7 @@ data ExampleDependency =
-- | Dependency on a pkg-config package
| ExPkg (ExamplePkgName, ExamplePkgVersion)
deriving Show
exFlag :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency]
-> ExampleDependency
......@@ -126,7 +134,7 @@ data ExampleAvailable = ExAv {
exAvName :: ExamplePkgName
, exAvVersion :: ExamplePkgVersion
, exAvDeps :: ComponentDeps [ExampleDependency]
}
} deriving Show
exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency]
-> ExampleAvailable
......@@ -142,17 +150,23 @@ data ExampleInstalled = ExInst {
exInstName :: ExamplePkgName
, exInstVersion :: ExamplePkgVersion
, exInstHash :: ExamplePkgHash
, exInstBuildAgainst :: [ExampleInstalled]
}
, exInstBuildAgainst :: [ExamplePkgHash]
} deriving Show
exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash
-> [ExampleInstalled] -> ExampleInstalled
exInst = ExInst
exInst pn v hash deps = ExInst pn v hash (map exInstHash deps)
type ExampleDb = [Either ExampleInstalled ExampleAvailable]
type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a
newtype IndepGoals = IndepGoals Bool
deriving Show
newtype ReorderGoals = ReorderGoals Bool
deriving Show
exDbPkgs :: ExampleDb -> [ExamplePkgName]
exDbPkgs = map (either exInstName exAvName)
......@@ -329,8 +343,7 @@ exInstInfo :: ExampleInstalled -> C.InstalledPackageInfo
exInstInfo ex = C.emptyInstalledPackageInfo {
C.installedUnitId = C.mkUnitId (exInstHash ex)
, C.sourcePackageId = exInstPkgId ex
, C.depends = map (C.mkUnitId . exInstHash)
(exInstBuildAgainst ex)
, C.depends = map C.mkUnitId (exInstBuildAgainst ex)
}
exInstPkgId :: ExampleInstalled -> C.PackageIdentifier
......@@ -352,13 +365,15 @@ exResolve :: ExampleDb
-> Maybe [Language]
-> PC.PkgConfigDb
-> [ExamplePkgName]
-> Bool
-> Solver
-> IndepGoals
-> ReorderGoals
-> [ExPreference]
-> ([String], Either String CI.InstallPlan.InstallPlan)
exResolve db exts langs pkgConfigDb targets indepGoals prefs = runProgress $
exResolve db exts langs pkgConfigDb targets solver (IndepGoals indepGoals) (ReorderGoals reorder) prefs = runProgress $
resolveDependencies C.buildPlatform
compiler pkgConfigDb
Modular
solver
params
where
defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag
......@@ -377,9 +392,9 @@ exResolve db exts langs pkgConfigDb targets indepGoals prefs = runProgress $
targets' = fmap (\p -> NamedPackage (C.PackageName p) []) targets
params = addPreferences (fmap toPref prefs)
$ addConstraints (fmap toLpc enableTests)
$ (standardInstallPolicy instIdx avaiIdx targets') {
depResolverIndependentGoals = indepGoals
}
$ setIndependentGoals indepGoals
$ setReorderGoals reorder
$ standardInstallPolicy instIdx avaiIdx targets'
toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown
toPref (ExPref n v) = PackageVersionPreference (C.PackageName n) v
......
{-# 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)
]
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)]
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 <$> 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 TopLevel)
return (comp, deps)
-- | Location of an 'ExampleDependency'. It determines which values are valid.
data ExDepLocation = TopLevel | Nested | Setup
arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency
arbitraryExDep db@(TestDb pkgs) level =
let test = ExTest <$> arbitraryTestName
<*> smallListOf (arbitraryExDep db Nested)
flag = ExFlag <$> arbitraryFlagName
<*> arbitraryDeps db
<*> arbitraryDeps db
nonNested = [
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
TopLevel -> test : flag : nonNested
Nested -> flag : nonNested
Setup -> nonNested
arbitraryDeps :: TestDb -> Gen Dependencies
arbitraryDeps db = frequency
[ (1, return NotBuildable)
, (20, Buildable <$> smallListOf (arbitraryExDep db Nested))
]
arbitraryTestName :: Gen String
arbitraryTestName = (:[]) <$> elements ['A'..'E']
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 [ return ComponentLib
, ComponentExe <$> arbitraryComponentName
, ComponentTest <$> arbitraryComponentName
, ComponentBench <$> arbitraryComponentName
, return ComponentSetup
]
shrink ComponentLib = []
shrink _ = [ComponentLib]
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 (ExTest testName deps) =
deps ++ [ExTest testName deps' | deps' <- shrink deps]
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)]]
......@@ -19,6 +19,7 @@ import Language.Haskell.Extension ( Extension(..)
-- cabal-install
import Distribution.Client.PkgConfigDb (PkgConfigDb, pkgConfigDbFromList)
import Distribution.Client.Dependency.Types (Solver(Modular))
import UnitTests.Distribution.Client.Dependency.Modular.DSL
import UnitTests.Options
......@@ -121,7 +122,7 @@ tests = [
]
]
where
indep test = test { testIndepGoals = True }
indep test = test { testIndepGoals = IndepGoals True }
soft prefs test = test { testSoftConstraints = prefs }
mkvrThis = V.thisVersion . makeV
mkvrOrEarlier = V.orEarlierVersion . makeV
......@@ -135,7 +136,7 @@ data SolverTest = SolverTest {
testLabel :: String
, testTargets :: [String]
, testResult :: Maybe [(String, Int)]
, testIndepGoals :: Bool
, testIndepGoals :: IndepGoals
, testSoftConstraints :: [ExPreference]
, testDb :: ExampleDb
, testSupportedExts :: Maybe [Extension]
......@@ -186,7 +187,7 @@ mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest {
testLabel = label
, testTargets = targets
, testResult = result
, testIndepGoals = False
, testIndepGoals = IndepGoals False
, testSoftConstraints = []
, testDb = db
, testSupportedExts = exts
......@@ -197,8 +198,10 @@ mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest {
runTest :: SolverTest -> TF.TestTree
runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
testCase testLabel $ do
let (_msgs, result) = exResolve testDb testSupportedExts testSupportedLangs
testPkgConfigDb testTargets testIndepGoals testSoftConstraints
let (_msgs, result) = exResolve testDb testSupportedExts
testSupportedLangs testPkgConfigDb testTargets
Modular testIndepGoals (ReorderGoals False)
testSoftConstraints
when showSolverLog $ mapM_ putStrLn _msgs
case result of
Left err -> assertBool ("Unexpected error:\n" ++ err) (isNothing testResult)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment