[commit: packages/Cabal] ghc-head: On failure, report whether solver search was exhaustive. (b57c7e0)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/Cabal

On branch  : ghc-head
Link       : http://git.haskell.org/?p=packages/Cabal.git;a=commit;h=b57c7e02f841ad38fa7c944ac404bf3b0b96c499

>---------------------------------------------------------------

commit b57c7e02f841ad38fa7c944ac404bf3b0b96c499
Author: Andres Loeh <andres at well-typed.com>
Date:   Fri May 3 14:39:31 2013 +0200

    On failure, report whether solver search was exhaustive.


>---------------------------------------------------------------

b57c7e02f841ad38fa7c944ac404bf3b0b96c499
 .../Distribution/Client/Dependency/Modular/Log.hs  |   33 +++++++++++++-------
 1 file changed, 21 insertions(+), 12 deletions(-)

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Log.hs b/cabal-install/Distribution/Client/Dependency/Modular/Log.hs
index 3bfe6a9..d71aab8 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Log.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Log.hs
@@ -36,19 +36,24 @@ runLog (Step m p)     = let
 logToProgress :: Maybe Int -> Log Message a -> Progress String String a
 logToProgress mbj l = let
                         (ms, s) = runLog l
+                        -- 'Nothing' for 's' means search tree exhaustively searched and failed
                         (es, e) = proc 0 ms -- catch first error (always)
+                        -- 'Nothing' in 'e' means no backjump found
                         (ns, t) = case mbj of
                                      Nothing -> (ms, Nothing)
                                      Just n  -> proc n ms
+                        -- 'Nothing' in 't' means backjump limit not reached
                         -- prefer first error over later error
-                        r       = case t of
-                                    Nothing -> case s of
-                                                 Nothing -> e
-                                                 Just _  -> Nothing
-                                    Just _  -> e
+                        (exh, r) = case t of
+                                     -- backjump limit not reached
+                                     Nothing -> case s of
+                                                  Nothing -> (True, e) -- failed after exhaustive search
+                                                  Just _  -> (True, Nothing) -- success
+                                     -- backjump limit reached; prefer first error
+                                     Just _  -> (False, e) -- failed after backjump limit was reached
                       in go es es -- trace for first error
                             (showMessages (const True) True ns) -- shortened run
-                            r s
+                            r s exh
   where
     -- Proc takes the allowed number of backjumps and a list of messages and explores the
     -- message list until the maximum number of backjumps has been reached. The log until
@@ -68,17 +73,21 @@ logToProgress mbj l = let
     -- beginning for when we print it. This trick prevents a space leak!
     --
     -- The third argument is the full log, the fifth and six error conditions.
+    -- The seventh argument indicates whether the search was exhaustive.
     --
     -- The order of arguments is important! In particular 's' must not be evaluated
     -- unless absolutely necessary. It contains the final result, and if we shortcut
     -- with an error due to backjumping, evaluating 's' would still require traversing
     -- the entire tree.
-    go ms (_ : ns) (x : xs) r         s        = Step x (go ms ns xs r s)
-    go ms []       (x : xs) r         s        = Step x (go ms [] xs r s)
-    go ms _        []       (Just cs) _        = Fail ("Could not resolve dependencies:\n" ++
-                                                 unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms))
-    go _  _        []       _         (Just s) = Done s
-    go _  _        []       _         _        = Fail ("Could not resolve dependencies.") -- should not happen
+    go ms (_ : ns) (x : xs) r         s        exh = Step x (go ms ns xs r s exh)
+    go ms []       (x : xs) r         s        exh = Step x (go ms [] xs r s exh)
+    go ms _        []       (Just cs) _        exh = Fail $
+                                                     "Could not resolve dependencies:\n" ++
+                                                     unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms) ++
+                                                     (if exh then "Dependency tree exhaustively searched.\n"
+                                                             else "Backjump limit reached (change with --max-backjumps).\n")
+    go _  _        []       _         (Just s) _   = Done s
+    go _  _        []       _         _        _   = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen
 
 logToProgress' :: Log Message a -> Progress String String a
 logToProgress' l = let