Commit 1bc42a89 authored by kristenk's avatar kristenk Committed by Mikhail Glushenkov

Solver DSL: Support benchmarks, internal libraries, and foreign libraries.

This change allows the solver quickcheck tests to test all types of components.
Previously, the tests generated the components in the solver DSL, but the code
that converted the packages to GenericPackageDescriptions removed some of the
components, i.e., it filtered out benchmarks and foreign libraries and merged
internal libraries with the main library.
parent 3c339d2e
...@@ -40,6 +40,7 @@ import Prelude () ...@@ -40,6 +40,7 @@ import Prelude ()
import Distribution.Solver.Compat.Prelude import Distribution.Solver.Compat.Prelude
-- base -- base
import Control.Arrow (second)
import Data.Either (partitionEithers) import Data.Either (partitionEithers)
import qualified Data.Map as Map import qualified Data.Map as Map
...@@ -50,7 +51,8 @@ import Distribution.License (License(..)) ...@@ -50,7 +51,8 @@ import Distribution.License (License(..))
import qualified Distribution.ModuleName as Module import qualified Distribution.ModuleName as Module
import qualified Distribution.Package as C import qualified Distribution.Package as C
hiding (HasUnitId(..)) hiding (HasUnitId(..))
import qualified Distribution.Types.ExeDependency as C import qualified Distribution.Types.ExeDependency as C
import qualified Distribution.Types.ForeignLib as C
import qualified Distribution.Types.LegacyExeDependency as C import qualified Distribution.Types.LegacyExeDependency as C
import qualified Distribution.Types.PkgconfigDependency as C import qualified Distribution.Types.PkgconfigDependency as C
import qualified Distribution.Types.UnqualComponentName as C import qualified Distribution.Types.UnqualComponentName as C
...@@ -327,14 +329,14 @@ exAvSrcPkg ex = ...@@ -327,14 +329,14 @@ exAvSrcPkg ex =
usedFlags :: Map ExampleFlagName C.Flag usedFlags :: Map ExampleFlagName C.Flag
usedFlags = Map.fromList [(fn, mkDefaultFlag fn) | fn <- names] usedFlags = Map.fromList [(fn, mkDefaultFlag fn) | fn <- names]
where where
names = concatMap extractFlags $ names = concatMap extractFlags $ CD.flatDeps (exAvDeps ex)
CD.libraryDeps (exAvDeps ex)
++ concatMap snd testSuites
++ concatMap snd executables
in -- 'declaredFlags' overrides 'usedFlags' to give flags non-default settings: in -- 'declaredFlags' overrides 'usedFlags' to give flags non-default settings:
Map.elems $ declaredFlags `Map.union` usedFlags Map.elems $ declaredFlags `Map.union` usedFlags
subLibraries = [(name, deps) | (CD.ComponentSubLib name, deps) <- CD.toList (exAvDeps ex)]
foreignLibraries = [(name, deps) | (CD.ComponentFLib name, deps) <- CD.toList (exAvDeps ex)]
testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)] testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)]
benchmarks = [(name, deps) | (CD.ComponentBench name, deps) <- CD.toList (exAvDeps ex)]
executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)] executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)]
setup = case CD.setupDeps (exAvDeps ex) of setup = case CD.setupDeps (exAvDeps ex) of
[] -> Nothing [] -> Nothing
...@@ -359,24 +361,35 @@ exAvSrcPkg ex = ...@@ -359,24 +361,35 @@ exAvSrcPkg ex =
, C.description = "description" , C.description = "description"
, C.synopsis = "synopsis" , C.synopsis = "synopsis"
, C.licenseFiles = ["LICENSE"] , C.licenseFiles = ["LICENSE"]
, C.specVersionRaw = Left $ C.mkVersion [1,12] -- Version 2.0 is required for internal libraries.
, C.specVersionRaw = Left $ C.mkVersion [2,0]
} }
, C.genPackageFlags = flags , C.genPackageFlags = flags
, C.condLibrary = , C.condLibrary =
let mkLib bi = mempty { C.libBuildInfo = bi } let mkLib bi = mempty { C.libBuildInfo = bi }
in Just $ mkCondTree defaultLib mkLib $ mkBuildInfoTree $ in Just $ mkCondTree defaultLib mkLib $ mkBuildInfoTree $
Buildable (CD.libraryDeps (exAvDeps ex)) Buildable $ fromMaybe [] $
, C.condSubLibraries = [] lookup CD.ComponentLib (CD.toList (exAvDeps ex))
, C.condForeignLibs = [] , C.condSubLibraries =
let mkTree = mkCondTree defaultLib mkLib . mkBuildInfoTree . Buildable
mkLib bi = mempty { C.libBuildInfo = bi }
in map (second mkTree) subLibraries
, C.condForeignLibs =
let mkTree = mkCondTree mempty mkLib . mkBuildInfoTree . Buildable
mkLib bi = mempty { C.foreignLibBuildInfo = bi }
in map (second mkTree) foreignLibraries
, C.condExecutables = , C.condExecutables =
let mkTree = mkCondTree defaultExe mkExe . mkBuildInfoTree . Buildable let mkTree = mkCondTree defaultExe mkExe . mkBuildInfoTree . Buildable
mkExe bi = mempty { C.buildInfo = bi } mkExe bi = mempty { C.buildInfo = bi }
in map (\(t, deps) -> (t, mkTree deps)) executables in map (second mkTree) executables
, C.condTestSuites = , C.condTestSuites =
let mkTree = mkCondTree defaultTest mkTest . mkBuildInfoTree . Buildable let mkTree = mkCondTree defaultTest mkTest . mkBuildInfoTree . Buildable
mkTest bi = mempty { C.testBuildInfo = bi } mkTest bi = mempty { C.testBuildInfo = bi }
in map (\(t, deps) -> (t, mkTree deps)) testSuites in map (second mkTree) testSuites
, C.condBenchmarks = [] , C.condBenchmarks =
let mkTree = mkCondTree defaultBenchmark mkBench . mkBuildInfoTree . Buildable
mkBench bi = mempty { C.benchmarkBuildInfo = bi }
in map (second mkTree) benchmarks
} }
} }
pkgCheckErrors = pkgCheckErrors =
...@@ -405,6 +418,11 @@ exAvSrcPkg ex = ...@@ -405,6 +418,11 @@ exAvSrcPkg ex =
C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1,0]) "Test.hs" C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1,0]) "Test.hs"
} }
defaultBenchmark :: C.Benchmark
defaultBenchmark = mempty {
C.benchmarkInterface = C.BenchmarkExeV10 (C.mkVersion [1,0]) "Benchmark.hs"
}
-- Split the set of dependencies into the set of dependencies of the library, -- Split the set of dependencies into the set of dependencies of the library,
-- the dependencies of the test suites and extensions. -- the dependencies of the test suites and extensions.
splitTopLevel :: [ExampleDependency] splitTopLevel :: [ExampleDependency]
......
...@@ -267,7 +267,7 @@ instance Arbitrary TestDb where ...@@ -267,7 +267,7 @@ instance Arbitrary TestDb where
arbitraryExAv :: PN -> PV -> TestDb -> Gen ExampleAvailable arbitraryExAv :: PN -> PV -> TestDb -> Gen ExampleAvailable
arbitraryExAv pn v db = arbitraryExAv pn v db =
(\cds -> ExAv (unPN pn) (unPV v) cds []) <$> arbitraryComponentDeps db (\cds -> ExAv (unPN pn) (unPV v) cds []) <$> arbitraryComponentDeps pn db
arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled
arbitraryExInst pn v pkgs = do arbitraryExInst pn v pkgs = do
...@@ -276,15 +276,19 @@ arbitraryExInst pn v pkgs = do ...@@ -276,15 +276,19 @@ arbitraryExInst pn v pkgs = do
deps <- randomSubset numDeps pkgs deps <- randomSubset numDeps pkgs
return $ ExInst (unPN pn) (unPV v) pkgHash (map exInstHash deps) return $ ExInst (unPN pn) (unPV v) pkgHash (map exInstHash deps)
arbitraryComponentDeps :: TestDb -> Gen (ComponentDeps [ExampleDependency]) arbitraryComponentDeps :: PN -> TestDb -> Gen (ComponentDeps [ExampleDependency])
arbitraryComponentDeps (TestDb []) = return $ CD.fromList [] arbitraryComponentDeps _ (TestDb []) = return $ CD.fromList []
arbitraryComponentDeps db = arbitraryComponentDeps pn db =
-- dedupComponentNames removes components with duplicate names, for example, -- dedupComponentNames removes components with duplicate names, for example,
-- 'ComponentExe x' and 'ComponentTest x', and then CD.fromList combines -- 'ComponentExe x' and 'ComponentTest x', and then CD.fromList combines
-- duplicate unnamed components. -- duplicate unnamed components.
CD.fromList . dedupComponentNames <$> CD.fromList . dedupComponentNames . filter (isValid . fst)
boundedListOf 5 (arbitraryComponentDep db) <$> boundedListOf 5 (arbitraryComponentDep db)
where where
isValid :: Component -> Bool
isValid (ComponentSubLib name) = name /= mkUnqualComponentName (unPN pn)
isValid _ = True
dedupComponentNames = dedupComponentNames =
nubBy ((\x y -> isJust x && isJust y && x == y) `on` componentName . fst) nubBy ((\x y -> isJust x && isJust y && x == y) `on` componentName . fst)
...@@ -378,7 +382,12 @@ instance Arbitrary IndependentGoals where ...@@ -378,7 +382,12 @@ instance Arbitrary IndependentGoals where
shrink (IndependentGoals indep) = [IndependentGoals False | indep] shrink (IndependentGoals indep) = [IndependentGoals False | indep]
instance Arbitrary UnqualComponentName where instance Arbitrary UnqualComponentName where
arbitrary = mkUnqualComponentName <$> (:[]) <$> elements "ABC" -- The "component-" prefix prevents component names and build-depends
-- dependency names from overlapping.
-- TODO: Remove the prefix once the QuickCheck tests support dependencies on
-- internal libraries.
arbitrary =
mkUnqualComponentName <$> (\c -> "component-" ++ [c]) <$> elements "ABC"
instance Arbitrary Component where instance Arbitrary Component where
arbitrary = oneof [ return ComponentLib arbitrary = oneof [ return ComponentLib
......
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