Add tests for active-repositories feature

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

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'.
 --

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

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]

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

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)