Skip to content

Commit 266c5aa

Browse files
grayjaygrayjay
authored
Merge pull request #4028 from grayjay/buildable-solver-tests-2
Solver DSL improvements
2 parents d53f62c + cb6603a commit 266c5aa

File tree

3 files changed

+190
-139
lines changed

3 files changed

+190
-139
lines changed

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

Lines changed: 150 additions & 104 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE RecordWildCards #-}
22
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+
{-# LANGUAGE ScopedTypeVariables #-}
34
-- | DSL for testing the modular solver
45
module UnitTests.Distribution.Solver.Modular.DSL (
56
ExampleDependency(..)
@@ -29,25 +30,30 @@ module UnitTests.Distribution.Solver.Modular.DSL (
2930
, runProgress
3031
) where
3132

33+
import Prelude ()
34+
import Distribution.Client.Compat.Prelude
35+
3236
-- base
3337
import Data.Either (partitionEithers)
34-
import Data.Maybe (catMaybes, isNothing)
35-
import Data.List (elemIndex, nub)
36-
import Data.Monoid
38+
import Data.List (elemIndex)
3739
import Data.Ord (comparing)
3840
import qualified Data.Map as Map
3941

4042
-- Cabal
41-
import qualified Distribution.Compiler as C
42-
import qualified Distribution.InstalledPackageInfo as C
43-
import qualified Distribution.Package as C
43+
import qualified Distribution.Compiler as C
44+
import qualified Distribution.InstalledPackageInfo as IPI
45+
import Distribution.License (License(..))
46+
import qualified Distribution.ModuleName as Module
47+
import qualified Distribution.Package as C
4448
hiding (HasUnitId(..))
45-
import qualified Distribution.PackageDescription as C
46-
import qualified Distribution.Simple.PackageIndex as C.PackageIndex
49+
import qualified Distribution.PackageDescription as C
50+
import qualified Distribution.PackageDescription.Check as C
51+
import qualified Distribution.Simple.PackageIndex as C.PackageIndex
4752
import Distribution.Simple.Setup (BooleanFlag(..))
48-
import qualified Distribution.System as C
49-
import qualified Distribution.Version as C
50-
import Language.Haskell.Extension (Extension(..), Language)
53+
import qualified Distribution.System as C
54+
import Distribution.Text (display)
55+
import qualified Distribution.Version as C
56+
import Language.Haskell.Extension (Extension(..), Language(..))
5157

5258
-- cabal-install
5359
import Distribution.Client.Dependency
@@ -246,59 +252,103 @@ type ExampleDb = [Either ExampleInstalled ExampleAvailable]
246252

247253
type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a
248254

255+
type DependencyComponent a = ( C.Condition C.ConfVar
256+
, DependencyTree a
257+
, Maybe (DependencyTree a))
258+
249259
exDbPkgs :: ExampleDb -> [ExamplePkgName]
250260
exDbPkgs = map (either exInstName exAvName)
251261

252262
exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage
253263
exAvSrcPkg ex =
254-
let (libraryDeps, exts, mlang, pcpkgs, exes) = splitTopLevel (CD.libraryDeps (exAvDeps ex))
264+
let pkgId = exAvPkgId ex
255265
testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)]
256266
executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)]
257-
in SourcePackage {
258-
packageInfoId = exAvPkgId ex
259-
, packageSource = LocalTarballPackage "<<path>>"
260-
, packageDescrOverride = Nothing
261-
, packageDescription = C.GenericPackageDescription {
262-
C.packageDescription = C.emptyPackageDescription {
263-
C.package = exAvPkgId ex
264-
, C.library = error "not yet configured: library"
265-
, C.subLibraries = error "not yet configured: subLibraries"
266-
, C.executables = error "not yet configured: executables"
267-
, C.testSuites = error "not yet configured: testSuites"
268-
, C.benchmarks = error "not yet configured: benchmarks"
269-
, C.buildDepends = error "not yet configured: buildDepends"
270-
, C.setupBuildInfo = Just C.SetupBuildInfo {
271-
C.setupDepends = mkSetupDeps (CD.setupDeps (exAvDeps ex)),
272-
C.defaultSetupDepends = False
273-
}
274-
}
275-
, C.genPackageFlags = nub $ concatMap extractFlags $
276-
CD.libraryDeps (exAvDeps ex)
277-
++ concatMap snd testSuites
278-
++ concatMap snd executables
279-
, C.condLibrary = Just (mkCondTree
280-
(extsLib exts <> langLib mlang <> pcpkgLib pcpkgs <> buildtoolsLib exes)
281-
disableLib
282-
(Buildable libraryDeps))
283-
, C.condSubLibraries = []
284-
, C.condExecutables =
285-
let mkTree = mkCondTree mempty disableExe . Buildable
286-
in map (\(t, deps) -> (t, mkTree deps)) executables
287-
, C.condTestSuites =
288-
let mkTree = mkCondTree mempty disableTest . Buildable
289-
in map (\(t, deps) -> (t, mkTree deps)) testSuites
290-
, C.condBenchmarks = []
291-
}
292-
}
267+
setup = case CD.setupDeps (exAvDeps ex) of
268+
[] -> Nothing
269+
deps -> Just C.SetupBuildInfo {
270+
C.setupDepends = mkSetupDeps deps,
271+
C.defaultSetupDepends = False
272+
}
273+
package = SourcePackage {
274+
packageInfoId = pkgId
275+
, packageSource = LocalTarballPackage "<<path>>"
276+
, packageDescrOverride = Nothing
277+
, packageDescription = C.GenericPackageDescription {
278+
C.packageDescription = C.emptyPackageDescription {
279+
C.package = pkgId
280+
, C.library = error "not yet configured: library"
281+
, C.subLibraries = error "not yet configured: subLibraries"
282+
, C.executables = error "not yet configured: executables"
283+
, C.testSuites = error "not yet configured: testSuites"
284+
, C.benchmarks = error "not yet configured: benchmarks"
285+
, C.buildDepends = error "not yet configured: buildDepends"
286+
, C.setupBuildInfo = setup
287+
, C.license = BSD3
288+
, C.buildType = if isNothing setup
289+
then Just C.Simple
290+
else Just C.Custom
291+
, C.category = "category"
292+
, C.maintainer = "maintainer"
293+
, C.description = "description"
294+
, C.synopsis = "synopsis"
295+
, C.licenseFiles = ["LICENSE"]
296+
, C.specVersionRaw = Left $ C.mkVersion [1,12]
297+
}
298+
, C.genPackageFlags = nub $ concatMap extractFlags $
299+
CD.libraryDeps (exAvDeps ex)
300+
++ concatMap snd testSuites
301+
++ concatMap snd executables
302+
, C.condLibrary =
303+
let mkLib bi = mempty { C.libBuildInfo = bi }
304+
in Just $ mkCondTree defaultLib mkLib $ mkBuildInfoTree $
305+
Buildable (CD.libraryDeps (exAvDeps ex))
306+
, C.condSubLibraries = []
307+
, C.condExecutables =
308+
let mkTree = mkCondTree defaultExe mkExe . mkBuildInfoTree . Buildable
309+
mkExe bi = mempty { C.buildInfo = bi }
310+
in map (\(t, deps) -> (t, mkTree deps)) executables
311+
, C.condTestSuites =
312+
let mkTree = mkCondTree defaultTest mkTest . mkBuildInfoTree . Buildable
313+
mkTest bi = mempty { C.testBuildInfo = bi }
314+
in map (\(t, deps) -> (t, mkTree deps)) testSuites
315+
, C.condBenchmarks = []
316+
}
317+
}
318+
pkgCheckErrors =
319+
-- We ignore these warnings because some unit tests test that the
320+
-- solver allows unknown extensions/languages when the compiler
321+
-- supports them.
322+
let ignore = ["Unknown extensions:", "Unknown languages:"]
323+
in [ err | err <- C.checkPackage (packageDescription package) Nothing
324+
, not $ any (`isPrefixOf` C.explanation err) ignore ]
325+
in if null pkgCheckErrors
326+
then package
327+
else error $ "invalid GenericPackageDescription for package "
328+
++ display pkgId ++ ": " ++ show pkgCheckErrors
293329
where
330+
defaultTopLevelBuildInfo :: C.BuildInfo
331+
defaultTopLevelBuildInfo = mempty { C.defaultLanguage = Just Haskell98 }
332+
333+
defaultLib :: C.Library
334+
defaultLib = mempty { C.exposedModules = [Module.fromString "Module"] }
335+
336+
defaultExe :: C.Executable
337+
defaultExe = mempty { C.modulePath = "Main.hs" }
338+
339+
defaultTest :: C.TestSuite
340+
defaultTest = mempty {
341+
C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1,0]) "Test.hs"
342+
}
343+
294344
-- Split the set of dependencies into the set of dependencies of the library,
295345
-- the dependencies of the test suites and extensions.
296346
splitTopLevel :: [ExampleDependency]
297347
-> ( [ExampleDependency]
298348
, [Extension]
299349
, Maybe Language
300350
, [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config
301-
, [(ExamplePkgName, Maybe Int)]
351+
, [(ExamplePkgName, Maybe Int)] -- build tools
302352
)
303353
splitTopLevel [] =
304354
([], [], Nothing, [], [])
@@ -343,22 +393,52 @@ exAvSrcPkg ex =
343393
extractFlags (ExLang _) = []
344394
extractFlags (ExPkg _) = []
345395

346-
mkCondTree :: Monoid a => a -> (a -> a) -> Dependencies -> DependencyTree a
347-
mkCondTree x dontBuild NotBuildable =
396+
-- Convert a tree of BuildInfos into a tree of a specific component type.
397+
-- 'defaultTopLevel' contains the default values for the component, and
398+
-- 'mkComponent' creates a component from a 'BuildInfo'.
399+
mkCondTree :: forall a. Semigroup a =>
400+
a -> (C.BuildInfo -> a)
401+
-> DependencyTree C.BuildInfo
402+
-> DependencyTree a
403+
mkCondTree defaultTopLevel mkComponent (C.CondNode topData topConstraints topComps) =
404+
C.CondNode {
405+
C.condTreeData =
406+
defaultTopLevel <> mkComponent (defaultTopLevelBuildInfo <> topData)
407+
, C.condTreeConstraints = topConstraints
408+
, C.condTreeComponents = goComponents topComps
409+
}
410+
where
411+
go :: DependencyTree C.BuildInfo -> DependencyTree a
412+
go (C.CondNode ctData constraints comps) =
413+
C.CondNode (mkComponent ctData) constraints (goComponents comps)
414+
415+
goComponents :: [DependencyComponent C.BuildInfo]
416+
-> [DependencyComponent a]
417+
goComponents comps = [(cond, go t, go <$> me) | (cond, t, me) <- comps]
418+
419+
mkBuildInfoTree :: Dependencies -> DependencyTree C.BuildInfo
420+
mkBuildInfoTree NotBuildable =
348421
C.CondNode {
349-
C.condTreeData = dontBuild x
422+
C.condTreeData = mempty { C.buildable = False }
350423
, C.condTreeConstraints = []
351424
, C.condTreeComponents = []
352425
}
353-
mkCondTree x dontBuild (Buildable deps) =
354-
let (directDeps, flaggedDeps) = splitDeps deps
426+
mkBuildInfoTree (Buildable deps) =
427+
let (libraryDeps, exts, mlang, pcpkgs, buildTools) = splitTopLevel deps
428+
(directDeps, flaggedDeps) = splitDeps libraryDeps
429+
bi = mempty {
430+
C.otherExtensions = exts
431+
, C.defaultLanguage = mlang
432+
, C.buildTools = map mkDirect buildTools
433+
, C.pkgconfigDepends = [mkDirect (n, (Just v)) | (n,v) <- pcpkgs]
434+
}
355435
in C.CondNode {
356-
C.condTreeData = x -- Necessary for language extensions
436+
C.condTreeData = bi -- Necessary for language extensions
357437
-- TODO: Arguably, build-tools dependencies should also
358438
-- effect constraints on conditional tree. But no way to
359439
-- distinguish between them
360440
, C.condTreeConstraints = map mkDirect directDeps
361-
, C.condTreeComponents = map (mkFlagged dontBuild) flaggedDeps
441+
, C.condTreeComponents = map mkFlagged flaggedDeps
362442
}
363443

364444
mkDirect :: (ExamplePkgName, Maybe ExamplePkgVersion) -> C.Dependency
@@ -367,23 +447,20 @@ exAvSrcPkg ex =
367447
where
368448
v = C.mkVersion [n, 0, 0]
369449

370-
mkFlagged :: Monoid a
371-
=> (a -> a)
372-
-> (ExampleFlagName, Dependencies, Dependencies)
373-
-> (C.Condition C.ConfVar
374-
, DependencyTree a, Maybe (DependencyTree a))
375-
mkFlagged dontBuild (f, a, b) = ( C.Var (C.Flag (C.FlagName f))
376-
, mkCondTree mempty dontBuild a
377-
, Just (mkCondTree mempty dontBuild b)
450+
mkFlagged :: (ExampleFlagName, Dependencies, Dependencies)
451+
-> ( C.Condition C.ConfVar
452+
, DependencyTree C.BuildInfo
453+
, Maybe (DependencyTree C.BuildInfo))
454+
mkFlagged (f, a, b) = ( C.Var (C.Flag (C.FlagName f))
455+
, mkBuildInfoTree a
456+
, Just (mkBuildInfoTree b)
378457
)
379458

380459
-- Split a set of dependencies into direct dependencies and flagged
381460
-- dependencies. A direct dependency is a tuple of the name of package and
382461
-- maybe its version (no version means any version) meant to be converted
383462
-- to a 'C.Dependency' with 'mkDirect' for example. A flagged dependency is
384463
-- the set of dependencies guarded by a flag.
385-
--
386-
-- TODO: Take care of flagged language extensions and language flavours.
387464
splitDeps :: [ExampleDependency]
388465
-> ( [(ExamplePkgName, Maybe Int)]
389466
, [(ExampleFlagName, Dependencies, Dependencies)]
@@ -399,55 +476,24 @@ exAvSrcPkg ex =
399476
splitDeps (ExFlag f a b:deps) =
400477
let (directDeps, flaggedDeps) = splitDeps deps
401478
in (directDeps, (f, a, b):flaggedDeps)
402-
splitDeps (_:deps) = splitDeps deps
479+
splitDeps (dep:_) = error $ "Unexpected dependency: " ++ show dep
403480

404-
-- Currently we only support simple setup dependencies
481+
-- custom-setup only supports simple dependencies
405482
mkSetupDeps :: [ExampleDependency] -> [C.Dependency]
406483
mkSetupDeps deps =
407484
let (directDeps, []) = splitDeps deps in map mkDirect directDeps
408485

409-
-- A 'C.Library' with just the given extensions in its 'BuildInfo'
410-
extsLib :: [Extension] -> C.Library
411-
extsLib es = mempty { C.libBuildInfo = mempty { C.otherExtensions = es } }
412-
413-
-- A 'C.Library' with just the given extensions in its 'BuildInfo'
414-
langLib :: Maybe Language -> C.Library
415-
langLib (Just lang) = mempty { C.libBuildInfo = mempty { C.defaultLanguage = Just lang } }
416-
langLib _ = mempty
417-
418-
disableLib :: C.Library -> C.Library
419-
disableLib lib =
420-
lib { C.libBuildInfo = (C.libBuildInfo lib) { C.buildable = False }}
421-
422-
disableTest :: C.TestSuite -> C.TestSuite
423-
disableTest test =
424-
test { C.testBuildInfo = (C.testBuildInfo test) { C.buildable = False }}
425-
426-
disableExe :: C.Executable -> C.Executable
427-
disableExe exe =
428-
exe { C.buildInfo = (C.buildInfo exe) { C.buildable = False }}
429-
430-
-- A 'C.Library' with just the given pkgconfig-depends in its 'BuildInfo'
431-
pcpkgLib :: [(ExamplePkgName, ExamplePkgVersion)] -> C.Library
432-
pcpkgLib ds = mempty { C.libBuildInfo = mempty { C.pkgconfigDepends = [mkDirect (n, (Just v)) | (n,v) <- ds] } }
433-
434-
buildtoolsLib :: [(ExamplePkgName, Maybe Int)] -> C.Library
435-
buildtoolsLib ds = mempty { C.libBuildInfo = mempty {
436-
C.buildTools = map mkDirect ds
437-
} }
438-
439-
440486
exAvPkgId :: ExampleAvailable -> C.PackageIdentifier
441487
exAvPkgId ex = C.PackageIdentifier {
442488
pkgName = C.mkPackageName (exAvName ex)
443489
, pkgVersion = C.mkVersion [exAvVersion ex, 0, 0]
444490
}
445491

446-
exInstInfo :: ExampleInstalled -> C.InstalledPackageInfo
447-
exInstInfo ex = C.emptyInstalledPackageInfo {
448-
C.installedUnitId = C.mkUnitId (exInstHash ex)
449-
, C.sourcePackageId = exInstPkgId ex
450-
, C.depends = map C.mkUnitId (exInstBuildAgainst ex)
492+
exInstInfo :: ExampleInstalled -> IPI.InstalledPackageInfo
493+
exInstInfo ex = IPI.emptyInstalledPackageInfo {
494+
IPI.installedUnitId = C.mkUnitId (exInstHash ex)
495+
, IPI.sourcePackageId = exInstPkgId ex
496+
, IPI.depends = map C.mkUnitId (exInstBuildAgainst ex)
451497
}
452498

453499
exInstPkgId :: ExampleInstalled -> C.PackageIdentifier

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

Lines changed: 13 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -258,16 +258,18 @@ arbitraryExDep db@(TestDb pkgs) level =
258258
let flag = ExFlag <$> arbitraryFlagName
259259
<*> arbitraryDeps db
260260
<*> arbitraryDeps db
261-
other = [
262-
ExAny . unPN <$> elements (map getName pkgs)
263-
264-
-- existing version
265-
, let fixed pkg = ExFix (unPN $ getName pkg) (unPV $ getVersion pkg)
266-
in fixed <$> elements pkgs
267-
268-
-- random version of an existing package
269-
, ExFix . unPN . getName <$> elements pkgs <*> (unPV <$> arbitrary)
270-
]
261+
other =
262+
-- Package checks require dependencies on "base" to have bounds.
263+
let notBase = filter ((/= PN "base") . getName) pkgs
264+
in [ExAny . unPN <$> elements (map getName notBase) | not (null notBase)]
265+
++ [
266+
-- existing version
267+
let fixed pkg = ExFix (unPN $ getName pkg) (unPV $ getVersion pkg)
268+
in fixed <$> elements pkgs
269+
270+
-- random version of an existing package
271+
, ExFix . unPN . getName <$> elements pkgs <*> (unPV <$> arbitrary)
272+
]
271273
in oneof $
272274
case level of
273275
NonSetupDep -> flag : other
@@ -332,6 +334,7 @@ instance Arbitrary ExampleDependency where
332334
arbitrary = error "arbitrary not implemented: ExampleDependency"
333335

334336
shrink (ExAny _) = []
337+
shrink (ExFix "base" _) = [] -- preserve bounds on base
335338
shrink (ExFix pn _) = [ExAny pn]
336339
shrink (ExFlag flag th el) =
337340
deps th ++ deps el

0 commit comments

Comments
 (0)