Skip to content

Commit 1b8f375

Browse files
grayjaygrayjay
authored
Merge pull request #3960 from fmthoma/fmthoma/print-conflict-set
Print final conflict set when search is exhaustive
2 parents a6e4b59 + 4dabd28 commit 1b8f375

File tree

4 files changed

+56
-45
lines changed

4 files changed

+56
-45
lines changed

‎cabal-install/Distribution/Solver/Modular/ConflictSet.hs

Lines changed: 16 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -10,10 +10,12 @@
1010
-- > import qualified Distribution.Solver.Modular.ConflictSet as CS
1111
module Distribution.Solver.Modular.ConflictSet (
1212
ConflictSet -- opaque
13+
, ConflictMap
1314
#ifdef DEBUG_CONFLICT_SETS
1415
, conflictSetOrigin
1516
#endif
1617
, showCS
18+
, showCSWithFrequency
1719
-- Set-like operations
1820
, toList
1921
, union
@@ -27,10 +29,12 @@ module Distribution.Solver.Modular.ConflictSet (
2729
) where
2830

2931
import Prelude hiding (filter)
30-
import Data.List (intercalate)
32+
import Data.List (intercalate, sortBy)
33+
import Data.Map (Map)
3134
import Data.Set (Set)
3235
import Data.Function (on)
3336
import qualified Data.Set as S
37+
import qualified Data.Map as M
3438

3539
#ifdef DEBUG_CONFLICT_SETS
3640
import Data.Tree
@@ -73,6 +77,14 @@ instance Ord qpn => Ord (ConflictSet qpn) where
7377
showCS :: ConflictSet QPN -> String
7478
showCS = intercalate ", " . map showVar . toList
7579

80+
showCSWithFrequency :: ConflictMap -> ConflictSet QPN -> String
81+
showCSWithFrequency cm = intercalate ", " . map showWithFrequency . indexByFrequency
82+
where
83+
indexByFrequency = sortBy (flip compare `on` snd) . map (\c -> (c, M.lookup c cm)) . toList
84+
showWithFrequency (conflict, maybeFrequency) = case maybeFrequency of
85+
Just frequency -> showVar conflict ++ " (" ++ show frequency ++ ")"
86+
Nothing -> showVar conflict
87+
7688
{-------------------------------------------------------------------------------
7789
Set-like operations
7890
-------------------------------------------------------------------------------}
@@ -169,3 +181,6 @@ fromList vars = CS {
169181
, conflictSetOrigin = Node ?loc []
170182
#endif
171183
}
184+
185+
type ConflictMap = Map (Var QPN) Int
186+

‎cabal-install/Distribution/Solver/Modular/Dependency.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ module Distribution.Solver.Modular.Dependency (
1212
, showVar
1313
-- * Conflict sets
1414
, ConflictSet
15+
, ConflictMap
1516
, CS.showCS
1617
-- * Constrained instances
1718
, CI(..)
@@ -53,7 +54,7 @@ import Language.Haskell.Extension (Extension(..), Language(..))
5354

5455
import Distribution.Text
5556

56-
import Distribution.Solver.Modular.ConflictSet (ConflictSet)
57+
import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap)
5758
import Distribution.Solver.Modular.Flag
5859
import Distribution.Solver.Modular.Package
5960
import Distribution.Solver.Modular.Var

‎cabal-install/Distribution/Solver/Modular/Explore.hs

Lines changed: 1 addition & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -68,8 +68,6 @@ backjump (EnableBackjumping enableBj) var initial xs =
6868

6969
type ConflictSetLog = RetryLog Message (ConflictSet QPN, ConflictMap)
7070

71-
type ConflictMap = Map (Var QPN) Int
72-
7371
getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a)
7472
getBestGoal cm =
7573
P.maximumBy
@@ -174,7 +172,4 @@ backjumpAndExplore :: EnableBackjumping
174172
-> CountConflicts
175173
-> Tree d QGoalReason -> Log Message (Assignment, RevDepMap)
176174
backjumpAndExplore enableBj countConflicts =
177-
toLog . exploreLog enableBj countConflicts . assign
178-
where
179-
toLog :: RetryLog step fail done -> Log step done
180-
toLog = toProgress . mapFailure (const ())
175+
toProgress . exploreLog enableBj countConflicts . assign

‎cabal-install/Distribution/Solver/Modular/Log.hs

Lines changed: 37 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -3,9 +3,10 @@ module Distribution.Solver.Modular.Log
33
, logToProgress
44
) where
55

6-
import Control.Applicative
6+
import Prelude ()
7+
import Distribution.Client.Compat.Prelude
8+
79
import Data.List as L
8-
import Data.Maybe (isNothing)
910

1011
import Distribution.Solver.Types.PackagePath
1112
import Distribution.Solver.Types.Progress
@@ -20,69 +21,68 @@ import qualified Distribution.Solver.Modular.ConflictSet as CS
2021
-- Represents the progress of a computation lazily.
2122
--
2223
-- Parameterized over the type of actual messages and the final result.
23-
type Log m a = Progress m () a
24+
type Log m a = Progress m (ConflictSet QPN, ConflictMap) a
2425

2526
messages :: Progress step fail done -> [step]
2627
messages = foldProgress (:) (const []) (const [])
2728

29+
data Exhaustiveness = Exhaustive | BackjumpLimitReached
30+
2831
-- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps.
2932
-- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the
3033
-- limit is 'Just 0', backtracking is completely disabled.
3134
logToProgress :: Maybe Int -> Log Message a -> Progress String String a
3235
logToProgress mbj l = let
3336
es = proc (Just 0) l -- catch first error (always)
34-
ms = useFirstError (proc mbj l)
37+
ms = proc mbj l
3538
in go es es -- trace for first error
3639
(showMessages (const True) True ms) -- run with backjump limit applied
3740
where
3841
-- Proc takes the allowed number of backjumps and a 'Progress' and explores the
3942
-- messages until the maximum number of backjumps has been reached. It filters out
4043
-- and ignores repeated backjumps. If proc reaches the backjump limit, it truncates
4144
-- the 'Progress' and ends it with the last conflict set. Otherwise, it leaves the
42-
-- original success result or replaces the original failure with 'Nothing'.
43-
proc :: Maybe Int -> Progress Message a b -> Progress Message (Maybe (ConflictSet QPN)) b
45+
-- original result.
46+
proc :: Maybe Int -> Log Message b -> Progress Message (Exhaustiveness, ConflictSet QPN, ConflictMap) b
4447
proc _ (Done x) = Done x
45-
proc _ (Fail _) = Fail Nothing
48+
proc _ (Fail (cs, cm)) = Fail (Exhaustive, cs, cm)
4649
proc mbj' (Step x@(Failure cs Backjump) xs@(Step Leave (Step (Failure cs' Backjump) _)))
4750
| cs == cs' = Step x (proc mbj' xs) -- repeated backjumps count as one
48-
proc (Just 0) (Step (Failure cs Backjump) _) = Fail (Just cs)
51+
proc (Just 0) (Step (Failure cs Backjump) _) = Fail (BackjumpLimitReached, cs, mempty) -- No final conflict map available
4952
proc (Just n) (Step x@(Failure _ Backjump) xs) = Step x (proc (Just (n - 1)) xs)
5053
proc mbj' (Step x xs) = Step x (proc mbj' xs)
5154

52-
-- Sets the conflict set from the first backjump as the final error, and records
53-
-- whether the search was exhaustive.
54-
useFirstError :: Progress Message (Maybe (ConflictSet QPN)) b
55-
-> Progress Message (Bool, Maybe (ConflictSet QPN)) b
56-
useFirstError = replace Nothing
57-
where
58-
replace _ (Done x) = Done x
59-
replace cs' (Fail cs) = -- 'Nothing' means backjump limit not reached.
60-
-- Prefer first error over later error.
61-
Fail (isNothing cs, cs' <|> cs)
62-
replace Nothing (Step x@(Failure cs Backjump) xs) = Step x $ replace (Just cs) xs
63-
replace cs' (Step x xs) = Step x $ replace cs' xs
64-
6555
-- The first two arguments are both supposed to be the log up to the first error.
6656
-- That's the error that will always be printed in case we do not find a solution.
6757
-- We pass this log twice, because we evaluate it in parallel with the full log,
6858
-- but we also want to retain the reference to its beginning for when we print it.
6959
-- This trick prevents a space leak!
7060
--
7161
-- The third argument is the full log, ending with either the solution or the
72-
-- exhaustiveness and first conflict set.
73-
go :: Progress Message a b
74-
-> Progress Message a b
75-
-> Progress String (Bool, Maybe (ConflictSet QPN)) b
62+
-- exhaustiveness and final conflict set.
63+
go :: Progress Message (Exhaustiveness, ConflictSet QPN, ConflictMap) b
64+
-> Progress Message (Exhaustiveness, ConflictSet QPN, ConflictMap) b
65+
-> Progress String (Exhaustiveness, ConflictSet QPN, ConflictMap) b
7666
-> Progress String String b
77-
go ms (Step _ ns) (Step x xs) = Step x (go ms ns xs)
78-
go ms r (Step x xs) = Step x (go ms r xs)
79-
go ms _ (Fail (exh, Just cs)) = Fail $
80-
"Could not resolve dependencies:\n" ++
81-
unlines (messages $ showMessages (L.foldr (\ v _ -> v `CS.member` cs) True) False ms) ++
82-
(if exh then "Dependency tree exhaustively searched.\n"
83-
else "Backjump limit reached (" ++ currlimit mbj ++
84-
"change with --max-backjumps or try to run with --reorder-goals).\n")
85-
where currlimit (Just n) = "currently " ++ show n ++ ", "
86-
currlimit Nothing = ""
87-
go _ _ (Done s) = Done s
88-
go _ _ (Fail (_, Nothing)) = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen
67+
go ms (Step _ ns) (Step x xs) = Step x (go ms ns xs)
68+
go ms r (Step x xs) = Step x (go ms r xs)
69+
go ms (Step _ ns) r = go ms ns r
70+
go ms (Fail (_, cs', _)) (Fail (exh, cs, cm)) = Fail $
71+
"Could not resolve dependencies:\n" ++
72+
unlines (messages $ showMessages (L.foldr (\ v _ -> v `CS.member` cs') True) False ms) ++
73+
case exh of
74+
Exhaustive ->
75+
"After searching the rest of the dependency tree exhaustively, "
76+
++ "these were the goals I've had most trouble fulfilling: "
77+
++ CS.showCSWithFrequency cm cs
78+
BackjumpLimitReached ->
79+
"Backjump limit reached (" ++ currlimit mbj ++
80+
"change with --max-backjumps or try to run with --reorder-goals).\n"
81+
where currlimit (Just n) = "currently " ++ show n ++ ", "
82+
currlimit Nothing = ""
83+
go _ _ (Done s) = Done s
84+
go _ (Done _) (Fail _) = Fail $
85+
-- Should not happen: Second argument is the log up to first error,
86+
-- third one is the entire log. Therefore it should never happen that
87+
-- the second log finishes with 'Done' and the third log with 'Fail'.
88+
"Could not resolve dependencies; something strange happened."

0 commit comments

Comments
 (0)