diff --git a/Makefile b/Makefile index cf670814edf..2c84c9d8d98 100644 --- a/Makefile +++ b/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). diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs index 73580aff3e6..11fa7ca874d 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs +++ b/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 \ No newline at end of file diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs index 123979921b1..3d5b965ba06 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/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 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