Merge pull request #3245 from grayjay/solver-quickcheck

Dependency solver quickcheck tests

.travis.yml

@@ -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

appveyor.yml

@@ -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

cabal-install/cabal-install.cabal

@@ -342,6 +342,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

cabal-install/tests/SolverQuickCheck.hs

+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

cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs

@@ -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
 

cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/QuickCheck.hs

+{-# 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)]]

cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs

@@ -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)