Commit 1b8f375a authored by kristenk's avatar kristenk Committed by GitHub
Browse files

Merge pull request #3960 from fmthoma/fmthoma/print-conflict-set

Print final conflict set when search is exhaustive
parents a6e4b59a 4dabd287
......@@ -10,10 +10,12 @@
-- > import qualified Distribution.Solver.Modular.ConflictSet as CS
module Distribution.Solver.Modular.ConflictSet (
ConflictSet -- opaque
, ConflictMap
#ifdef DEBUG_CONFLICT_SETS
, conflictSetOrigin
#endif
, showCS
, showCSWithFrequency
-- Set-like operations
, toList
, union
......@@ -27,10 +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
......@@ -73,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
-------------------------------------------------------------------------------}
......@@ -169,3 +181,6 @@ fromList vars = CS {
, conflictSetOrigin = Node ?loc []
#endif
}
type ConflictMap = Map (Var QPN) Int
......@@ -12,6 +12,7 @@ module Distribution.Solver.Modular.Dependency (
, showVar
-- * Conflict sets
, ConflictSet
, ConflictMap
, CS.showCS
-- * Constrained instances
, CI(..)
......@@ -53,7 +54,7 @@ import Language.Haskell.Extension (Extension(..), Language(..))
import Distribution.Text
import Distribution.Solver.Modular.ConflictSet (ConflictSet)
import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap)
import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.Var
......
......@@ -68,8 +68,6 @@ backjump (EnableBackjumping enableBj) var initial xs =
type ConflictSetLog = RetryLog Message (ConflictSet QPN, ConflictMap)
type ConflictMap = Map (Var QPN) Int
getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a)
getBestGoal cm =
P.maximumBy
......@@ -174,7 +172,4 @@ backjumpAndExplore :: EnableBackjumping
-> CountConflicts
-> Tree d QGoalReason -> Log Message (Assignment, RevDepMap)
backjumpAndExplore enableBj countConflicts =
toLog . exploreLog enableBj countConflicts . assign
where
toLog :: RetryLog step fail done -> Log step done
toLog = toProgress . mapFailure (const ())
toProgress . exploreLog enableBj countConflicts . assign
......@@ -3,9 +3,10 @@ module Distribution.Solver.Modular.Log
, logToProgress
) where
import Control.Applicative
import Prelude ()
import Distribution.Client.Compat.Prelude
import Data.List as L
import Data.Maybe (isNothing)
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.Progress
......@@ -20,18 +21,20 @@ import qualified Distribution.Solver.Modular.ConflictSet as CS
-- Represents the progress of a computation lazily.
--
-- Parameterized over the type of actual messages and the final result.
type Log m a = Progress m () a
type Log m a = Progress m (ConflictSet QPN, ConflictMap) a
messages :: Progress step fail done -> [step]
messages = foldProgress (:) (const []) (const [])
data Exhaustiveness = Exhaustive | BackjumpLimitReached
-- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps.
-- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the
-- limit is 'Just 0', backtracking is completely disabled.
logToProgress :: Maybe Int -> Log Message a -> Progress String String a
logToProgress mbj l = let
es = proc (Just 0) l -- catch first error (always)
ms = useFirstError (proc mbj l)
ms = proc mbj l
in go es es -- trace for first error
(showMessages (const True) True ms) -- run with backjump limit applied
where
......@@ -39,29 +42,16 @@ logToProgress mbj l = let
-- messages until the maximum number of backjumps has been reached. It filters out
-- 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 -> Progress Message a b -> Progress Message (Maybe (ConflictSet QPN)) b
-- original result.
proc :: Maybe Int -> Log Message b -> Progress Message (Exhaustiveness, ConflictSet QPN, ConflictMap) b
proc _ (Done x) = Done x
proc _ (Fail _) = Fail Nothing
proc _ (Fail (cs, cm)) = Fail (Exhaustive, 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 (Just cs)
proc (Just 0) (Step (Failure cs Backjump) _) = Fail (BackjumpLimitReached, cs, mempty) -- No final conflict map available
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 (Maybe (ConflictSet QPN)) b
-> Progress Message (Bool, Maybe (ConflictSet QPN)) b
useFirstError = replace Nothing
where
replace _ (Done x) = Done x
replace cs' (Fail cs) = -- 'Nothing' means backjump limit not reached.
-- Prefer first error over later error.
Fail (isNothing cs, cs' <|> cs)
replace Nothing (Step x@(Failure cs Backjump) xs) = Step x $ replace (Just cs) xs
replace cs' (Step x xs) = Step x $ replace cs' xs
-- The first two arguments are both supposed to be the log up to the first error.
-- That's the error that will always be printed in case we do not find a solution.
-- We pass this log twice, because we evaluate it in parallel with the full log,
......@@ -69,20 +59,30 @@ logToProgress mbj l = let
-- This trick prevents a space leak!
--
-- The third argument is the full log, ending with either the solution or the
-- exhaustiveness and first conflict set.
go :: Progress Message a b
-> Progress Message a b
-> Progress String (Bool, Maybe (ConflictSet QPN)) b
-- exhaustiveness and final conflict set.
go :: Progress Message (Exhaustiveness, ConflictSet QPN, ConflictMap) b
-> Progress Message (Exhaustiveness, ConflictSet QPN, ConflictMap) b
-> Progress String (Exhaustiveness, 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, Just cs)) = Fail $
"Could not resolve dependencies:\n" ++
unlines (messages $ showMessages (L.foldr (\ v _ -> v `CS.member` cs) True) False ms) ++
(if exh then "Dependency tree exhaustively searched.\n"
else "Backjump limit reached (" ++ currlimit mbj ++
"change with --max-backjumps or try to run with --reorder-goals).\n")
where currlimit (Just n) = "currently " ++ show n ++ ", "
currlimit Nothing = ""
go _ _ (Done s) = Done s
go _ _ (Fail (_, Nothing)) = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen
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 (Step _ ns) r = go ms ns r
go ms (Fail (_, cs', _)) (Fail (exh, cs, cm)) = Fail $
"Could not resolve dependencies:\n" ++
unlines (messages $ showMessages (L.foldr (\ v _ -> v `CS.member` cs') True) False ms) ++
case exh of
Exhaustive ->
"After searching the rest of the dependency tree exhaustively, "
++ "these were the goals I've had most trouble fulfilling: "
++ CS.showCSWithFrequency cm cs
BackjumpLimitReached ->
"Backjump limit reached (" ++ currlimit mbj ++
"change with --max-backjumps or try to run with --reorder-goals).\n"
where currlimit (Just n) = "currently " ++ show n ++ ", "
currlimit Nothing = ""
go _ _ (Done s) = Done s
go _ (Done _) (Fail _) = Fail $
-- Should not happen: Second argument is the log up to first error,
-- third one is the entire log. Therefore it should never happen that
-- the second log finishes with 'Done' and the third log with 'Fail'.
"Could not resolve dependencies; something strange happened."
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