Commit e83ba105 authored by Franz Thoma's avatar Franz Thoma
Browse files

Print conflict counts alongside the conflicts (#3570)

Conflicts are sorted by conflict counts, so high-rated conflicts appear
early in the list. Currently the raw count is printed.
parent 67c89578
......@@ -15,6 +15,7 @@ module Distribution.Solver.Modular.ConflictSet (
, conflictSetOrigin
#endif
, showCS
, showCSWithFrequency
-- Set-like operations
, toList
, union
......@@ -28,11 +29,12 @@ module Distribution.Solver.Modular.ConflictSet (
) where
import Prelude hiding (filter)
import Data.List (intercalate)
import Data.List (intercalate, sortBy)
import Data.Map (Map)
import Data.Set (Set)
import Data.Function (on)
import qualified Data.Set as S
import qualified Data.Map as M
#ifdef DEBUG_CONFLICT_SETS
import Data.Tree
......@@ -75,6 +77,14 @@ instance Ord qpn => Ord (ConflictSet qpn) where
showCS :: ConflictSet QPN -> String
showCS = intercalate ", " . map showVar . toList
showCSWithFrequency :: ConflictMap -> ConflictSet QPN -> String
showCSWithFrequency cm = intercalate ", " . map showWithFrequency . indexByFrequency
where
indexByFrequency = sortBy (flip compare `on` snd) . map (\c -> (c, M.lookup c cm)) . toList
showWithFrequency (conflict, maybeFrequency) = case maybeFrequency of
Just frequency -> showVar conflict ++ " (" ++ show frequency ++ ")"
Nothing -> showVar conflict
{-------------------------------------------------------------------------------
Set-like operations
-------------------------------------------------------------------------------}
......
......@@ -39,25 +39,25 @@ logToProgress mbj l = let
-- and ignores repeated backjumps. If proc reaches the backjump limit, it truncates
-- the 'Progress' and ends it with the last conflict set. Otherwise, it leaves the
-- original success result or replaces the original failure with 'Nothing'.
proc :: Maybe Int -> Log Message b -> Progress Message (Bool, ConflictSet QPN) b
proc :: Maybe Int -> Log Message b -> Progress Message (Bool, ConflictSet QPN, ConflictMap) b
proc _ (Done x) = Done x
proc _ (Fail (cs, _cm)) = Fail (True, cs)
proc _ (Fail (cs, cm)) = Fail (True, cs, cm)
proc mbj' (Step x@(Failure cs Backjump) xs@(Step Leave (Step (Failure cs' Backjump) _)))
| cs == cs' = Step x (proc mbj' xs) -- repeated backjumps count as one
proc (Just 0) (Step (Failure cs Backjump) _) = Fail (False, cs)
proc (Just 0) (Step (Failure cs Backjump) _) = Fail (False, cs, mempty)
proc (Just n) (Step x@(Failure _ Backjump) xs) = Step x (proc (Just (n - 1)) xs)
proc mbj' (Step x xs) = Step x (proc mbj' xs)
-- Sets the conflict set from the first backjump as the final error, and records
-- whether the search was exhaustive.
useFirstError :: Progress Message (Bool, ConflictSet QPN) b
-> Progress Message (Bool, ConflictSet QPN) b
useFirstError :: Progress Message (Bool, ConflictSet QPN, ConflictMap) b
-> Progress Message (Bool, ConflictSet QPN, ConflictMap) b
useFirstError = replace Nothing
where
replace _ (Done x) = Done x
replace cs' (Fail (exh, cs)) = -- 'Nothing' means backjump limit not reached.
replace cs' (Fail (exh, cs, cm)) = -- 'Nothing' means backjump limit not reached.
-- Prefer first error over later error.
Fail (exh, if exh then cs else fromMaybe cs cs')
Fail (exh, if exh then cs else fromMaybe cs cs', cm)
replace Nothing (Step x@(Failure cs Backjump) xs) = Step x $ replace (Just cs) xs
replace cs' (Step x xs) = Step x $ replace cs' xs
......@@ -71,13 +71,13 @@ logToProgress mbj l = let
-- exhaustiveness and first conflict set.
go :: Progress Message a b
-> Progress Message a b
-> Progress String (Bool, ConflictSet QPN) b
-> Progress String (Bool, ConflictSet QPN, ConflictMap) b
-> Progress String String b
go ms (Step _ ns) (Step x xs) = Step x (go ms ns xs)
go ms r (Step x xs) = Step x (go ms r xs)
go ms _ (Fail (exh, cs)) = Fail $ "Could not resolve dependencies:\n" ++ if exh
go ms _ (Fail (exh, cs, cm)) = Fail $ "Could not resolve dependencies:\n" ++ if exh
then "Dependency tree exhaustively searched.\n" ++
"Final conflict set is: " ++ CS.showCS cs
"Final conflict set is: " ++ CS.showCSWithFrequency cm cs
else unlines (messages $ showMessages (L.foldr (\ v _ -> v `CS.member` cs) True) False ms) ++
"Backjump limit reached (" ++ currlimit mbj ++
"change with --max-backjumps or try to run with --reorder-goals).\n"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment