active-repositories: Don't override fully-deprecated packages

cabal-install-solver/src/Distribution/Solver/Types/PackageIndex.hs

@@ -22,6 +22,8 @@ module Distribution.Solver.Types.PackageIndex (
   -- * Updates
   merge,
   override,
+  OverrideOrMerge(..),
+  overrideOrMerge,
   insert,
   deletePackageName,
   deletePackageId,
@@ -181,6 +183,28 @@ override i1@(PackageIndex m1) i2@(PackageIndex m2) =
   expensiveAssert (invariant i1 && invariant i2) $
     mkPackageIndex (Map.unionWith (\_l r -> r) m1 m2)
 
+data OverrideOrMerge = Override | Merge
+  deriving (Eq, Show)
+
+-- | Combined override-or-merge of two indexes.
+--
+-- For any package, either 'override' or 'merge' the packages from the second
+-- index into the first based on the supplied predicate.
+--
+overrideOrMerge ::
+     Package pkg
+  => (PackageName -> OverrideOrMerge)
+  -> PackageIndex pkg
+  -> PackageIndex pkg
+  -> PackageIndex pkg
+overrideOrMerge strategy i1@(PackageIndex m1) i2@(PackageIndex m2) =
+  expensiveAssert (invariant i1 && invariant i2) $
+    mkPackageIndex (Map.unionWithKey overridePkg m1 m2)
+  where
+    overridePkg name l r = case strategy name of
+      Override -> r
+      Merge -> mergeBuckets l r
+
 -- | Inserts a single package into the index.
 --
 -- This is equivalent to (but slightly quicker than) using 'mappend' or

cabal-install/src/Distribution/Client/IndexUtils.hs

@@ -30,6 +30,8 @@ module Distribution.Client.IndexUtils
   , ActiveRepos
   , filterSkippedActiveRepos
   , applyStrategy
+  , addIndex
+  , deprecationAwareStrategy
   , Index (..)
   , RepoIndexState (..)
   , PackageEntry (..)
@@ -374,7 +376,7 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
             ]
 
   let pkgs :: PackageIndex UnresolvedSourcePackage
-      pkgs = foldl' (\acc (rd, s) -> applyStrategy acc (rdIndex rd, s)) mempty pkgss'
+      pkgs = foldl' (\acc (rd, s) -> addIndex acc (rdIndex rd, rdPreferences rd, s)) mempty pkgss'
 
   -- Note: preferences combined without using CombineStrategy
   let prefs :: Map PackageName VersionRange
@@ -419,6 +421,45 @@ applyStrategy acc (_, CombineStrategySkip) = acc
 applyStrategy acc (idx, CombineStrategyMerge) = PackageIndex.merge acc idx
 applyStrategy acc (idx, CombineStrategyOverride) = PackageIndex.override acc idx
 
+-- | Fold one package index and its preferred-versions into an accumulator
+-- according to a 'CombineStrategy'.
+--
+-- Like 'applyStrategy', but for 'CombineStrategyOverride' consults the
+-- repo's @preferred-versions@ via 'deprecationAwareStrategy': if all
+-- versions of a package are deprecated in the override repo, merge
+-- semantics are used for that package instead of override semantics.
+addIndex
+  :: Package pkg
+  => PackageIndex pkg
+  -> (PackageIndex pkg, [Dependency], CombineStrategy)
+  -> PackageIndex pkg
+addIndex acc (idx, prefs, CombineStrategyOverride) =
+  PackageIndex.overrideOrMerge (deprecationAwareStrategy idx prefsByPkg) acc idx
+  where
+    prefsByPkg =
+      Map.fromListWith
+        intersectVersionRanges
+        [(name, range) | Dependency name range _ <- prefs]
+addIndex acc (idx, _, s) = applyStrategy acc (idx, s)
+
+-- | Per-package override-or-merge decision for a 'CombineStrategyOverride' repo.
+--
+-- Returns 'PackageIndex.Merge' when every version of the package in the
+-- override index is deprecated (i.e. excluded by the repo's
+-- @preferred-versions@), so that versions from earlier repos remain visible.
+-- Returns 'PackageIndex.Override' otherwise.
+deprecationAwareStrategy
+  :: Package pkg
+  => PackageIndex pkg
+  -> Map PackageName VersionRange
+  -> PackageName
+  -> PackageIndex.OverrideOrMerge
+deprecationAwareStrategy idx prefsByPkg pkgname
+  | Just pkgPrefs <- Map.lookup pkgname prefsByPkg
+  , null $ PackageIndex.lookupDependency idx pkgname pkgPrefs =
+      PackageIndex.Merge
+  | otherwise = PackageIndex.Override
+
 -- | Read a repository index from disk, from the local file specified by
 -- the 'Repo'.
 --

cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs

@@ -5,11 +5,13 @@ import Distribution.Client.IndexUtils.ActiveRepos
 import qualified Distribution.Compat.NonEmptySet as NES
 import Distribution.Package
 import Distribution.Simple.Utils (toUTF8LBS)
+import Distribution.Solver.Types.PackageIndex (OverrideOrMerge (..))
 import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
 import Distribution.Types.LibraryName
 import Distribution.Version
 
 import qualified Data.List as List
+import qualified Data.Map.Strict as Map
 
 import Test.Tasty
 import Test.Tasty.HUnit
@@ -18,6 +20,9 @@ tests :: [TestTree]
 tests =
   [ simpleVersionsParserTests
   , indexCombiningTests
+  , overrideOrMergeTests
+  , deprecationAwareStrategyTests
+  , addIndexTests
   ]
 
 -- ---------------------------------------------------------------------------
@@ -193,3 +198,183 @@ repoBar1 = PackageIndex.fromList [bar1]
 repoFoo12, repoFoo1bar1 :: PackageIndex.PackageIndex PackageIdentifier
 repoFoo12 = PackageIndex.fromList [foo1, foo2]
 repoFoo1bar1 = PackageIndex.fromList [foo1, bar1]
+
+-- ---------------------------------------------------------------------------
+-- overrideOrMerge tests
+--
+-- These test PackageIndex.overrideOrMerge directly, which is the building
+-- block for conditionally falling back to merge when all versions of a
+-- package in the override repo are deprecated (issue #8502).
+-- ---------------------------------------------------------------------------
+
+overrideOrMergeTests :: TestTree
+overrideOrMergeTests =
+  testGroup
+    "overrideOrMerge"
+    [ testCase "all-Override strategy matches plain override" $
+        -- When strategy always returns Override, result equals PackageIndex.override
+        let result = PackageIndex.overrideOrMerge (const Override) repoFoo12 repoFoo2
+            expected = PackageIndex.override repoFoo12 repoFoo2
+         in allPkgs result @?= allPkgs expected
+    , testCase "all-Merge strategy matches plain merge" $
+        -- When strategy always returns Merge, result equals PackageIndex.merge
+        let result = PackageIndex.overrideOrMerge (const Merge) repoFoo12 repoFoo2
+            expected = PackageIndex.merge repoFoo12 repoFoo2
+         in allPkgs result @?= allPkgs expected
+    , testCase "Override: second index wins entire package bucket" $
+        -- repoFoo12 has foo-1.0 and foo-2.0; repoFoo2 has only foo-2.0.
+        -- Override means repoFoo2 wins the 'foo' bucket, so foo-1.0 is hidden.
+        allPkgs (PackageIndex.overrideOrMerge (const Override) repoFoo12 repoFoo2)
+          @?= [foo2]
+    , testCase "Merge: both buckets combined, duplicates removed" $
+        -- repoFoo12 has foo-1.0 and foo-2.0; repoFoo2 has only foo-2.0.
+        -- Merge keeps foo-1.0 and foo-2.0 (foo-2.0 deduplicated).
+        allPkgs (PackageIndex.overrideOrMerge (const Merge) repoFoo12 repoFoo2)
+          @?= List.sort [foo1, foo2]
+    , testCase "mixed strategy: Override for foo, Merge for bar" $
+        -- repoFoo1bar1 has foo-1.0 and bar-1.0; second index has foo-2.0 and bar-1.0.
+        -- foo is overridden (foo-1.0 hidden), bar is merged (bar-1.0 deduplicated).
+        let i2 = PackageIndex.fromList [foo2, bar1]
+            strategy name
+              | name == mkPackageName "foo" = Override
+              | otherwise = Merge
+         in allPkgs (PackageIndex.overrideOrMerge strategy repoFoo1bar1 i2)
+              @?= List.sort [foo2, bar1]
+    , testCase "deprecated fallback: Merge when override repo has only deprecated versions" $
+        -- Simulates the issue-8502 scenario: repo-a has foo-1.0; repo-b (override)
+        -- has foo-2.0 but all its versions are deprecated.  The caller detects this
+        -- and passes Merge for 'foo', so foo-1.0 remains visible alongside foo-2.0.
+        let repoA = PackageIndex.fromList [foo1]
+            repoB = PackageIndex.fromList [foo2] -- pretend all deprecated
+            strategy name
+              | name == mkPackageName "foo" = Merge -- fall back because all deprecated
+              | otherwise = Override
+         in allPkgs (PackageIndex.overrideOrMerge strategy repoA repoB)
+              @?= List.sort [foo1, foo2]
+    , testCase "package absent from second index: first index versions kept" $
+        -- bar is only in repoFoo1bar1, not in repoFoo2; it survives regardless of strategy.
+        allPkgs (PackageIndex.overrideOrMerge (const Override) repoFoo1bar1 repoFoo2)
+          @?= List.sort [foo2, bar1]
+    , testCase "package absent from first index: second index versions appear" $
+        allPkgs (PackageIndex.overrideOrMerge (const Override) repoFoo1 repoBar1)
+          @?= List.sort [foo1, bar1]
+    , testCase "empty first index: second index fully visible" $
+        allPkgs (PackageIndex.overrideOrMerge (const Override) mempty repoFoo12)
+          @?= List.sort [foo1, foo2]
+    , testCase "empty second index: first index unchanged" $
+        allPkgs (PackageIndex.overrideOrMerge (const Override) repoFoo12 mempty)
+          @?= List.sort [foo1, foo2]
+    ]
+
+allPkgs :: PackageIndex.PackageIndex PackageIdentifier -> [PackageIdentifier]
+allPkgs = List.sort . PackageIndex.allPackages
+
+-- ---------------------------------------------------------------------------
+-- deprecationAwareStrategy tests
+--
+-- Tests for the per-package Override/Merge decision used when applying a
+-- CombineStrategyOverride repo.  The three cases are:
+--   1. Package absent from preferred-versions  -> Override
+--   2. Package present, some versions preferred -> Override
+--   3. Package present, no versions preferred  -> Merge (all deprecated)
+-- ---------------------------------------------------------------------------
+
+deprecationAwareStrategyTests :: TestTree
+deprecationAwareStrategyTests =
+  testGroup
+    "deprecationAwareStrategy"
+    [ testCase "package absent from preferred-versions gives Override" $
+        -- No entry for 'foo' in prefs, so the repo is not restricting it.
+        strat repoFoo1 Map.empty fooName @?= Override
+    , testCase "package present with matching versions gives Override" $
+        -- foo-1.0 is in the index and satisfies ">= 1.0", so not all deprecated.
+        strat repoFoo1 (prefs fooName (orLaterVersion v1)) fooName @?= Override
+    , testCase "package present but no versions match gives Merge" $
+        -- foo-1.0 is in the index but the pref ">= 2.0" excludes it: all deprecated.
+        strat repoFoo1 (prefs fooName (orLaterVersion v2)) fooName @?= Merge
+    , testCase "unrelated package in prefs does not affect result" $
+        -- Prefs only mention 'bar'; 'foo' has no pref entry, so Override.
+        strat repoFoo1 (prefs barName (orLaterVersion v1)) fooName @?= Override
+    , testCase "package absent from index but in prefs gives Merge" $
+        -- The pref entry exists but the index is empty, so lookupDependency
+        -- returns [], meaning no preferred version exists.
+        strat mempty (prefs fooName (orLaterVersion v2)) fooName @?= Merge
+    , testCase "multiple packages decided independently" $
+        -- foo is deprecated (pref excludes foo-1.0), bar is not (bar-1.0 satisfies >= 1.0).
+        let p =
+              Map.unionWith
+                intersectVersionRanges
+                (prefs fooName (orLaterVersion v2))
+                (prefs barName (orLaterVersion v1))
+         in do
+              strat repoFoo1bar1 p fooName @?= Merge
+              strat repoFoo1bar1 p barName @?= Override
+    ]
+  where
+    strat = deprecationAwareStrategy
+    fooName = mkPackageName "foo"
+    barName = mkPackageName "bar"
+    v1 = mkVersion [1, 0]
+    v2 = mkVersion [2, 0]
+    prefs name vr = Map.singleton name vr
+
+-- ---------------------------------------------------------------------------
+-- addIndex tests
+--
+-- Tests for the top-level addIndex, which is the function used by
+-- getSourcePackagesAtIndexState to fold each repository's index into the
+-- accumulator.  Unlike applyStrategy, addIndex consults preferred-versions
+-- for CombineStrategyOverride, falling back to merge when all versions of a
+-- package are deprecated.  A regression to plain override would cause the
+-- "all deprecated" test to fail.
+-- ---------------------------------------------------------------------------
+
+addIndexTests :: TestTree
+addIndexTests =
+  testGroup
+    "addIndex"
+    [ testCase "Skip: index not added" $
+        run [(repoFoo1, [], CombineStrategySkip)]
+          @?= []
+    , testCase "Merge: index added" $
+        run [(repoFoo1, [], CombineStrategyMerge)]
+          @?= [foo1]
+    , testCase "Override with no prefs: behaves like plain override" $
+        run
+          [ (repoFoo12, [], CombineStrategyMerge)
+          , (repoFoo2, [], CombineStrategyOverride)
+          ]
+          @?= [foo2]
+    , testCase "Override with prefs matching some versions: still overrides" $
+        -- foo-2.0 satisfies ">= 2.0", so not all deprecated; override applies.
+        run
+          [ (repoFoo12, [], CombineStrategyMerge)
+          , (repoFoo2, [dep fooName (orLaterVersion v2)], CombineStrategyOverride)
+          ]
+          @?= [foo2]
+    , testCase "Override with all versions deprecated: falls back to merge" $
+        -- foo-2.0 does not satisfy ">= 3.0", so all versions deprecated;
+        -- override falls back to merge, keeping foo-1.0 from the first repo.
+        run
+          [ (repoFoo1, [], CombineStrategyMerge)
+          , (repoFoo2, [dep fooName (orLaterVersion v3)], CombineStrategyOverride)
+          ]
+          @?= List.sort [foo1, foo2]
+    , testCase "Override: only the deprecated package falls back, others still override" $
+        -- foo is all-deprecated in override repo → merge; bar has no prefs → override.
+        run
+          [ (repoFoo1bar1, [], CombineStrategyMerge)
+          ,
+            ( PackageIndex.fromList [foo2, bar1]
+            , [dep fooName (orLaterVersion v3)]
+            , CombineStrategyOverride
+            )
+          ]
+          @?= List.sort [foo1, foo2, bar1]
+    ]
+  where
+    run = allPkgs . List.foldl' (\acc (idx, ps, s) -> addIndex acc (idx, ps, s)) mempty
+    fooName = mkPackageName "foo"
+    v2 = mkVersion [2, 0]
+    v3 = mkVersion [3, 0]
+    dep name vr = Dependency name vr (NES.singleton LMainLibName)

changelog.d/pr-11760

@@ -0,0 +1,17 @@
+---
+synopsis: "active-repositories: don't override fully-deprecated packages"
+packages: [cabal-install, cabal-install-solver]
+prs: 11760
+---
+
+When `active-repositories` includes a repo with `:override`, and that
+repo's `preferred-versions` marks all its versions of a package as
+deprecated, the index-combining step previously still applied full
+override semantics, hiding all versions of that package from earlier
+repos.
+
+Fix by consulting `preferred-versions` when combining indexes: if no
+version of the package in the override repo is preferred, fall back to
+merge semantics so earlier-repo versions remain visible.
+
+Fixes https://github.com/haskell/cabal/issues/8502

doc/cabal-project-description-file.rst

@@ -782,6 +782,13 @@ The following settings control the behavior of the dependency solver:
     present in my-repository only in version 2.0, and the :override forbids
     searching for other versions of X further up the list.
 
+    There is one exception: if all versions of a package in the overriding
+    repository are deprecated (i.e. excluded by that repository's
+    ``preferred-versions``), :override falls back to merge semantics for that
+    package, so versions from earlier repositories remain visible. This avoids
+    a situation where a fully-deprecated override inadvertently hides all
+    usable versions of a package.
+
     :override has no effect for package names that aren't present in the
     overriding repository.