Merge pull request haskell#9824 from cabalism/fix/short-rejection-all…

…ow-suffix-9823

Show abbreviated mixed versions with suffix

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

@@ -7,13 +7,12 @@ module Distribution.Solver.Modular.Message (
     showMessages
   ) where
 
-import Data.Maybe (isJust)
 import qualified Data.List as L
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Set (Set)
 import qualified Data.Set as S
-import Data.Maybe (catMaybes, mapMaybe)
+import Data.Maybe (catMaybes, mapMaybe, isJust)
 import Prelude hiding (pi)
 
 import Distribution.Pretty (prettyShow) -- from Cabal
@@ -236,61 +235,41 @@ 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)
+blurbOptions a q ps = blurb a ++ showOptions q 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]
+-- | Shows a mixed list of instances and versions in a human-friendly way,
+-- abbreviated.
+-- >>> showOptions foobarQPN [v0, v1]
 -- "foo-bar; 0, 1"
--- >>> showIsOrVs foobarQPN $ tryVs [v0]
+-- >>> showOptions foobarQPN [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 []
+-- >>> showOptions foobarQPN [i0, i1]
+-- "foo-bar; 0/installed-inplace, 1/installed-inplace"
+-- >>> showOptions foobarQPN [i0, v1]
+-- "foo-bar; 0/installed-inplace, 1"
+-- >>> showOptions foobarQPN [v0, i1]
+-- "foo-bar; 0, 1/installed-inplace"
+-- >>> showOptions foobarQPN []
 -- "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)
+-- >>> showOptions foobarQPN [k1, k2]
+-- "foo-bar; foo-bar~>bazqux.foo-bar-1, foo-bar~>bazqux.foo-bar-2"
+-- >>> showOptions foobarQPN [v0, i1, k2]
+-- "foo-bar; 0, 1/installed-inplace, foo-bar~>bazqux.foo-bar-2"
+showOptions :: QPN -> [POption] -> String
+showOptions _ [] = "unexpected empty list of versions"
+showOptions q [x] = showOption q x
+showOptions q xs = showQPN q ++ "; " ++ (L.intercalate ", "
+  [if isJust linkedTo
+    then showOption q x
+    else showI i -- Don't show the package, just the version
+  | x@(POption i linkedTo) <- xs
+  ])
 
 showGR :: QGoalReason -> String
 showGR UserGoal            = " (user goal)"
@@ -356,8 +335,12 @@ showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) =
 -- >>> import Distribution.Solver.Types.PackagePath
 -- >>> import Distribution.Types.Version
 -- >>> import Distribution.Types.UnitId
--- >>> let foobarQPN = Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "foo-bar")
+-- >>> let foobarPN = PackagePath DefaultNamespace QualToplevel
+-- >>> let bazquxPN = PackagePath (Independent $ mkPackageName "bazqux") QualToplevel
+-- >>> let foobarQPN = Q foobarPN (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
+-- >>> let k1 = POption (I (mkVersion [1]) InRepo) (Just bazquxPN)
+-- >>> let k2 = POption (I (mkVersion [2]) InRepo) (Just bazquxPN)

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

@@ -961,7 +961,7 @@ tests =
                     , 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"
+                  skipping = "skipping: A; 2.0.0/installed-2.0.0, 1.0.0/installed-1.0.0"
                in mkTest db "show skipping versions list, installed" ["B"] $
                     solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg)
           ]

changelog.d/pr-9824

@@ -0,0 +1,10 @@
+synopsis: Abbrevate solver rejection messages with installed versions
+packages: cabal-install-solver
+prs: #9824
+issues: #9823
+
+description: {
+
+Abbreviate solver rejection messages even in the presence of installed versions.
+
+}