diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 62c5ac63e45..9eef7f206c6 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -341,6 +341,7 @@ test-suite unit-tests UnitTests.Distribution.Client.Glob UnitTests.Distribution.Client.GZipUtils UnitTests.Distribution.Client.IndexUtils + UnitTests.Distribution.Client.IndexUtils.ActiveRepos UnitTests.Distribution.Client.IndexUtils.Timestamp UnitTests.Distribution.Client.Init UnitTests.Distribution.Client.Init.Golden diff --git a/cabal-install/src/Distribution/Client/IndexUtils.hs b/cabal-install/src/Distribution/Client/IndexUtils.hs index 8872ad6467f..d5539b41edd 100644 --- a/cabal-install/src/Distribution/Client/IndexUtils.hs +++ b/cabal-install/src/Distribution/Client/IndexUtils.hs @@ -29,6 +29,7 @@ module Distribution.Client.IndexUtils , getSourcePackagesAtIndexState , ActiveRepos , filterSkippedActiveRepos + , applyStrategy , Index (..) , RepoIndexState (..) , PackageEntry (..) @@ -372,16 +373,8 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do ts /= NoTimestamp ] - let addIndex - :: PackageIndex UnresolvedSourcePackage - -> (RepoData, CombineStrategy) - -> PackageIndex UnresolvedSourcePackage - addIndex acc (RepoData _ _ _ _, CombineStrategySkip) = acc - addIndex acc (RepoData _ _ idx _, CombineStrategyMerge) = PackageIndex.merge acc idx - addIndex acc (RepoData _ _ idx _, CombineStrategyOverride) = PackageIndex.override acc idx - let pkgs :: PackageIndex UnresolvedSourcePackage - pkgs = foldl' addIndex mempty pkgss' + pkgs = foldl' (\acc (rd, s) -> applyStrategy acc (rdIndex rd, s)) mempty pkgss' -- Note: preferences combined without using CombineStrategy let prefs :: Map PackageName VersionRange @@ -413,6 +406,19 @@ data RepoData = RepoData , rdPreferences :: [Dependency] } +-- | Fold one package index into an accumulator according to a 'CombineStrategy'. +-- +-- This is the per-repository step used by 'getSourcePackagesAtIndexState' when +-- building the combined 'PackageIndex' from multiple repositories. +applyStrategy + :: Package pkg + => PackageIndex pkg + -> (PackageIndex pkg, CombineStrategy) + -> PackageIndex pkg +applyStrategy acc (_, CombineStrategySkip) = acc +applyStrategy acc (idx, CombineStrategyMerge) = PackageIndex.merge acc idx +applyStrategy acc (idx, CombineStrategyOverride) = PackageIndex.override acc idx + -- | Read a repository index from disk, from the local file specified by -- the 'Repo'. -- diff --git a/cabal-install/tests/UnitTests.hs b/cabal-install/tests/UnitTests.hs index 8434f623e82..0020c695d12 100644 --- a/cabal-install/tests/UnitTests.hs +++ b/cabal-install/tests/UnitTests.hs @@ -9,6 +9,7 @@ import qualified UnitTests.Distribution.Client.GZipUtils import qualified UnitTests.Distribution.Client.Get import qualified UnitTests.Distribution.Client.Glob import qualified UnitTests.Distribution.Client.IndexUtils +import qualified UnitTests.Distribution.Client.IndexUtils.ActiveRepos import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp import qualified UnitTests.Distribution.Client.Init import qualified UnitTests.Distribution.Client.InstallPlan @@ -52,6 +53,9 @@ main = do , testGroup "UnitTests.Distribution.Client.IndexUtils" UnitTests.Distribution.Client.IndexUtils.tests + , testGroup + "UnitTests.Distribution.Client.IndexUtils.ActiveRepos" + UnitTests.Distribution.Client.IndexUtils.ActiveRepos.tests , testGroup "UnitTests.Distribution.Client.IndexUtils.Timestamp" UnitTests.Distribution.Client.IndexUtils.Timestamp.tests diff --git a/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs b/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs index fbd5952019a..a4a69870588 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs @@ -1,21 +1,29 @@ module UnitTests.Distribution.Client.IndexUtils where import Distribution.Client.IndexUtils +import Distribution.Client.IndexUtils.ActiveRepos import qualified Distribution.Compat.NonEmptySet as NES +import Distribution.Package import Distribution.Simple.Utils (toUTF8LBS) -import Distribution.Types.Dependency +import qualified Distribution.Solver.Types.PackageIndex as PackageIndex import Distribution.Types.LibraryName -import Distribution.Types.PackageName import Distribution.Version +import qualified Data.List as List + import Test.Tasty import Test.Tasty.HUnit tests :: [TestTree] tests = [ simpleVersionsParserTests + , indexCombiningTests ] +-- --------------------------------------------------------------------------- +-- Preferred-versions parser tests +-- --------------------------------------------------------------------------- + simpleVersionsParserTests :: TestTree simpleVersionsParserTests = testGroup @@ -80,3 +88,108 @@ simpleVersionsParserTests = ] , preferredVersionsOriginalDependency = "binary 0.9.0.0 || > 0.9.0.0" } + +-- --------------------------------------------------------------------------- +-- Index-combining tests +-- +-- These test 'applyStrategy' (exported from IndexUtils), which is the +-- per-repository step used by getSourcePackagesAtIndexState: +-- +-- applyStrategy acc (_, Skip) = acc +-- applyStrategy acc (idx, Merge) = PackageIndex.merge acc idx +-- applyStrategy acc (idx, Override) = PackageIndex.override acc idx +-- pkgs = foldl' (\acc (rd, s) -> applyStrategy acc (rdIndex rd, s)) mempty pkgss' +-- --------------------------------------------------------------------------- + +indexCombiningTests :: TestTree +indexCombiningTests = + testGroup + "Index combining (CombineStrategy)" + [ testCase "Skip: repo contributes nothing" $ + pkgs [(repoFoo1, CombineStrategySkip)] + @?= [] + , testCase "Merge: single repo makes all its packages visible" $ + pkgs [(repoFoo1, CombineStrategyMerge)] + @?= [foo1] + , testCase "Override: single repo makes all its packages visible" $ + pkgs [(repoFoo1, CombineStrategyOverride)] + @?= [foo1] + , testCase "Merge+Merge: non-overlapping packages are both visible" $ + pkgs [(repoFoo1, CombineStrategyMerge), (repoBar1, CombineStrategyMerge)] + @?= List.sort [foo1, bar1] + , testCase "Merge+Merge: different versions of same package are both visible" $ + pkgs [(repoFoo1, CombineStrategyMerge), (repoFoo2, CombineStrategyMerge)] + @?= List.sort [foo1, foo2] + , testCase "Merge+Override: packages only in first repo remain visible" $ + pkgs [(repoFoo1, CombineStrategyMerge), (repoBar1, CombineStrategyOverride)] + @?= List.sort [foo1, bar1] + , testCase "Merge+Override: override repo replaces all versions of overlapping package" $ + -- repoFoo12 has foo-1.0 and foo-2.0; repoFoo2 has only foo-2.0. + -- Override means repoFoo2 wins the entire 'foo' bucket. + pkgs [(repoFoo12, CombineStrategyMerge), (repoFoo2, CombineStrategyOverride)] + @?= [foo2] + , testCase "Merge+Override: override does not affect packages absent from override repo" $ + pkgs [(repoFoo1bar1, CombineStrategyMerge), (repoFoo2, CombineStrategyOverride)] + @?= List.sort [foo2, bar1] + , testCase "Skip in middle: skipped repo is ignored" $ + pkgs + [ (repoFoo1, CombineStrategyMerge) + , (repoFoo2, CombineStrategySkip) + , (repoBar1, CombineStrategyMerge) + ] + @?= List.sort [foo1, bar1] + , testCase "Skip+Merge: later merge after skip still contributes" $ + pkgs [(repoFoo1, CombineStrategySkip), (repoFoo2, CombineStrategyMerge)] + @?= [foo2] + , testCase "Override+Override: last override wins the package bucket" $ + pkgs + [ (repoFoo1, CombineStrategyMerge) + , (repoFoo2, CombineStrategyOverride) + , (repoFoo3, CombineStrategyOverride) + ] + @?= [foo3] + , testCase "Override+Merge: merge after override combines both buckets" $ + -- foo bucket starts as {foo-2.0} after override, then merges {foo-3.0} + -- giving {foo-2.0, foo-3.0} + pkgs + [ (repoFoo1, CombineStrategyMerge) + , (repoFoo2, CombineStrategyOverride) + , (repoFoo3, CombineStrategyMerge) + ] + @?= List.sort [foo2, foo3] + , testCase "All skip: result is empty" $ + pkgs + [ (repoFoo1, CombineStrategySkip) + , (repoFoo2, CombineStrategySkip) + ] + @?= [] + , testCase "Empty repos list: result is empty" $ + pkgs [] @?= [] + ] + +-- Run the combining fold and return the result as a sorted list of PackageIds. +-- Uses the exported 'applyStrategy' from IndexUtils directly, so this stays +-- in sync with the production implementation in getSourcePackagesAtIndexState. +pkgs + :: [(PackageIndex.PackageIndex PackageIdentifier, CombineStrategy)] + -> [PackageIdentifier] +pkgs = List.sort . PackageIndex.allPackages . List.foldl' applyStrategy mempty + +-- Test packages +foo1, foo2, foo3, bar1 :: PackageIdentifier +foo1 = PackageIdentifier (mkPackageName "foo") (mkVersion [1, 0]) +foo2 = PackageIdentifier (mkPackageName "foo") (mkVersion [2, 0]) +foo3 = PackageIdentifier (mkPackageName "foo") (mkVersion [3, 0]) +bar1 = PackageIdentifier (mkPackageName "bar") (mkVersion [1, 0]) + +-- Single-package indices +repoFoo1, repoFoo2, repoFoo3, repoBar1 :: PackageIndex.PackageIndex PackageIdentifier +repoFoo1 = PackageIndex.fromList [foo1] +repoFoo2 = PackageIndex.fromList [foo2] +repoFoo3 = PackageIndex.fromList [foo3] +repoBar1 = PackageIndex.fromList [bar1] + +-- Multi-package indices +repoFoo12, repoFoo1bar1 :: PackageIndex.PackageIndex PackageIdentifier +repoFoo12 = PackageIndex.fromList [foo1, foo2] +repoFoo1bar1 = PackageIndex.fromList [foo1, bar1] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils/ActiveRepos.hs b/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils/ActiveRepos.hs new file mode 100644 index 00000000000..b33da1eaadf --- /dev/null +++ b/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils/ActiveRepos.hs @@ -0,0 +1,169 @@ +module UnitTests.Distribution.Client.IndexUtils.ActiveRepos (tests) where + +import Distribution.Client.IndexUtils.ActiveRepos +import Distribution.Client.Types.RepoName (RepoName (..)) +import Distribution.Parsec (simpleParsec) +import Distribution.Pretty (prettyShow) + +import UnitTests.Distribution.Client.ArbitraryInstances () + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +tests :: [TestTree] +tests = + [ testGroup "organizeByRepos" organizeByReposTests + , testGroup "filterSkippedActiveRepos" filterSkippedTests + , testGroup + "parse/pretty roundtrip" + [ testProperty "ActiveRepos roundtrips" prop_activeReposRoundtrip + ] + ] + +------------------------------------------------------------------------------- +-- organizeByRepos +------------------------------------------------------------------------------- + +-- Convenience: run organizeByRepos over a fixed three-element repo list. +organize :: ActiveRepos -> Either String [(RepoName, CombineStrategy)] +organize ar = organizeByRepos ar id [RepoName "a", RepoName "b", RepoName "c"] + +organizeByReposTests :: [TestTree] +organizeByReposTests = + [ testCase ":rest assigns strategy to all repos in order" $ + organize (ActiveRepos [ActiveRepoRest CombineStrategyMerge]) + @?= Right + [ (RepoName "a", CombineStrategyMerge) + , (RepoName "b", CombineStrategyMerge) + , (RepoName "c", CombineStrategyMerge) + ] + , testCase ":none yields empty result" $ + organize (ActiveRepos []) + @?= Right [] + , testCase "named repo before :rest is placed first" $ + organize + ( ActiveRepos + [ ActiveRepo (RepoName "b") CombineStrategyOverride + , ActiveRepoRest CombineStrategyMerge + ] + ) + @?= Right + [ (RepoName "b", CombineStrategyOverride) + , (RepoName "a", CombineStrategyMerge) + , (RepoName "c", CombineStrategyMerge) + ] + , testCase "named repo after :rest is placed last" $ + organize + ( ActiveRepos + [ ActiveRepoRest CombineStrategyMerge + , ActiveRepo (RepoName "b") CombineStrategyOverride + ] + ) + @?= Right + [ (RepoName "a", CombineStrategyMerge) + , (RepoName "c", CombineStrategyMerge) + , (RepoName "b", CombineStrategyOverride) + ] + , testCase "named repo absent from provided list gives Left" $ + organize + ( ActiveRepos + [ ActiveRepoRest CombineStrategyMerge + , ActiveRepo (RepoName "d") CombineStrategyOverride + ] + ) + @?= Left "no repository provided d" + , testCase "named repo against empty list gives Left" $ + organizeByRepos + (ActiveRepos [ActiveRepo (RepoName "a") CombineStrategyMerge]) + id + ([] :: [RepoName]) + @?= Left "no repository provided a" + , testCase "skip strategy is preserved in output" $ + organize + ( ActiveRepos + [ ActiveRepo (RepoName "a") CombineStrategySkip + , ActiveRepoRest CombineStrategyMerge + ] + ) + @?= Right + [ (RepoName "a", CombineStrategySkip) + , (RepoName "b", CombineStrategyMerge) + , (RepoName "c", CombineStrategyMerge) + ] + , testCase ":rest with skip strategy skips all remaining repos" $ + organize (ActiveRepos [ActiveRepoRest CombineStrategySkip]) + @?= Right + [ (RepoName "a", CombineStrategySkip) + , (RepoName "b", CombineStrategySkip) + , (RepoName "c", CombineStrategySkip) + ] + , testCase "multiple :rest entries cause each repo to appear once per :rest" $ + -- Documented edge case: if ActiveRepoRest appears more than once, + -- the rest-repositories appear multiple times in the output. + organize + ( ActiveRepos + [ ActiveRepoRest CombineStrategyMerge + , ActiveRepoRest CombineStrategyOverride + ] + ) + @?= Right + [ (RepoName "a", CombineStrategyMerge) + , (RepoName "b", CombineStrategyMerge) + , (RepoName "c", CombineStrategyMerge) + , (RepoName "a", CombineStrategyOverride) + , (RepoName "b", CombineStrategyOverride) + , (RepoName "c", CombineStrategyOverride) + ] + ] + +------------------------------------------------------------------------------- +-- filterSkippedActiveRepos +------------------------------------------------------------------------------- + +filterSkippedTests :: [TestTree] +filterSkippedTests = + [ testCase "skipped entries are removed when no :rest is present" $ + filterSkippedActiveRepos + ( ActiveRepos + [ ActiveRepo (RepoName "a") CombineStrategyMerge + , ActiveRepo (RepoName "b") CombineStrategySkip + ] + ) + @?= ActiveRepos [ActiveRepo (RepoName "a") CombineStrategyMerge] + , testCase "all-skipped list with no :rest yields empty" $ + filterSkippedActiveRepos + ( ActiveRepos + [ ActiveRepo (RepoName "a") CombineStrategySkip + , ActiveRepo (RepoName "b") CombineStrategySkip + ] + ) + @?= ActiveRepos [] + , testCase "list without any skipped entries is unchanged" $ + let ar = + ActiveRepos + [ ActiveRepo (RepoName "a") CombineStrategyMerge + , ActiveRepo (RepoName "b") CombineStrategyOverride + ] + in filterSkippedActiveRepos ar @?= ar + , testCase "skipped entries are kept when :rest is present" $ + -- filterSkippedActiveRepos is a no-op when ActiveRepoRest appears + let ar = + ActiveRepos + [ ActiveRepoRest CombineStrategyMerge + , ActiveRepo (RepoName "b") CombineStrategySkip + ] + in filterSkippedActiveRepos ar @?= ar + , testCase ":rest with skip strategy is kept unchanged" $ + let ar = ActiveRepos [ActiveRepoRest CombineStrategySkip] + in filterSkippedActiveRepos ar @?= ar + ] + +------------------------------------------------------------------------------- +-- Parse/pretty roundtrip +------------------------------------------------------------------------------- + +prop_activeReposRoundtrip :: ActiveRepos -> Property +prop_activeReposRoundtrip ar = + counterexample ("prettyShow: " ++ prettyShow ar) $ + simpleParsec (prettyShow ar) === Just ar diff --git a/changelog.d/pr-11684 b/changelog.d/pr-11684 new file mode 100644 index 00000000000..70583b7c6ca --- /dev/null +++ b/changelog.d/pr-11684 @@ -0,0 +1,12 @@ +--- +synopsis: Add unit tests for active-repositories feature +packages: [cabal-install] +prs: 11684 +--- + +Add unit tests for the `active-repositories` cabal configuration field: + +- `organizeByRepos`: ordering and strategy assignment with `:rest`, named repos, and error cases +- `filterSkippedActiveRepos`: filtering of skipped entries in the absence of `:rest` +- `CombineStrategy` index-combining logic (Skip/Merge/Override) +- Parse/pretty roundtrip for `ActiveRepos` (QuickCheck)