From 5efd6a1663e614284e8b333e8b72bff0ad3e420b Mon Sep 17 00:00:00 2001
From: Phil de Joux <philderbeast@gmail.com>
Date: Sun, 24 Dec 2023 13:44:58 -0500
Subject: [PATCH] Format solver rejections

- Take account of hyphenated package names
- Don't shorten a singe rejection
---
 .../Distribution/Solver/Modular/Message.hs    | 19 +++++++++++++++-
 changelog.d/pr-9560                           | 22 +++++++++++++++++++
 2 files changed, 40 insertions(+), 1 deletion(-)
 create mode 100644 changelog.d/pr-9560

diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
index 73580aff3e6..de0bf38fddf 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
@@ -5,6 +5,7 @@ module Distribution.Solver.Modular.Message (
     showMessages
   ) where
 
+import Data.Maybe (listToMaybe)
 import qualified Data.List as L
 import Data.Map (Map)
 import qualified Data.Map as M
@@ -98,7 +99,23 @@ showMessages = go 0
     goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))
       | qpn == qpn' && fr == fr' = goPReject l qpn (i : is) c fr ms
     goPReject l qpn is c fr ms =
-        (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms)
+        (atLevel l $ formatRejections (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr)
+        (go l ms)
+
+    formatRejections :: [String] -> String
+    formatRejections [x] = "rejecting: " ++ x
+    formatRejections xs = "rejecting: " ++ case L.nub prefixes of
+        [prefix] -> prefix ++ "; " ++ L.intercalate ", " versions
+        _ -> L.intercalate ", " xs
+      where
+        (prefixes, versions) = unzip
+          [ maybe (x, "") (\hyphen -> (take hyphen x, drop (hyphen + 1) x)) ix
+          | x <- xs
+          -- Package names may contain hypens but a hypen is also the separator
+          -- between the package name and its version so find the last hyphen in
+          -- the string.
+          , let ix = listToMaybe (reverse $ L.elemIndices '-' x)
+          ]
 
     -- Handle many subsequent skipped package instances.
     goPSkip :: Int
diff --git a/changelog.d/pr-9560 b/changelog.d/pr-9560
new file mode 100644
index 00000000000..9f6ce9a4133
--- /dev/null
+++ b/changelog.d/pr-9560
@@ -0,0 +1,22 @@
+synopsis: Shorten solver rejection messages by removing repetition
+packages: cabal-install-solver
+prs: #9560
+issues: #9559 #4251
+
+description: {
+
+As before, we show a single rejection as hyphenated package-version.
+
+For multiple rejections, we show a list of versions preceded by package
+semicolon, a much shorter rendering of the same information.
+
+```diff
+- [__0] rejecting: pandoc-3.1.8, pandoc-3.1.7, pandoc-3.1.6.2, pandoc-3.1.6.1,
+- pandoc-3.1.6, pandoc-3.1.5, pandoc-3.1.4, pandoc-3.1.3, pandoc-3.1.2,
+- pandoc-3.1.1, pandoc-3.1, pandoc-3.0.1, pandoc-3.0, pandoc-2.19.2,
+- pandoc-2.19.1, pandoc-2.19, pandoc-2.18, pandoc-2.17.1.1, pandoc-2.17.1,
++ [__0] rejecting: pandoc; 3.1.8, 3.1.7, 3.1.6.2, 3.1.6.1, 3.1.6, 3.1.5, 3.1.4,
++ 3.1.3, 3.1.2, 3.1.1, 3.1, 3.0.1, 3.0, 2.19.2, 2.19.1, 2.19, 2.18, 2.17.1.1,
+```
+
+}
\ No newline at end of file