Skip to content

Commit 4acce9e

Browse files
jdnavarrojdnavarro
committed
Add real tests for solving language flavours
This also includes modifications to the solver testing DSL and the testing functions. This is ready for review at PR haskell#2732.
1 parent 1ebb890 commit 4acce9e

File tree

2 files changed

+82
-34
lines changed
  • cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular

2 files changed

+82
-34
lines changed

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

Lines changed: 31 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -141,7 +141,7 @@ exDbPkgs = map (either exInstName exAvName)
141141

142142
exAvSrcPkg :: ExampleAvailable -> SourcePackage
143143
exAvSrcPkg ex =
144-
let (libraryDeps, testSuites, exts) = splitTopLevel (CD.libraryDeps (exAvDeps ex))
144+
let (libraryDeps, testSuites, exts, mlang) = splitTopLevel (CD.libraryDeps (exAvDeps ex))
145145
in SourcePackage {
146146
packageInfoId = exAvPkgId ex
147147
, packageSource = LocalTarballPackage "<<path>>"
@@ -160,7 +160,7 @@ exAvSrcPkg ex =
160160
}
161161
, C.genPackageFlags = concatMap extractFlags
162162
(CD.libraryDeps (exAvDeps ex))
163-
, C.condLibrary = Just $ mkCondTree (extsLib exts) libraryDeps
163+
, C.condLibrary = Just $ mkCondTree (extsLib exts <> langLib mlang) libraryDeps
164164
, C.condExecutables = []
165165
, C.condTestSuites = map (\(t, deps) -> (t, mkCondTree mempty deps))
166166
testSuites
@@ -174,17 +174,23 @@ exAvSrcPkg ex =
174174
-> ( [ExampleDependency]
175175
, [(ExampleTestName, [ExampleDependency])]
176176
, [Extension]
177+
, Maybe Language
177178
)
178-
splitTopLevel [] = ([], [], [])
179+
splitTopLevel [] =
180+
([], [], [], Nothing)
179181
splitTopLevel (ExTest t a:deps) =
180-
let (other, testSuites, exts) = splitTopLevel deps
181-
in (other, (t, a):testSuites, exts)
182+
let (other, testSuites, exts, lang) = splitTopLevel deps
183+
in (other, (t, a):testSuites, exts, lang)
182184
splitTopLevel (ExExt ext:deps) =
183-
let (other, testSuites, exts) = splitTopLevel deps
184-
in (other, testSuites, ext:exts)
185-
splitTopLevel (dep:deps) =
186-
let (other, testSuites, exts) = splitTopLevel deps
187-
in (dep:other, testSuites, exts)
185+
let (other, testSuites, exts, lang) = splitTopLevel deps
186+
in (other, testSuites, ext:exts, lang)
187+
splitTopLevel (ExLang lang:deps) =
188+
case splitTopLevel deps of
189+
(other, testSuites, exts, Nothing) -> (other, testSuites, exts, Just lang)
190+
_ -> error "Only 1 Language dependency is supported"
191+
splitTopLevel (dep:deps) =
192+
let (other, testSuites, exts, lang) = splitTopLevel deps
193+
in (dep:other, testSuites, exts, lang)
188194

189195
-- Extract the total set of flags used
190196
extractFlags :: ExampleDependency -> [C.Flag]
@@ -231,7 +237,7 @@ exAvSrcPkg ex =
231237
-- to a 'C.Dependency' with 'mkDirect' for example. A flagged dependency is
232238
-- the set of dependencies guarded by a flag.
233239
--
234-
-- TODO: Take care of flagged language extensions
240+
-- TODO: Take care of flagged language extensions and language flavours.
235241
splitDeps :: [ExampleDependency]
236242
-> ( [(ExamplePkgName, Maybe Int)]
237243
, [(ExampleFlagName, [ExampleDependency], [ExampleDependency])]
@@ -260,6 +266,10 @@ exAvSrcPkg ex =
260266
extsLib :: [Extension] -> C.Library
261267
extsLib es = mempty { C.libBuildInfo = mempty { C.otherExtensions = es } }
262268

269+
-- A 'C.Library' with just the given extensions in its 'BuildInfo'
270+
langLib :: Maybe Language -> C.Library
271+
langLib (Just lang) = mempty { C.libBuildInfo = mempty { C.defaultLanguage = Just lang } }
272+
langLib _ = mempty
263273

264274
exAvPkgId :: ExampleAvailable -> C.PackageIdentifier
265275
exAvPkgId ex = C.PackageIdentifier {
@@ -290,19 +300,25 @@ exInstIdx = C.PackageIndex.fromList . map exInstInfo
290300
exResolve :: ExampleDb
291301
-- List of extensions supported by the compiler.
292302
-> [Extension]
303+
-- A compiler can support multiple languages.
304+
-> [Language]
293305
-> [ExamplePkgName]
294306
-> Bool
295307
-> ([String], Either String CI.InstallPlan.InstallPlan)
296-
exResolve db exts targets indepGoals = runProgress $
308+
exResolve db exts langs targets indepGoals = runProgress $
297309
resolveDependencies C.buildPlatform
298310
compiler
299311
Modular
300312
params
301313
where
302314
defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag
303-
compiler = if null exts
304-
then defaultCompiler
305-
else defaultCompiler { C.compilerInfoExtensions = Just exts }
315+
compiler = defaultCompiler { C.compilerInfoExtensions = if null exts
316+
then Nothing
317+
else Just exts
318+
, C.compilerInfoLanguages = if null langs
319+
then Nothing
320+
else Just langs
321+
}
306322
(inst, avai) = partitionEithers db
307323
instIdx = exInstIdx inst
308324
avaiIdx = SourcePackageDb {

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

Lines changed: 51 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,7 @@ import Test.Tasty.HUnit (testCase, assertEqual, assertBool)
1414
import Test.Tasty.Options
1515

1616
-- Cabal
17-
import Language.Haskell.Extension (Extension(..), KnownExtension(..))
17+
import Language.Haskell.Extension (Extension(..), KnownExtension(..), Language(..))
1818

1919
-- cabal-install
2020
import UnitTests.Distribution.Client.Dependency.Modular.DSL
@@ -72,12 +72,18 @@ tests = [
7272
]
7373
, testGroup "Extensions" [
7474
runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] Nothing
75-
, runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedTransitive" ["B"] Nothing
75+
, runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedIndirect" ["B"] Nothing
7676
, runTest $ mkTestExts [EnableExtension RankNTypes] dbExts1 "supported" ["A"] (Just [("A",1)])
77-
, runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedTransitive" ["C"] (Just [("A",1),("B",1), ("C",1)])
77+
, runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedIndirect" ["C"] (Just [("A",1),("B",1), ("C",1)])
7878
, runTest $ mkTestExts [EnableExtension CPP] dbExts1 "disabledExtension" ["D"] Nothing
7979
, runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "disabledExtension" ["D"] Nothing
80-
, runTest $ mkTestExts (UnknownExtension "custom" : map EnableExtension [CPP,RankNTypes]) dbExts1 "unknownExtension" ["E"] (Just [("A",1),("B",1),("C",1),("E",1)])
80+
, runTest $ mkTestExts (UnknownExtension "custom" : map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedUnknown" ["E"] (Just [("A",1),("B",1),("C",1),("E",1)])
81+
]
82+
, testGroup "Languages" [
83+
runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupported" ["A"] Nothing
84+
, runTest $ mkTestLangs [Haskell98,Haskell2010] dbLangs1 "supported" ["A"] (Just [("A",1)])
85+
, runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] Nothing
86+
, runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (Just [("A",1),("B",1),("C",1)])
8187
]
8288
]
8389
where
@@ -88,40 +94,59 @@ tests = [
8894
-------------------------------------------------------------------------------}
8995

9096
data SolverTest = SolverTest {
91-
testLabel :: String
92-
, testTargets :: [String]
93-
, testResult :: Maybe [(String, Int)]
94-
, testIndepGoals :: Bool
95-
, testDb :: ExampleDb
96-
, testSupportedExts :: [Extension]
97+
testLabel :: String
98+
, testTargets :: [String]
99+
, testResult :: Maybe [(String, Int)]
100+
, testIndepGoals :: Bool
101+
, testDb :: ExampleDb
102+
, testSupportedExts :: [Extension]
103+
, testSupportedLangs :: [Language]
97104
}
98105

99106
mkTest :: ExampleDb
100107
-> String
101108
-> [String]
102109
-> Maybe [(String, Int)]
103110
-> SolverTest
104-
mkTest = mkTestExts []
111+
mkTest = mkTestExtLang [] []
105112

106113
mkTestExts :: [Extension]
107114
-> ExampleDb
108115
-> String
109116
-> [String]
110117
-> Maybe [(String, Int)]
111118
-> SolverTest
112-
mkTestExts exts db label targets result = SolverTest {
113-
testLabel = label
114-
, testTargets = targets
115-
, testResult = result
116-
, testIndepGoals = False
117-
, testDb = db
118-
, testSupportedExts = exts
119+
mkTestExts exts = mkTestExtLang exts []
120+
121+
mkTestLangs :: [Language]
122+
-> ExampleDb
123+
-> String
124+
-> [String]
125+
-> Maybe [(String, Int)]
126+
-> SolverTest
127+
mkTestLangs = mkTestExtLang []
128+
129+
mkTestExtLang :: [Extension]
130+
-> [Language]
131+
-> ExampleDb
132+
-> String
133+
-> [String]
134+
-> Maybe [(String, Int)]
135+
-> SolverTest
136+
mkTestExtLang exts langs db label targets result = SolverTest {
137+
testLabel = label
138+
, testTargets = targets
139+
, testResult = result
140+
, testIndepGoals = False
141+
, testDb = db
142+
, testSupportedExts = exts
143+
, testSupportedLangs = langs
119144
}
120145

121146
runTest :: SolverTest -> TF.TestTree
122147
runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
123148
testCase testLabel $ do
124-
let (_msgs, result) = exResolve testDb testSupportedExts testTargets testIndepGoals
149+
let (_msgs, result) = exResolve testDb testSupportedExts testSupportedLangs testTargets testIndepGoals
125150
when showSolverLog $ mapM_ putStrLn _msgs
126151
case result of
127152
Left err -> assertBool ("Unexpected error:\n" ++ err) (isNothing testResult)
@@ -371,6 +396,13 @@ dbExts1 = [
371396
, Right $ exAv "E" 1 [ExExt (UnknownExtension "custom"), ExAny "C"]
372397
]
373398

399+
dbLangs1 :: ExampleDb
400+
dbLangs1 = [
401+
Right $ exAv "A" 1 [ExLang Haskell2010]
402+
, Right $ exAv "B" 1 [ExLang Haskell98, ExAny "A"]
403+
, Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"]
404+
]
405+
374406

375407
{-------------------------------------------------------------------------------
376408
Test options

0 commit comments

Comments
 (0)