From 8118c36a1bad7c77bbe758cdcf193fcc302620cd Mon Sep 17 00:00:00 2001 From: Kristen Kozak Date: Sun, 12 May 2019 19:26:23 -0700 Subject: [PATCH] Solver DSL: Support sub-libraries and library visibility field. --- .../Distribution/Solver/Modular/DSL.hs | 56 +++++++++++++++---- .../Distribution/Solver/Modular/QuickCheck.hs | 12 +++- 2 files changed, 57 insertions(+), 11 deletions(-) diff --git a/cabal-install/solver-dsl/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/solver-dsl/UnitTests/Distribution/Solver/Modular/DSL.hs index b19c8ea3e66..5389d1e5038 100644 --- a/cabal-install/solver-dsl/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/solver-dsl/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -5,6 +5,7 @@ module UnitTests.Distribution.Solver.Modular.DSL ( ExampleDependency(..) , Dependencies(..) + , ExSubLib(..) , ExTest(..) , ExExe(..) , ExConstraint(..) @@ -29,6 +30,8 @@ module UnitTests.Distribution.Solver.Modular.DSL ( , exResolve , extractInstallPlan , declareFlags + , withSubLibrary + , withSubLibraries , withSetupDeps , withTest , withTests @@ -139,6 +142,7 @@ type ExamplePkgName = String type ExamplePkgVersion = Int type ExamplePkgHash = String -- for example "installed" packages type ExampleFlagName = String +type ExampleSubLibName = String type ExampleTestName = String type ExampleExeName = String type ExampleVersionRange = C.VersionRange @@ -157,6 +161,12 @@ data ExampleDependency = -- and an exclusive upper bound. | ExRange ExamplePkgName ExamplePkgVersion ExamplePkgVersion + -- | Sub-library dependency + | ExSubLibAny ExamplePkgName ExampleSubLibName + + -- | Sub-library dependency on a fixed version + | ExSubLibFix ExamplePkgName ExampleSubLibName ExamplePkgVersion + -- | Build-tool-depends dependency | ExBuildToolAny ExamplePkgName ExampleExeName @@ -190,6 +200,8 @@ data ExFlag = ExFlag { , exFlagType :: FlagType } deriving Show +data ExSubLib = ExSubLib ExampleSubLibName C.LibraryVisibility [ExampleDependency] + data ExTest = ExTest ExampleTestName [ExampleDependency] data ExExe = ExExe ExampleExeName [ExampleDependency] @@ -221,7 +233,7 @@ data ExampleAvailable = ExAv { data ExampleComponents a = ExampleComponents { exLib :: Maybe a - , exSubLibs :: [(C.UnqualComponentName, a)] + , exSubLibs :: [(C.UnqualComponentName, C.LibraryVisibility, a)] , exFLibs :: [(C.UnqualComponentName, a)] , exExes :: [(C.UnqualComponentName, a)] , exTests :: [(C.UnqualComponentName, a)] @@ -243,8 +255,9 @@ defaultExampleComponents = ExampleComponents { flatDeps :: ExampleComponents [a] -> [a] flatDeps components = concat $ maybeToList (exLib components) + ++ [ deps | (_, _, deps) <- exSubLibs components] ++ [ concatMap snd (f components) - | f <- [exSubLibs, exFLibs, exExes, exTests, exBenchmarks] ] + | f <- [exFLibs, exExes, exTests, exBenchmarks] ] ++ maybeToList (exSetup components) data ExampleVar = @@ -298,6 +311,17 @@ declareFlags flags ex = ex { exAvFlags = flags } +withSubLibrary :: ExampleAvailable -> ExSubLib -> ExampleAvailable +withSubLibrary ex lib = withSubLibraries ex [lib] + +withSubLibraries :: ExampleAvailable -> [ExSubLib] -> ExampleAvailable +withSubLibraries ex libs = + let allLibs = + exSubLibs (exAvDeps ex) + ++ [(C.mkUnqualComponentName name, visibility, deps) + | ExSubLib name visibility deps <- libs] + in ex { exAvDeps = (exAvDeps ex) { exSubLibs = allLibs } } + withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable withSetupDeps ex setupDeps = ex { exAvDeps = (exAvDeps ex) { exSetup = Just setupDeps } @@ -408,9 +432,12 @@ exAvSrcPkg ex = libDeps = exLib (exAvDeps ex) in mkCondTree defaultLib mkLib . mkBuildInfoTree . Buildable <$> libDeps , C.condSubLibraries = - let mkTree = mkCondTree defaultLib mkLib . mkBuildInfoTree . Buildable + let mkTree visibility deps = + let tree = mkCondTree defaultLib mkLib . mkBuildInfoTree $ Buildable deps + in tree { C.condTreeData = (C.condTreeData tree) {C.libVisibility = visibility} } mkLib bi = mempty { C.libBuildInfo = bi } - in map (second mkTree) $ exSubLibs (exAvDeps ex) + in map (\(name, visibility, deps) -> (name, mkTree visibility deps)) $ + exSubLibs (exAvDeps ex) , C.condForeignLibs = let mkTree = mkCondTree mempty mkLib . mkBuildInfoTree . Buildable mkLib bi = mempty { C.foreignLibBuildInfo = bi } @@ -504,6 +531,8 @@ exAvSrcPkg ex = extractFlags (ExAny _) = [] extractFlags (ExFix _ _) = [] extractFlags (ExRange _ _ _) = [] + extractFlags (ExSubLibAny _ _) = [] + extractFlags (ExSubLibFix _ _ _) = [] extractFlags (ExBuildToolAny _ _) = [] extractFlags (ExBuildToolFix _ _ _) = [] extractFlags (ExLegacyBuildToolAny _) = [] @@ -572,8 +601,8 @@ exAvSrcPkg ex = , C.condTreeComponents = map mkFlagged flaggedDeps } - mkDirect :: (ExamplePkgName, C.VersionRange) -> C.Dependency - mkDirect (dep, vr) = C.Dependency (C.mkPackageName dep) vr (Set.singleton C.LMainLibName) + mkDirect :: (ExamplePkgName, C.LibraryName, C.VersionRange) -> C.Dependency + mkDirect (dep, name, vr) = C.Dependency (C.mkPackageName dep) vr (Set.singleton name) mkFlagged :: (ExampleFlagName, Dependencies, Dependencies) -> DependencyComponent C.BuildInfo @@ -588,20 +617,27 @@ exAvSrcPkg ex = -- 'mkDirect' for example. A flagged dependency is the set of dependencies -- guarded by a flag. splitDeps :: [ExampleDependency] - -> ( [(ExamplePkgName, C.VersionRange)] + -> ( [(ExamplePkgName, C.LibraryName, C.VersionRange)] , [(ExampleFlagName, Dependencies, Dependencies)] ) splitDeps [] = ([], []) splitDeps (ExAny p:deps) = let (directDeps, flaggedDeps) = splitDeps deps - in ((p, C.anyVersion):directDeps, flaggedDeps) + in ((p, C.LMainLibName, C.anyVersion):directDeps, flaggedDeps) splitDeps (ExFix p v:deps) = let (directDeps, flaggedDeps) = splitDeps deps - in ((p, C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps) + in ((p, C.LMainLibName, C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps) splitDeps (ExRange p v1 v2:deps) = let (directDeps, flaggedDeps) = splitDeps deps - in ((p, mkVersionRange v1 v2):directDeps, flaggedDeps) + in ((p, C.LMainLibName, mkVersionRange v1 v2):directDeps, flaggedDeps) + splitDeps (ExSubLibAny p lib:deps) = + let (directDeps, flaggedDeps) = splitDeps deps + in ((p, C.LSubLibName (C.mkUnqualComponentName lib), C.anyVersion):directDeps, flaggedDeps) + splitDeps (ExSubLibFix p lib v:deps) = + let (directDeps, flaggedDeps) = splitDeps deps + in ( (p, C.LSubLibName (C.mkUnqualComponentName lib), C.thisVersion $ mkSimpleVersion v):directDeps + , flaggedDeps) splitDeps (ExFlagged f a b:deps) = let (directDeps, flaggedDeps) = splitDeps deps in (directDeps, (f, a, b):flaggedDeps) diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index db4a934482c..d825400cb32 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -26,6 +26,7 @@ import Distribution.Utils.ShortText (ShortText) import Distribution.Client.Setup (defaultMaxBackjumps) +import Distribution.Types.LibraryVisibility import Distribution.Types.PackageName import Distribution.Types.UnqualComponentName @@ -292,7 +293,10 @@ arbitraryExampleComponents pn db = do toExampleComponents :: [(Component, a)] -> ExampleComponents a toExampleComponents comps = ExampleComponents { exLib = listToMaybe [deps | (ComponentLib, deps) <- comps] - , exSubLibs = [(name, deps) | (ComponentSubLib name, deps) <- comps] + + -- TODO: Handle private libraries. + , exSubLibs = [(name, LibraryVisibilityPublic, deps) | (ComponentSubLib name, deps) <- comps] + , exFLibs = [(name, deps) | (ComponentFLib name, deps) <- comps] , exExes = [(name, deps) | (ComponentExe name, deps) <- comps] , exTests = [(name, deps) | (ComponentTest name, deps) <- comps] @@ -460,6 +464,12 @@ instance (Arbitrary a, Monoid a) => Arbitrary (ExampleComponents a) where , exBenchmarks comps , exSetup comps) ] +instance Arbitrary LibraryVisibility where + arbitrary = elements [LibraryVisibilityPublic, LibraryVisibilityPrivate] + + shrink LibraryVisibilityPublic = [] + shrink LibraryVisibilityPrivate = [LibraryVisibilityPublic] + instance Arbitrary ExampleDependency where arbitrary = error "arbitrary not implemented: ExampleDependency"