Skip to content

Commit

Permalink
Add solver tests for language extensions and flavours
Browse files Browse the repository at this point in the history 
This also includes modifications to the solver testing DSL and the
testing functions.

This is necessary for merging PR #2732.
  • Loading branch information
@jdnavarro
jdnavarro committed Oct 29, 2015
1 parent e1ac8e7 commit 594335b
Show file tree
Hide file tree
Showing 2 changed files with 147 additions and 31 deletions.
90 changes: 71 additions & 19 deletions cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,6 +26,7 @@ import qualified Distribution.PackageDescription as C
import qualified Distribution.Simple.PackageIndex as C.PackageIndex
import qualified Distribution.System as C
import qualified Distribution.Version as C
import Language.Haskell.Extension (Extension(..), Language)

-- cabal-install
import Distribution.Client.ComponentDeps (ComponentDeps)
Expand Down Expand Up @@ -97,6 +98,13 @@ data ExampleDependency =
-- | Dependency if tests are enabled
| ExTest ExampleTestName [ExampleDependency]

-- | Dependency on a language extension
| ExExt Extension

-- | Dependency on a language version
| ExLang Language


data ExampleAvailable = ExAv {
exAvName :: ExamplePkgName
, exAvVersion :: ExamplePkgVersion
Expand Down Expand Up @@ -133,12 +141,12 @@ exDbPkgs = map (either exInstName exAvName)

exAvSrcPkg :: ExampleAvailable -> SourcePackage
exAvSrcPkg ex =
let (libraryDeps, testSuites) = splitTopLevel (CD.libraryDeps (exAvDeps ex))
let (libraryDeps, testSuites, exts, mlang) = splitTopLevel (CD.libraryDeps (exAvDeps ex))
in SourcePackage {
packageInfoId = exAvPkgId ex
, packageSource = LocalTarballPackage "<<path>>"
, packageDescrOverride = Nothing
, packageDescription = C.GenericPackageDescription{
, packageDescription = C.GenericPackageDescription {
C.packageDescription = C.emptyPackageDescription {
C.package = exAvPkgId ex
, C.library = error "not yet configured: library"
Expand All @@ -152,26 +160,39 @@ exAvSrcPkg ex =
}
, C.genPackageFlags = concatMap extractFlags
(CD.libraryDeps (exAvDeps ex))
, C.condLibrary = Just $ mkCondTree libraryDeps
, C.condLibrary = Just $ mkCondTree (extsLib exts <> langLib mlang) libraryDeps
, C.condExecutables = []
, C.condTestSuites = map (\(t, deps) -> (t, mkCondTree deps))
, C.condTestSuites = map (\(t, deps) -> (t, mkCondTree mempty deps))
testSuites
, C.condBenchmarks = []
}
}
where
-- Split the set of dependencies into the set of dependencies of the library,
-- the dependencies of the test suites and extensions.
splitTopLevel :: [ExampleDependency]
-> ( [ExampleDependency]
, [(ExampleTestName, [ExampleDependency])]
, [Extension]
, Maybe Language
)
splitTopLevel [] = ([], [])
splitTopLevel [] =
([], [], [], Nothing)
splitTopLevel (ExTest t a:deps) =
let (other, testSuites) = splitTopLevel deps
in (other, (t, a):testSuites)
splitTopLevel (dep:deps) =
let (other, testSuites) = splitTopLevel deps
in (dep:other, testSuites)

let (other, testSuites, exts, lang) = splitTopLevel deps
in (other, (t, a):testSuites, exts, lang)
splitTopLevel (ExExt ext:deps) =
let (other, testSuites, exts, lang) = splitTopLevel deps
in (other, testSuites, ext:exts, lang)
splitTopLevel (ExLang lang:deps) =
case splitTopLevel deps of
(other, testSuites, exts, Nothing) -> (other, testSuites, exts, Just lang)
_ -> error "Only 1 Language dependency is supported"
splitTopLevel (dep:deps) =
let (other, testSuites, exts, lang) = splitTopLevel deps
in (dep:other, testSuites, exts, lang)

-- Extract the total set of flags used
extractFlags :: ExampleDependency -> [C.Flag]
extractFlags (ExAny _) = []
extractFlags (ExFix _ _) = []
Expand All @@ -183,13 +204,15 @@ exAvSrcPkg ex =
}
: concatMap extractFlags (a ++ b)
extractFlags (ExTest _ a) = concatMap extractFlags a
extractFlags (ExExt _) = []
extractFlags (ExLang _) = []

mkCondTree :: Monoid a => [ExampleDependency] -> DependencyTree a
mkCondTree deps =
mkCondTree :: Monoid a => a -> [ExampleDependency] -> DependencyTree a
mkCondTree x deps =
let (directDeps, flaggedDeps) = splitDeps deps
in C.CondNode {
C.condTreeData = mempty -- irrelevant to the solver
, C.condTreeConstraints = map mkDirect directDeps
C.condTreeData = x -- Necessary for language extensions
, C.condTreeConstraints = map mkDirect directDeps
, C.condTreeComponents = map mkFlagged flaggedDeps
}

Expand All @@ -204,10 +227,17 @@ exAvSrcPkg ex =
-> (C.Condition C.ConfVar
, DependencyTree a, Maybe (DependencyTree a))
mkFlagged (f, a, b) = ( C.Var (C.Flag (C.FlagName f))
, mkCondTree a
, Just (mkCondTree b)
, mkCondTree mempty a
, Just (mkCondTree mempty b)
)

-- Split a set of dependencies into direct dependencies and flagged
-- dependencies. A direct dependency is a tuple of the name of package and
-- 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, [ExampleDependency], [ExampleDependency])]
Expand All @@ -225,12 +255,22 @@ exAvSrcPkg ex =
in (directDeps, (f, a, b):flaggedDeps)
splitDeps (ExTest _ _:_) =
error "Unexpected nested test"
splitDeps (_:deps) = splitDeps deps

-- Currently we only support simple setup 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

exAvPkgId :: ExampleAvailable -> C.PackageIdentifier
exAvPkgId ex = C.PackageIdentifier {
pkgName = C.PackageName (exAvName ex)
Expand Down Expand Up @@ -258,15 +298,27 @@ exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex
exInstIdx = C.PackageIndex.fromList . map exInstInfo

exResolve :: ExampleDb
-- List of extensions supported by the compiler.
-> [Extension]
-- A compiler can support multiple languages.
-> [Language]
-> [ExamplePkgName]
-> Bool
-> ([String], Either String CI.InstallPlan.InstallPlan)
exResolve db targets indepGoals = runProgress $
exResolve db exts langs targets indepGoals = runProgress $
resolveDependencies C.buildPlatform
(C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag)
compiler
Modular
params
where
defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag
compiler = defaultCompiler { C.compilerInfoExtensions = if null exts
then Nothing
else Just exts
, C.compilerInfoLanguages = if null langs
then Nothing
else Just langs
}
(inst, avai) = partitionEithers db
instIdx = exInstIdx inst
avaiIdx = SourcePackageDb {
Expand Down
88 changes: 76 additions & 12 deletions cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,6 +13,9 @@ import Test.Tasty as TF
import Test.Tasty.HUnit (testCase, assertEqual, assertBool)
import Test.Tasty.Options

-- Cabal
import Language.Haskell.Extension (Extension(..), KnownExtension(..), Language(..))

-- cabal-install
import UnitTests.Distribution.Client.Dependency.Modular.DSL

Expand Down Expand Up @@ -67,6 +70,21 @@ tests = [
, runTest $ mkTest db12 "baseShim5" ["D"] Nothing
, runTest $ mkTest db12 "baseShim6" ["E"] (Just [("E", 1), ("syb", 2)])
]
, testGroup "Extensions" [
runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] Nothing
, runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedIndirect" ["B"] Nothing
, runTest $ mkTestExts [EnableExtension RankNTypes] dbExts1 "supported" ["A"] (Just [("A",1)])
, runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedIndirect" ["C"] (Just [("A",1),("B",1), ("C",1)])
, runTest $ mkTestExts [EnableExtension CPP] dbExts1 "disabledExtension" ["D"] Nothing
, runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "disabledExtension" ["D"] Nothing
, runTest $ mkTestExts (UnknownExtension "custom" : map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedUnknown" ["E"] (Just [("A",1),("B",1),("C",1),("E",1)])
]
, testGroup "Languages" [
runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupported" ["A"] Nothing
, runTest $ mkTestLangs [Haskell98,Haskell2010] dbLangs1 "supported" ["A"] (Just [("A",1)])
, runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] Nothing
, runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (Just [("A",1),("B",1),("C",1)])
]
]
where
indep test = test { testIndepGoals = True }
Expand All @@ -76,30 +94,59 @@ tests = [
-------------------------------------------------------------------------------}

data SolverTest = SolverTest {
testLabel :: String
, testTargets :: [String]
, testResult :: Maybe [(String, Int)]
, testIndepGoals :: Bool
, testDb :: ExampleDb
testLabel :: String
, testTargets :: [String]
, testResult :: Maybe [(String, Int)]
, testIndepGoals :: Bool
, testDb :: ExampleDb
, testSupportedExts :: [Extension]
, testSupportedLangs :: [Language]
}

mkTest :: ExampleDb
-> String
-> [String]
-> Maybe [(String, Int)]
-> SolverTest
mkTest db label targets result = SolverTest {
testLabel = label
, testTargets = targets
, testResult = result
, testIndepGoals = False
, testDb = db
mkTest = mkTestExtLang [] []

mkTestExts :: [Extension]
-> ExampleDb
-> String
-> [String]
-> Maybe [(String, Int)]
-> SolverTest
mkTestExts exts = mkTestExtLang exts []

mkTestLangs :: [Language]
-> ExampleDb
-> String
-> [String]
-> Maybe [(String, Int)]
-> SolverTest
mkTestLangs = mkTestExtLang []

mkTestExtLang :: [Extension]
-> [Language]
-> ExampleDb
-> String
-> [String]
-> Maybe [(String, Int)]
-> SolverTest
mkTestExtLang exts langs db label targets result = SolverTest {
testLabel = label
, testTargets = targets
, testResult = result
, testIndepGoals = False
, testDb = db
, testSupportedExts = exts
, testSupportedLangs = langs
}

runTest :: SolverTest -> TF.TestTree
runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
testCase testLabel $ do
let (_msgs, result) = exResolve testDb testTargets testIndepGoals
let (_msgs, result) = exResolve testDb testSupportedExts testSupportedLangs testTargets testIndepGoals
when showSolverLog $ mapM_ putStrLn _msgs
case result of
Left err -> assertBool ("Unexpected error:\n" ++ err) (isNothing testResult)
Expand Down Expand Up @@ -340,6 +387,23 @@ db12 =
, Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2]
]

dbExts1 :: ExampleDb
dbExts1 = [
Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)]
, Right $ exAv "B" 1 [ExExt (EnableExtension CPP), ExAny "A"]
, Right $ exAv "C" 1 [ExAny "B"]
, Right $ exAv "D" 1 [ExExt (DisableExtension CPP), ExAny "B"]
, Right $ exAv "E" 1 [ExExt (UnknownExtension "custom"), ExAny "C"]
]

dbLangs1 :: ExampleDb
dbLangs1 = [
Right $ exAv "A" 1 [ExLang Haskell2010]
, Right $ exAv "B" 1 [ExLang Haskell98, ExAny "A"]
, Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"]
]


{-------------------------------------------------------------------------------
Test options
-------------------------------------------------------------------------------}
Expand Down

0 comments on commit 594335b

Please sign in to comment.