Commit 266c5aa4 authored by kristenk's avatar kristenk Committed by GitHub
Browse files

Merge pull request #4028 from grayjay/buildable-solver-tests-2

Solver DSL improvements
parents d53f62c8 cb6603a1
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | DSL for testing the modular solver
module UnitTests.Distribution.Solver.Modular.DSL (
ExampleDependency(..)
......@@ -29,25 +30,30 @@ module UnitTests.Distribution.Solver.Modular.DSL (
, runProgress
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
-- base
import Data.Either (partitionEithers)
import Data.Maybe (catMaybes, isNothing)
import Data.List (elemIndex, nub)
import Data.Monoid
import Data.List (elemIndex)
import Data.Ord (comparing)
import qualified Data.Map as Map
-- Cabal
import qualified Distribution.Compiler as C
import qualified Distribution.InstalledPackageInfo as C
import qualified Distribution.Package as C
import qualified Distribution.Compiler as C
import qualified Distribution.InstalledPackageInfo as IPI
import Distribution.License (License(..))
import qualified Distribution.ModuleName as Module
import qualified Distribution.Package as C
hiding (HasUnitId(..))
import qualified Distribution.PackageDescription as C
import qualified Distribution.Simple.PackageIndex as C.PackageIndex
import qualified Distribution.PackageDescription as C
import qualified Distribution.PackageDescription.Check as C
import qualified Distribution.Simple.PackageIndex as C.PackageIndex
import Distribution.Simple.Setup (BooleanFlag(..))
import qualified Distribution.System as C
import qualified Distribution.Version as C
import Language.Haskell.Extension (Extension(..), Language)
import qualified Distribution.System as C
import Distribution.Text (display)
import qualified Distribution.Version as C
import Language.Haskell.Extension (Extension(..), Language(..))
-- cabal-install
import Distribution.Client.Dependency
......@@ -246,51 +252,95 @@ type ExampleDb = [Either ExampleInstalled ExampleAvailable]
type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a
type DependencyComponent a = ( C.Condition C.ConfVar
, DependencyTree a
, Maybe (DependencyTree a))
exDbPkgs :: ExampleDb -> [ExamplePkgName]
exDbPkgs = map (either exInstName exAvName)
exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage
exAvSrcPkg ex =
let (libraryDeps, exts, mlang, pcpkgs, exes) = splitTopLevel (CD.libraryDeps (exAvDeps ex))
let pkgId = exAvPkgId ex
testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)]
executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)]
in SourcePackage {
packageInfoId = exAvPkgId ex
, packageSource = LocalTarballPackage "<<path>>"
, packageDescrOverride = Nothing
, packageDescription = C.GenericPackageDescription {
C.packageDescription = C.emptyPackageDescription {
C.package = exAvPkgId ex
, C.library = error "not yet configured: library"
, C.subLibraries = error "not yet configured: subLibraries"
, C.executables = error "not yet configured: executables"
, C.testSuites = error "not yet configured: testSuites"
, C.benchmarks = error "not yet configured: benchmarks"
, C.buildDepends = error "not yet configured: buildDepends"
, C.setupBuildInfo = Just C.SetupBuildInfo {
C.setupDepends = mkSetupDeps (CD.setupDeps (exAvDeps ex)),
C.defaultSetupDepends = False
}
}
, C.genPackageFlags = nub $ concatMap extractFlags $
CD.libraryDeps (exAvDeps ex)
++ concatMap snd testSuites
++ concatMap snd executables
, C.condLibrary = Just (mkCondTree
(extsLib exts <> langLib mlang <> pcpkgLib pcpkgs <> buildtoolsLib exes)
disableLib
(Buildable libraryDeps))
, C.condSubLibraries = []
, C.condExecutables =
let mkTree = mkCondTree mempty disableExe . Buildable
in map (\(t, deps) -> (t, mkTree deps)) executables
, C.condTestSuites =
let mkTree = mkCondTree mempty disableTest . Buildable
in map (\(t, deps) -> (t, mkTree deps)) testSuites
, C.condBenchmarks = []
}
}
setup = case CD.setupDeps (exAvDeps ex) of
[] -> Nothing
deps -> Just C.SetupBuildInfo {
C.setupDepends = mkSetupDeps deps,
C.defaultSetupDepends = False
}
package = SourcePackage {
packageInfoId = pkgId
, packageSource = LocalTarballPackage "<<path>>"
, packageDescrOverride = Nothing
, packageDescription = C.GenericPackageDescription {
C.packageDescription = C.emptyPackageDescription {
C.package = pkgId
, C.library = error "not yet configured: library"
, C.subLibraries = error "not yet configured: subLibraries"
, C.executables = error "not yet configured: executables"
, C.testSuites = error "not yet configured: testSuites"
, C.benchmarks = error "not yet configured: benchmarks"
, C.buildDepends = error "not yet configured: buildDepends"
, C.setupBuildInfo = setup
, C.license = BSD3
, C.buildType = if isNothing setup
then Just C.Simple
else Just C.Custom
, C.category = "category"
, C.maintainer = "maintainer"
, C.description = "description"
, C.synopsis = "synopsis"
, C.licenseFiles = ["LICENSE"]
, C.specVersionRaw = Left $ C.mkVersion [1,12]
}
, C.genPackageFlags = nub $ concatMap extractFlags $
CD.libraryDeps (exAvDeps ex)
++ concatMap snd testSuites
++ concatMap snd executables
, C.condLibrary =
let mkLib bi = mempty { C.libBuildInfo = bi }
in Just $ mkCondTree defaultLib mkLib $ mkBuildInfoTree $
Buildable (CD.libraryDeps (exAvDeps ex))
, C.condSubLibraries = []
, C.condExecutables =
let mkTree = mkCondTree defaultExe mkExe . mkBuildInfoTree . Buildable
mkExe bi = mempty { C.buildInfo = bi }
in map (\(t, deps) -> (t, mkTree deps)) executables
, C.condTestSuites =
let mkTree = mkCondTree defaultTest mkTest . mkBuildInfoTree . Buildable
mkTest bi = mempty { C.testBuildInfo = bi }
in map (\(t, deps) -> (t, mkTree deps)) testSuites
, C.condBenchmarks = []
}
}
pkgCheckErrors =
-- We ignore these warnings because some unit tests test that the
-- solver allows unknown extensions/languages when the compiler
-- supports them.
let ignore = ["Unknown extensions:", "Unknown languages:"]
in [ err | err <- C.checkPackage (packageDescription package) Nothing
, not $ any (`isPrefixOf` C.explanation err) ignore ]
in if null pkgCheckErrors
then package
else error $ "invalid GenericPackageDescription for package "
++ display pkgId ++ ": " ++ show pkgCheckErrors
where
defaultTopLevelBuildInfo :: C.BuildInfo
defaultTopLevelBuildInfo = mempty { C.defaultLanguage = Just Haskell98 }
defaultLib :: C.Library
defaultLib = mempty { C.exposedModules = [Module.fromString "Module"] }
defaultExe :: C.Executable
defaultExe = mempty { C.modulePath = "Main.hs" }
defaultTest :: C.TestSuite
defaultTest = mempty {
C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1,0]) "Test.hs"
}
-- Split the set of dependencies into the set of dependencies of the library,
-- the dependencies of the test suites and extensions.
splitTopLevel :: [ExampleDependency]
......@@ -298,7 +348,7 @@ exAvSrcPkg ex =
, [Extension]
, Maybe Language
, [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config
, [(ExamplePkgName, Maybe Int)]
, [(ExamplePkgName, Maybe Int)] -- build tools
)
splitTopLevel [] =
([], [], Nothing, [], [])
......@@ -343,22 +393,52 @@ exAvSrcPkg ex =
extractFlags (ExLang _) = []
extractFlags (ExPkg _) = []
mkCondTree :: Monoid a => a -> (a -> a) -> Dependencies -> DependencyTree a
mkCondTree x dontBuild NotBuildable =
-- Convert a tree of BuildInfos into a tree of a specific component type.
-- 'defaultTopLevel' contains the default values for the component, and
-- 'mkComponent' creates a component from a 'BuildInfo'.
mkCondTree :: forall a. Semigroup a =>
a -> (C.BuildInfo -> a)
-> DependencyTree C.BuildInfo
-> DependencyTree a
mkCondTree defaultTopLevel mkComponent (C.CondNode topData topConstraints topComps) =
C.CondNode {
C.condTreeData =
defaultTopLevel <> mkComponent (defaultTopLevelBuildInfo <> topData)
, C.condTreeConstraints = topConstraints
, C.condTreeComponents = goComponents topComps
}
where
go :: DependencyTree C.BuildInfo -> DependencyTree a
go (C.CondNode ctData constraints comps) =
C.CondNode (mkComponent ctData) constraints (goComponents comps)
goComponents :: [DependencyComponent C.BuildInfo]
-> [DependencyComponent a]
goComponents comps = [(cond, go t, go <$> me) | (cond, t, me) <- comps]
mkBuildInfoTree :: Dependencies -> DependencyTree C.BuildInfo
mkBuildInfoTree NotBuildable =
C.CondNode {
C.condTreeData = dontBuild x
C.condTreeData = mempty { C.buildable = False }
, C.condTreeConstraints = []
, C.condTreeComponents = []
}
mkCondTree x dontBuild (Buildable deps) =
let (directDeps, flaggedDeps) = splitDeps deps
mkBuildInfoTree (Buildable deps) =
let (libraryDeps, exts, mlang, pcpkgs, buildTools) = splitTopLevel deps
(directDeps, flaggedDeps) = splitDeps libraryDeps
bi = mempty {
C.otherExtensions = exts
, C.defaultLanguage = mlang
, C.buildTools = map mkDirect buildTools
, C.pkgconfigDepends = [mkDirect (n, (Just v)) | (n,v) <- pcpkgs]
}
in C.CondNode {
C.condTreeData = x -- Necessary for language extensions
C.condTreeData = bi -- Necessary for language extensions
-- TODO: Arguably, build-tools dependencies should also
-- effect constraints on conditional tree. But no way to
-- distinguish between them
, C.condTreeConstraints = map mkDirect directDeps
, C.condTreeComponents = map (mkFlagged dontBuild) flaggedDeps
, C.condTreeComponents = map mkFlagged flaggedDeps
}
mkDirect :: (ExamplePkgName, Maybe ExamplePkgVersion) -> C.Dependency
......@@ -367,14 +447,13 @@ exAvSrcPkg ex =
where
v = C.mkVersion [n, 0, 0]
mkFlagged :: Monoid a
=> (a -> a)
-> (ExampleFlagName, Dependencies, Dependencies)
-> (C.Condition C.ConfVar
, DependencyTree a, Maybe (DependencyTree a))
mkFlagged dontBuild (f, a, b) = ( C.Var (C.Flag (C.FlagName f))
, mkCondTree mempty dontBuild a
, Just (mkCondTree mempty dontBuild b)
mkFlagged :: (ExampleFlagName, Dependencies, Dependencies)
-> ( C.Condition C.ConfVar
, DependencyTree C.BuildInfo
, Maybe (DependencyTree C.BuildInfo))
mkFlagged (f, a, b) = ( C.Var (C.Flag (C.FlagName f))
, mkBuildInfoTree a
, Just (mkBuildInfoTree b)
)
-- Split a set of dependencies into direct dependencies and flagged
......@@ -382,8 +461,6 @@ exAvSrcPkg ex =
-- maybe its version (no version means any version) meant to be converted
-- to a 'C.Dependency' with 'mkDirect' for example. A flagged dependency is
-- the set of dependencies guarded by a flag.
--
-- TODO: Take care of flagged language extensions and language flavours.
splitDeps :: [ExampleDependency]
-> ( [(ExamplePkgName, Maybe Int)]
, [(ExampleFlagName, Dependencies, Dependencies)]
......@@ -399,55 +476,24 @@ exAvSrcPkg ex =
splitDeps (ExFlag f a b:deps) =
let (directDeps, flaggedDeps) = splitDeps deps
in (directDeps, (f, a, b):flaggedDeps)
splitDeps (_:deps) = splitDeps deps
splitDeps (dep:_) = error $ "Unexpected dependency: " ++ show dep
-- Currently we only support simple setup dependencies
-- custom-setup only supports simple dependencies
mkSetupDeps :: [ExampleDependency] -> [C.Dependency]
mkSetupDeps deps =
let (directDeps, []) = splitDeps deps in map mkDirect directDeps
-- A 'C.Library' with just the given extensions in its 'BuildInfo'
extsLib :: [Extension] -> C.Library
extsLib es = mempty { C.libBuildInfo = mempty { C.otherExtensions = es } }
-- A 'C.Library' with just the given extensions in its 'BuildInfo'
langLib :: Maybe Language -> C.Library
langLib (Just lang) = mempty { C.libBuildInfo = mempty { C.defaultLanguage = Just lang } }
langLib _ = mempty
disableLib :: C.Library -> C.Library
disableLib lib =
lib { C.libBuildInfo = (C.libBuildInfo lib) { C.buildable = False }}
disableTest :: C.TestSuite -> C.TestSuite
disableTest test =
test { C.testBuildInfo = (C.testBuildInfo test) { C.buildable = False }}
disableExe :: C.Executable -> C.Executable
disableExe exe =
exe { C.buildInfo = (C.buildInfo exe) { C.buildable = False }}
-- A 'C.Library' with just the given pkgconfig-depends in its 'BuildInfo'
pcpkgLib :: [(ExamplePkgName, ExamplePkgVersion)] -> C.Library
pcpkgLib ds = mempty { C.libBuildInfo = mempty { C.pkgconfigDepends = [mkDirect (n, (Just v)) | (n,v) <- ds] } }
buildtoolsLib :: [(ExamplePkgName, Maybe Int)] -> C.Library
buildtoolsLib ds = mempty { C.libBuildInfo = mempty {
C.buildTools = map mkDirect ds
} }
exAvPkgId :: ExampleAvailable -> C.PackageIdentifier
exAvPkgId ex = C.PackageIdentifier {
pkgName = C.mkPackageName (exAvName ex)
, pkgVersion = C.mkVersion [exAvVersion ex, 0, 0]
}
exInstInfo :: ExampleInstalled -> C.InstalledPackageInfo
exInstInfo ex = C.emptyInstalledPackageInfo {
C.installedUnitId = C.mkUnitId (exInstHash ex)
, C.sourcePackageId = exInstPkgId ex
, C.depends = map C.mkUnitId (exInstBuildAgainst ex)
exInstInfo :: ExampleInstalled -> IPI.InstalledPackageInfo
exInstInfo ex = IPI.emptyInstalledPackageInfo {
IPI.installedUnitId = C.mkUnitId (exInstHash ex)
, IPI.sourcePackageId = exInstPkgId ex
, IPI.depends = map C.mkUnitId (exInstBuildAgainst ex)
}
exInstPkgId :: ExampleInstalled -> C.PackageIdentifier
......
......@@ -258,16 +258,18 @@ arbitraryExDep db@(TestDb pkgs) level =
let flag = ExFlag <$> arbitraryFlagName
<*> arbitraryDeps db
<*> arbitraryDeps db
other = [
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)
]
other =
-- Package checks require dependencies on "base" to have bounds.
let notBase = filter ((/= PN "base") . getName) pkgs
in [ExAny . unPN <$> elements (map getName notBase) | not (null notBase)]
++ [
-- 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
NonSetupDep -> flag : other
......@@ -332,6 +334,7 @@ instance Arbitrary ExampleDependency where
arbitrary = error "arbitrary not implemented: ExampleDependency"
shrink (ExAny _) = []
shrink (ExFix "base" _) = [] -- preserve bounds on base
shrink (ExFix pn _) = [ExAny pn]
shrink (ExFlag flag th el) =
deps th ++ deps el
......
......@@ -139,7 +139,7 @@ tests = [
testBuildable "avoid building component with unknown dependency" (ExAny "unknown")
, testBuildable "avoid building component with unknown extension" (ExExt (UnknownExtension "unknown"))
, testBuildable "avoid building component with unknown language" (ExLang (UnknownLanguage "unknown"))
, runTest $ enableAllTests $ mkTest dbBuildable1 "choose flags that set buildable to false" ["pkg"] (solverSuccess [("flag1-false", 1), ("flag2-true", 1), ("pkg", 1)])
, runTest $ mkTest dbBuildable1 "choose flags that set buildable to false" ["pkg"] (solverSuccess [("flag1-false", 1), ("flag2-true", 1), ("pkg", 1)])
, runTest $ mkTest dbBuildable2 "choose version that sets buildable to false" ["A"] (solverSuccess [("A", 1), ("B", 2)])
]
, testGroup "Pkg-config dependencies" [
......@@ -974,23 +974,22 @@ dbLangs1 = [
, Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"]
]
-- | cabal must set enable-lib to false in order to avoid the unavailable
-- | cabal must set enable-exe to false in order to avoid the unavailable
-- dependency. Flags are true by default. The flag choice causes "pkg" to
-- depend on "false-dep".
testBuildable :: String -> ExampleDependency -> TestTree
testBuildable testName unavailableDep =
runTest $ enableAllTests $
mkTestExtLangPC (Just []) (Just []) [] db testName ["pkg"] expected
runTest $
mkTestExtLangPC (Just []) (Just [Haskell98]) [] db testName ["pkg"] expected
where
expected = solverSuccess [("false-dep", 1), ("pkg", 1)]
db = [
Right $ exAv "pkg" 1
[ unavailableDep
, ExFlag "enable-lib" (Buildable []) NotBuildable ]
`withTest`
ExTest "test" [exFlag "enable-lib"
[ExAny "true-dep"]
[ExAny "false-dep"]]
Right $ exAv "pkg" 1 [exFlag "enable-exe"
[ExAny "true-dep"]
[ExAny "false-dep"]]
`withExe`
ExExe "exe" [ unavailableDep
, ExFlag "enable-exe" (Buildable []) NotBuildable ]
, Right $ exAv "true-dep" 1 []
, Right $ exAv "false-dep" 1 []
]
......@@ -1000,18 +999,19 @@ testBuildable testName unavailableDep =
dbBuildable1 :: ExampleDb
dbBuildable1 = [
Right $ exAv "pkg" 1
[ ExAny "unknown"
, ExFlag "flag1" (Buildable []) NotBuildable
, ExFlag "flag2" (Buildable []) NotBuildable]
`withTests`
[ ExTest "optional-test"
[ ExAny "unknown"
, ExFlag "flag1"
(Buildable [])
(Buildable [ExFlag "flag2" NotBuildable (Buildable [])])]
, ExTest "test" [ exFlag "flag1" [ExAny "flag1-true"] [ExAny "flag1-false"]
, exFlag "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]]
]
[ exFlag "flag1" [ExAny "flag1-true"] [ExAny "flag1-false"]
, exFlag "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]]
`withExes`
[ ExExe "exe1"
[ ExAny "unknown"
, ExFlag "flag1" (Buildable []) NotBuildable
, ExFlag "flag2" (Buildable []) NotBuildable]
, ExExe "exe2"
[ ExAny "unknown"
, ExFlag "flag1"
(Buildable [])
(Buildable [ExFlag "flag2" NotBuildable (Buildable [])])]
]
, Right $ exAv "flag1-true" 1 []
, Right $ exAv "flag1-false" 1 []
, Right $ exAv "flag2-true" 1 []
......@@ -1023,9 +1023,11 @@ dbBuildable2 :: ExampleDb
dbBuildable2 = [
Right $ exAv "A" 1 [ExAny "B"]
, Right $ exAv "B" 1 [ExAny "unknown"]
, Right $ exAv "B" 2
, Right $ exAv "B" 2 []
`withExe`
ExExe "exe"
[ ExAny "unknown"
, ExFlag "disable-lib" NotBuildable (Buildable [])
, ExFlag "disable-exe" NotBuildable (Buildable [])
]
, Right $ exAv "B" 3 [ExAny "unknown"]
]
......
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