From be71421f92742df242d105c0b0055a86be755a00 Mon Sep 17 00:00:00 2001
From: Phil de Joux <philderbeast@gmail.com>
Date: Sun, 31 Dec 2023 13:21:06 -0500
Subject: [PATCH] Add ProgressAction
---
.../Distribution/Solver/Modular/Message.hs | 80 +++++++++++--------
1 file changed, 46 insertions(+), 34 deletions(-)
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
index 41d0bc80a7..805e424f14 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
@@ -65,13 +65,13 @@ showMessages = go 0
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)
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 $ showOptions 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 (TryP qpn i) ms) = (atLevel l $ showOptions Trying 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 (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms)
@@ -99,7 +99,7 @@ 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 $ formatRejections (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr)
+ (atLevel l $ showOptions Rejecting qpn is ++ showFR c fr)
(go l ms)
-- Handle many subsequent skipped package instances.
@@ -112,9 +112,7 @@ showMessages = go 0
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
goPSkip l qpn is conflicts ms =
- let msg = "skipping: "
- ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is))
- ++ showConflicts conflicts
+ let msg = showOptions Skipping qpn is ++ showConflicts conflicts
in atLevel l msg (go l ms)
-- write a message with the current level number
@@ -123,32 +121,6 @@ showMessages = go 0
let s = show l
in Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs
--- | Format a list of package names and versions as a rejection message,
--- avoiding repetition of the package name.
--- >>> formatRejections ["foo-1.0.0", "foo-1.0.1", "foo-1.0.2"]
--- "rejecting: foo; 1.0.0, 1.0.1, 1.0.2"
--- >>> formatRejections ["foo-1.0.0"]
--- "rejecting: foo-1.0.0"
--- >>> formatRejections ["foo-1.0.0", "bar-1.0.0"]
--- "rejecting: foo-1.0.0, bar-1.0.0"
--- >>> formatRejections []
--- "unexpected rejection set"
-formatRejections :: [String] -> String
-formatRejections [] = "unexpected rejection set"
-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)
- ]
-
-- | Display the set of 'Conflicts' for a skipped package version.
showConflicts :: Set CS.Conflict -> String
showConflicts conflicts =
@@ -234,12 +206,52 @@ data MergedPackageConflict = MergedPackageConflict {
, versionConflict :: Maybe VR
}
-showQPNPOpt :: QPN -> POption -> String
-showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) =
+data ProgressAction =
+ Trying
+ | Skipping
+ | Rejecting
+
+instance Show ProgressAction where
+ show Trying = "trying: "
+ show Skipping = "skipping: "
+ show Rejecting = "rejecting: "
+
+showOptions :: ProgressAction -> QPN -> [POption] -> String
+showOptions a q [p] = show a ++ showOption q p
+showOptions a q ps = show a ++ abbreviatePkgVers (showOption q `map` reverse 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)
+-- | Format a list of package names and versions, avoiding repetition of the
+-- package name.
+-- >>> abbreviatePkgVers ["foo-1.0.0", "foo-1.0.1", "foo-1.0.2"]
+-- "foo; 1.0.0, 1.0.1, 1.0.2"
+-- >>> abbreviatePkgVers ["foo-1.0.0"]
+-- "foo-1.0.0"
+-- >>> abbreviatePkgVers ["foo-1.0.0", "bar-1.0.0"]
+-- "foo-1.0.0, bar-1.0.0"
+-- >>> abbreviatePkgVers []
+-- "unexpected package version set"
+abbreviatePkgVers :: [String] -> String
+abbreviatePkgVers [] = "unexpected package version set"
+abbreviatePkgVers [x] = x
+abbreviatePkgVers xs = 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)
+ ]
+
showGR :: QGoalReason -> String
showGR UserGoal = " (user goal)"
showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")"
--
GitLab