Merge pull request #9560 from cabalism/fix/format-rejections-9559

Add a format rejections function

Author: mergify[bot]

Makefile

@@ -94,6 +94,7 @@ doctest :
 	$(DOCTEST) Cabal-syntax
 	$(DOCTEST) Cabal-described
 	$(DOCTEST) --build-depends=QuickCheck Cabal
+	$(DOCTEST) cabal-install-solver
 	$(DOCTEST) cabal-install
 
 # This is not run as part of validate.sh (we need hackage-security, which is tricky to get).

cabal-install-solver/src/Distribution/Solver/Modular/Message.hs

@@ -1,10 +1,13 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Distribution.Solver.Modular.Message (
     Message(..),
     showMessages
   ) where
 
+import Data.Maybe (isJust)
 import qualified Data.List as L
 import Data.Map (Map)
 import qualified Data.Map as M
@@ -17,7 +20,8 @@ import Distribution.Pretty (prettyShow) -- from Cabal
 
 import qualified Distribution.Solver.Modular.ConflictSet as CS
 import Distribution.Solver.Modular.Dependency
-import Distribution.Solver.Modular.Flag
+import Distribution.Solver.Modular.Flag ( QFN, QSN )
+import qualified Distribution.Solver.Modular.Flag as Flag ( showQFN, showQFNBool, showQSN, showQSNBool )
 import Distribution.Solver.Modular.MessageUtils
          (showUnsupportedExtension, showUnsupportedLanguage)
 import Distribution.Solver.Modular.Package
@@ -60,24 +64,24 @@ showMessages = go 0
     go !l (Step (TryP qpn i) (Step Enter (Step (Skip conflicts) (Step Leave ms)))) =
         goPSkip l qpn [i] conflicts ms
     go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
-        (atLevel l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go l ms)
+        (atLevel l $ blurbQFNBool Rejecting qfn b ++ showFR c fr) (go l ms)
     go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
-        (atLevel l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go l ms)
+        (atLevel l $ blurbQSNBool Rejecting qsn b ++ showFR c fr) (go l ms)
     go !l (Step (Next (Goal (P _  ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =
-        (atLevel l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go l ms)
+        (atLevel l $ blurbOption Trying qpn' i ++ showGR gr) (go l ms)
     go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) =
         atLevel l ("unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms
     -- standard display
     go !l (Step Enter                    ms) = go (l+1) ms
     go !l (Step Leave                    ms) = go (l-1) ms
-    go !l (Step (TryP qpn i)             ms) = (atLevel l $ "trying: " ++ showQPNPOpt qpn i) (go l ms)
-    go !l (Step (TryF qfn b)             ms) = (atLevel l $ "trying: " ++ showQFNBool qfn b) (go l ms)
-    go !l (Step (TryS qsn b)             ms) = (atLevel l $ "trying: " ++ showQSNBool qsn b) (go l ms)
+    go !l (Step (TryP qpn i)             ms) = (atLevel l $ blurbOption Trying qpn i) (go l ms)
+    go !l (Step (TryF qfn b)             ms) = (atLevel l $ blurbQFNBool Trying qfn b) (go l ms)
+    go !l (Step (TryS qsn b)             ms) = (atLevel l $ blurbQSNBool Trying qsn b) (go l ms)
     go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms)
     go !l (Step (Next _)                 ms) = go l     ms -- ignore flag goals in the log
     go !l (Step (Skip conflicts)         ms) =
         -- 'Skip' should always be handled by 'goPSkip' in the case above.
-        (atLevel l $ "skipping: " ++ showConflicts conflicts) (go l ms)
+        (atLevel l $ blurb Skipping ++ showConflicts conflicts) (go l ms)
     go !l (Step (Success)                ms) = (atLevel l $ "done") (go l ms)
     go !l (Step (Failure c fr)           ms) = (atLevel l $ showFailure c fr) (go l ms)
 
@@ -96,9 +100,12 @@ showMessages = go 0
               -> Progress Message a b
               -> Progress String a b
     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
+      | qpn == qpn' && fr == fr' =
+        -- By prepending (i : is) we reverse the order of the instances.
+        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 $ blurbOptions Rejecting qpn (reverse is) ++ showFR c fr)
+        (go l ms)
 
     -- Handle many subsequent skipped package instances.
     goPSkip :: Int
@@ -108,11 +115,11 @@ showMessages = go 0
             -> Progress Message a b
             -> Progress String a b
     goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms))))
-      | qpn == qpn' && conflicts == conflicts' = goPSkip l qpn (i : is) conflicts ms
+      | qpn == qpn' && conflicts == conflicts' =
+        -- By prepending (i : is) we reverse the order of the instances.
+        goPSkip l qpn (i : is) conflicts ms
     goPSkip l qpn is conflicts ms =
-      let msg = "skipping: "
-                 ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is))
-                 ++ showConflicts conflicts
+      let msg = blurbOptions Skipping qpn (reverse is) ++ showConflicts conflicts
       in atLevel l msg (go l ms)
 
     -- write a message with the current level number
@@ -206,12 +213,83 @@ data MergedPackageConflict = MergedPackageConflict {
   , versionConflict :: Maybe VR
   }
 
-showQPNPOpt :: QPN -> POption -> String
-showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) =
+data ProgressAction =
+    Trying
+  | Skipping
+  | Rejecting
+
+blurb :: ProgressAction -> String
+blurb = \case
+  Trying -> "trying: "
+  Skipping -> "skipping: "
+  Rejecting -> "rejecting: "
+
+blurbQFNBool :: ProgressAction -> QFN -> Bool -> String
+blurbQFNBool a q b = blurb a ++ Flag.showQFNBool q b
+
+blurbQSNBool :: ProgressAction -> QSN -> Bool -> String
+blurbQSNBool a q b = blurb a ++ Flag.showQSNBool q b
+
+blurbOption :: ProgressAction -> QPN -> POption -> String
+blurbOption a q p = blurb a ++ showOption q p
+
+blurbOptions :: ProgressAction -> QPN -> [POption] -> String
+blurbOptions a q ps = blurb a ++ showIsOrVs q (tryVs ps)
+
+showOption :: QPN -> POption -> String
+showOption qpn@(Q _pp pn) (POption i linkedTo) =
   case linkedTo of
     Nothing  -> showPI (PI qpn i) -- Consistent with prior to POption
     Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i)
 
+-- | A list of versions, or a list of instances.
+data IsOrVs = Is [POption] | Vs [Ver] deriving Show
+
+-- | Try to convert a list of options to a list of versions, or a list of
+-- instances if any of the options is linked or installed.  Singleton lists or
+-- empty lists are always converted to Is.
+-- >>> tryVs [v0, v1]
+-- Vs [mkVersion [0],mkVersion [1]]
+-- >>> tryVs [v0]
+-- Is [POption (I (mkVersion [0]) InRepo) Nothing]
+-- >>> tryVs [i0, i1]
+-- Is [POption (I (mkVersion [0]) (Inst (UnitId "foo-bar-0-inplace"))) Nothing,POption (I (mkVersion [1]) (Inst (UnitId "foo-bar-1-inplace"))) Nothing]
+-- >>> tryVs [i0, v1]
+-- Is [POption (I (mkVersion [0]) (Inst (UnitId "foo-bar-0-inplace"))) Nothing,POption (I (mkVersion [1]) InRepo) Nothing]
+-- >>> tryVs [v0, i1]
+-- Is [POption (I (mkVersion [0]) InRepo) Nothing,POption (I (mkVersion [1]) (Inst (UnitId "foo-bar-1-inplace"))) Nothing]
+-- >>> tryVs [i0]
+-- Is [POption (I (mkVersion [0]) (Inst (UnitId "foo-bar-0-inplace"))) Nothing]
+-- >>> tryVs []
+-- Is []
+tryVs :: [POption] -> IsOrVs
+tryVs xs@[] = Is xs
+tryVs xs@[_] = Is xs
+tryVs xs
+    | any (\(POption (instI -> b0) (isJust -> b1)) -> b0 || b1) xs = Is xs
+    | otherwise =
+      let (vs, is) = L.partition ((== InRepo) . snd) [(v, l) | POption i _ <- xs, let I v l = i]
+      in if null is then Vs (fst `map` vs) else Is xs
+
+-- | Shows a list of versions in a human-friendly way, abbreviated. Shows a list
+-- of instances in full.
+-- >>> showIsOrVs foobarQPN $ tryVs [v0, v1]
+-- "foo-bar; 0, 1"
+-- >>> showIsOrVs foobarQPN $ tryVs [v0]
+-- "foo-bar-0"
+-- >>> showIsOrVs foobarQPN $ tryVs [i0, i1]
+-- "foo-bar-0/installed-inplace, foo-bar-1/installed-inplace"
+-- >>> showIsOrVs foobarQPN $ tryVs [i0, v1]
+-- "foo-bar-0/installed-inplace, foo-bar-1"
+-- >>> showIsOrVs foobarQPN $ tryVs [v0, i1]
+-- "foo-bar-0, foo-bar-1/installed-inplace"
+-- >>> showIsOrVs foobarQPN $ tryVs []
+-- "unexpected empty list of versions"
+showIsOrVs :: QPN -> IsOrVs -> String
+showIsOrVs _ (Is []) = "unexpected empty list of versions"
+showIsOrVs q (Is xs) = L.intercalate ", " (showOption q `map` xs)
+showIsOrVs q (Vs xs) = showQPN q ++ "; " ++ L.intercalate ", " (showVer `map` xs)
+
 showGR :: QGoalReason -> String
 showGR UserGoal            = " (user goal)"
 showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")"
@@ -246,8 +324,8 @@ showFR _ (UnsupportedSpecVer ver)         = " (unsupported spec-version " ++ pre
 -- The following are internal failures. They should not occur. In the
 -- interest of not crashing unnecessarily, we still just print an error
 -- message though.
-showFR _ (MalformedFlagChoice qfn)        = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")"
-showFR _ (MalformedStanzaChoice qsn)      = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")"
+showFR _ (MalformedFlagChoice qfn)        = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ Flag.showQFN qfn ++ ")"
+showFR _ (MalformedStanzaChoice qsn)      = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ Flag.showQSN qsn ++ ")"
 showFR _ EmptyGoalChoice                  = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"
 
 showExposedComponent :: ExposedComponent -> String
@@ -270,3 +348,13 @@ showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) =
                          showQPN qpn ++ componentStr ++ "==" ++ showI i
        Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++
                          componentStr ++ showVR vr
+
+-- $setup
+-- >>> import Distribution.Solver.Types.PackagePath
+-- >>> import Distribution.Types.Version
+-- >>> import Distribution.Types.UnitId
+-- >>> let foobarQPN = Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "foo-bar")
+-- >>> let v0 = POption (I (mkVersion [0]) InRepo) Nothing
+-- >>> let v1 = POption (I (mkVersion [1]) InRepo) Nothing
+-- >>> let i0 = POption (I (mkVersion [0]) (Inst $ mkUnitId "foo-bar-0-inplace")) Nothing
+-- >>> let i1 = POption (I (mkVersion [1]) (Inst $ mkUnitId "foo-bar-1-inplace")) Nothing

cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs

@@ -615,7 +615,7 @@ tests =
                 , "[__2] unknown package: unknown2 (dependency of B)"
                 , "[__2] fail (backjumping, conflict set: B, unknown2)"
                 , "[__1] fail (backjumping, conflict set: A, B, unknown1, unknown2)"
-                , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that "
+                , "[__0] skipping: A; 3.0.0, 2.0.0 (has the same characteristics that "
                     ++ "caused the previous version to fail: depends on 'B')"
                 , "[__0] trying: A-1.0.0"
                 , "[__1] done"
@@ -644,7 +644,7 @@ tests =
                 , "[__1] next goal: B (dependency of A)"
                 , "[__1] rejecting: B-11.0.0 (conflict: A => B==14.0.0)"
                 , "[__1] fail (backjumping, conflict set: A, B)"
-                , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that "
+                , "[__0] skipping: A; 3.0.0, 2.0.0 (has the same characteristics that "
                     ++ "caused the previous version to fail: depends on 'B' but excludes "
                     ++ "version 11.0.0)"
                 , "[__0] trying: A-1.0.0"
@@ -769,7 +769,7 @@ tests =
                 , "[__2] next goal: C (dependency of A)"
                 , "[__2] rejecting: C-2.0.0 (conflict: A => C==1.0.0)"
                 , "[__2] fail (backjumping, conflict set: A, C)"
-                , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that caused the "
+                , "[__0] skipping: A; 3.0.0, 2.0.0 (has the same characteristics that caused the "
                     ++ "previous version to fail: depends on 'C' but excludes version 2.0.0)"
                 , "[__0] trying: A-1.0.0"
                 , "[__1] next goal: C (dependency of A)"
@@ -912,6 +912,51 @@ tests =
               msg = "rejecting: other-package-2.0.0/installed-AbCdEfGhIj0123456789"
            in mkTest db "show full installed package ABI hash (issue #5892)" ["my-package"] $
                 solverFailure (isInfixOf msg)
+      , testGroup
+          "package versions abbreviation (issue #9559.)"
+          [ runTest $
+              let db =
+                    [ Right $ exAv "A" 1 []
+                    , Right $ exAv "A" 2 []
+                    , Right $ exAv "B" 1 [ExFix "A" 3]
+                    ]
+                  rejecting = "rejecting: A-2.0.0"
+                  skipping = "skipping: A-1.0.0"
+               in mkTest db "show skipping singleton" ["B"] $
+                    solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg)
+          , runTest $
+              let db =
+                    [ Left $ exInst "A" 1 "A-1.0.0" []
+                    , Left $ exInst "A" 2 "A-2.0.0" []
+                    , Right $ exAv "B" 1 [ExFix "A" 3]
+                    ]
+                  rejecting = "rejecting: A-2.0.0/installed-2.0.0"
+                  skipping = "skipping: A-1.0.0/installed-1.0.0"
+               in mkTest db "show skipping singleton, installed" ["B"] $
+                    solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg)
+          , runTest $
+              let db =
+                    [ Right $ exAv "A" 1 []
+                    , Right $ exAv "A" 2 []
+                    , Right $ exAv "A" 3 []
+                    , Right $ exAv "B" 1 [ExFix "A" 4]
+                    ]
+                  rejecting = "rejecting: A-3.0.0"
+                  skipping = "skipping: A; 2.0.0, 1.0.0"
+               in mkTest db "show skipping versions list" ["B"] $
+                    solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg)
+          , runTest $
+              let db =
+                    [ Left $ exInst "A" 1 "A-1.0.0" []
+                    , Left $ exInst "A" 2 "A-2.0.0" []
+                    , Left $ exInst "A" 3 "A-3.0.0" []
+                    , Right $ exAv "B" 1 [ExFix "A" 4]
+                    ]
+                  rejecting = "rejecting: A-3.0.0/installed-3.0.0"
+                  skipping = "skipping: A-2.0.0/installed-2.0.0, A-1.0.0/installed-1.0.0"
+               in mkTest db "show skipping versions list, installed" ["B"] $
+                    solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg)
+          ]
       ]
   ]
   where

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,
+```
+
+}