Solver: Only print conflict counts at higher verbosity (fixes haskell#4150).

sebright · ezyang · commit 5cb0408ed3c0 · 2017-02-03T14:13:08.000-08:00
diff --git a/cabal-install/Distribution/Client/Configure.hs b/cabal-install/Distribution/Client/Configure.hs
@@ -362,6 +362,8 @@ planLocalPackage verbosity comp platform configFlags configExFlags
             -- installed package index
         . setSolveExecutables (SolveExecutables False)
 
+        . setSolverVerbosity verbosity
+
         $ standardInstallPolicy
             installedPkgIndex
             -- NB: We pass in an *empty* source package database,
diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs
@@ -56,6 +56,7 @@ module Distribution.Client.Dependency (
     setEnableBackjumping,
     setSolveExecutables,
     setGoalOrder,
+    setSolverVerbosity,
     removeLowerBounds,
     removeUpperBounds,
     addDefaultSetupDependencies,
@@ -106,7 +107,7 @@ import Distribution.Simple.Setup
 import Distribution.Text
          ( display )
 import Distribution.Verbosity
-         ( Verbosity )
+         ( normal, Verbosity )
 import qualified Distribution.Compat.Graph as Graph
 
 import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)
@@ -174,7 +175,8 @@ data DepResolverParams = DepResolverParams {
        depResolverSolveExecutables  :: SolveExecutables,
 
        -- | Function to override the solver's goal-ordering heuristics.
-       depResolverGoalOrder         :: Maybe (Variable QPN -> Variable QPN -> Ordering)
+       depResolverGoalOrder         :: Maybe (Variable QPN -> Variable QPN -> Ordering),
+       depResolverVerbosity         :: Verbosity
      }
 
 showDepResolverParams :: DepResolverParams -> String
@@ -252,7 +254,8 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex =
        depResolverMaxBackjumps      = Nothing,
        depResolverEnableBackjumping = EnableBackjumping True,
        depResolverSolveExecutables  = SolveExecutables True,
-       depResolverGoalOrder         = Nothing
+       depResolverGoalOrder         = Nothing,
+       depResolverVerbosity         = normal
      }
 
 addTargets :: [PackageName]
@@ -353,6 +356,12 @@ setGoalOrder order params =
       depResolverGoalOrder = order
     }
 
+setSolverVerbosity :: Verbosity -> DepResolverParams -> DepResolverParams
+setSolverVerbosity verbosity params =
+    params {
+      depResolverVerbosity = verbosity
+    }
+
 -- | Some packages are specific to a given compiler version and should never be
 -- upgraded.
 dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams
@@ -663,7 +672,7 @@ resolveDependencies platform comp pkgConfigDB solver params =
   $ runSolver solver (SolverConfig reordGoals cntConflicts
                       indGoals noReinstalls
                       shadowing strFlags allowBootLibs maxBkjumps enableBj
-                      solveExes order)
+                      solveExes order verbosity)
                      platform comp installedPkgIndex sourcePkgIndex
                      pkgConfigDB preferences constraints targets
   where
@@ -683,9 +692,11 @@ resolveDependencies platform comp pkgConfigDB solver params =
       maxBkjumps
       enableBj
       solveExes
-      order) = if asBool (depResolverAllowBootLibInstalls params)
-               then params
-               else dontUpgradeNonUpgradeablePackages params
+      order
+      verbosity) =
+        if asBool (depResolverAllowBootLibInstalls params)
+        then params
+        else dontUpgradeNonUpgradeablePackages params
 
     preferences = interpretPackagesPreference targets defpref prefs
 
@@ -911,7 +922,7 @@ resolveWithoutDependencies (DepResolverParams targets constraints
                               prefs defpref installedPkgIndex sourcePkgIndex
                               _reorderGoals _countConflicts _indGoals _avoidReinstalls
                               _shadowing _strFlags _maxBjumps _enableBj
-                              _solveExes _allowBootLibInstalls _order) =
+                              _solveExes _allowBootLibInstalls _order _verbosity) =
     collectEithers $ map selectPackage (Set.toList targets)
   where
     selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage
diff --git a/cabal-install/Distribution/Client/Fetch.hs b/cabal-install/Distribution/Client/Fetch.hs
@@ -166,6 +166,8 @@ planPackages verbosity comp platform fetchFlags
 
       . setAllowBootLibInstalls allowBootLibInstalls
 
+      . setSolverVerbosity verbosity
+
         -- Reinstall the targets given on the command line so that the dep
         -- resolver will decide that they need fetching, even if they're
         -- already installed. Since we want to get the source packages of
diff --git a/cabal-install/Distribution/Client/Freeze.hs b/cabal-install/Distribution/Client/Freeze.hs
@@ -181,6 +181,8 @@ planPackages verbosity comp platform mSandboxPkgInfo freezeFlags
 
       . setAllowBootLibInstalls allowBootLibInstalls
 
+      . setSolverVerbosity verbosity
+
       . addConstraints
           [ let pkg = pkgSpecifierTarget pkgSpecifier
                 pc = PackageConstraint (scopeToplevel pkg)
diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs
@@ -320,7 +320,7 @@ makeInstallPlan verbosity
     solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))
               (compilerInfo comp)
     notice verbosity "Resolving dependencies..."
-    return $ planPackages comp platform mSandboxPkgInfo solver
+    return $ planPackages verbosity comp platform mSandboxPkgInfo solver
           configFlags configExFlags installFlags
           installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers
 
@@ -349,7 +349,8 @@ processInstallPlan verbosity
 -- * Installation planning
 -- ------------------------------------------------------------
 
-planPackages :: Compiler
+planPackages :: Verbosity
+             -> Compiler
              -> Platform
              -> Maybe SandboxPackageInfo
              -> Solver
@@ -361,7 +362,7 @@ planPackages :: Compiler
              -> PkgConfigDb
              -> [PackageSpecifier UnresolvedSourcePackage]
              -> Progress String String SolverInstallPlan
-planPackages comp platform mSandboxPkgInfo solver
+planPackages verbosity comp platform mSandboxPkgInfo solver
              configFlags configExFlags installFlags
              installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers =
 
@@ -392,6 +393,8 @@ planPackages comp platform mSandboxPkgInfo solver
 
       . setAllowBootLibInstalls allowBootLibInstalls
 
+      . setSolverVerbosity verbosity
+
       . setPreferenceDefault (if upgradeDeps then PreferAllLatest
                                              else PreferLatestForSelected)
 
diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs
@@ -517,7 +517,7 @@ rebuildInstallPlan verbosity
 
             notice verbosity "Resolving dependencies..."
             plan <- foldProgress logMsg die return $
-              planPackages compiler platform solver solverSettings
+              planPackages verbosity compiler platform solver solverSettings
                            installedPkgIndex sourcePkgDb pkgConfigDB
                            localPackages localPackagesEnabledStanzas
             return (plan, pkgConfigDB)
@@ -894,7 +894,8 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do
 -- * Installation planning
 -- ------------------------------------------------------------
 
-planPackages :: Compiler
+planPackages :: Verbosity
+             -> Compiler
              -> Platform
              -> Solver -> SolverSettings
              -> InstalledPackageIndex
@@ -903,7 +904,7 @@ planPackages :: Compiler
              -> [UnresolvedSourcePackage]
              -> Map PackageName (Map OptionalStanza Bool)
              -> Progress String String SolverInstallPlan
-planPackages comp platform solver SolverSettings{..}
+planPackages verbosity comp platform solver SolverSettings{..}
              installedPkgIndex sourcePkgDb pkgConfigDB
              localPackages pkgStanzasEnable =
 
@@ -937,6 +938,8 @@ planPackages comp platform solver SolverSettings{..}
 
       . setAllowBootLibInstalls solverSettingAllowBootLibInstalls
 
+      . setSolverVerbosity verbosity
+
         --TODO: [required eventually] decide if we need to prefer installed for
         -- global packages, or prefer latest even for global packages. Perhaps
         -- should be configurable but with a different name than "upgrade-dependencies".
diff --git a/cabal-install/Distribution/Solver/Modular.hs b/cabal-install/Distribution/Solver/Modular.hs
@@ -39,8 +39,8 @@ import Distribution.System
 -- solver. Performs the necessary translations before and after.
 modularResolver :: SolverConfig -> DependencyResolver loc
 modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns =
-  fmap (uncurry postprocess)      $ -- convert install plan
-  logToProgress (maxBackjumps sc) $ -- convert log format into progress format
+  fmap (uncurry postprocess)                           $ -- convert install plan
+  logToProgress (solverVerbosity sc) (maxBackjumps sc) $ -- convert log format into progress format
   solve sc cinfo idx pkgConfigDB pprefs gcs pns
     where
       -- Indices have to be converted into solver-specific uniform index.
diff --git a/cabal-install/Distribution/Solver/Modular/ConflictSet.hs b/cabal-install/Distribution/Solver/Modular/ConflictSet.hs
@@ -14,7 +14,8 @@ module Distribution.Solver.Modular.ConflictSet (
 #ifdef DEBUG_CONFLICT_SETS
   , conflictSetOrigin
 #endif
-  , showCS
+  , showConflictSet
+  , showCSSortedByFrequency
   , showCSWithFrequency
     -- Set-like operations
   , toList
@@ -74,16 +75,24 @@ instance Eq ConflictSet where
 instance Ord ConflictSet where
   compare = compare `on` conflictSetToSet
 
-showCS :: ConflictSet -> String
-showCS = intercalate ", " . map showVar . toList
+showConflictSet :: ConflictSet -> String
+showConflictSet = intercalate ", " . map showVar . toList
+
+showCSSortedByFrequency :: ConflictMap -> ConflictSet -> String
+showCSSortedByFrequency = showCS False
 
 showCSWithFrequency :: ConflictMap -> ConflictSet -> String
-showCSWithFrequency cm = intercalate ", " . map showWithFrequency . indexByFrequency
+showCSWithFrequency = showCS True
+
+showCS :: Bool -> ConflictMap -> ConflictSet -> String
+showCS showCount 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
+      Just frequency
+        | showCount -> showVar conflict ++ " (" ++ show frequency ++ ")"
+      _             -> showVar conflict
 
 {-------------------------------------------------------------------------------
   Set-like operations
diff --git a/cabal-install/Distribution/Solver/Modular/Dependency.hs b/cabal-install/Distribution/Solver/Modular/Dependency.hs
@@ -13,7 +13,7 @@ module Distribution.Solver.Modular.Dependency (
     -- * Conflict sets
   , ConflictSet
   , ConflictMap
-  , CS.showCS
+  , CS.showConflictSet
     -- * Constrained instances
   , CI(..)
   , merge
diff --git a/cabal-install/Distribution/Solver/Modular/Log.hs b/cabal-install/Distribution/Solver/Modular/Log.hs
@@ -14,6 +14,7 @@ import Distribution.Solver.Modular.Dependency
 import Distribution.Solver.Modular.Message
 import Distribution.Solver.Modular.Tree (FailReason(..))
 import qualified Distribution.Solver.Modular.ConflictSet as CS
+import Distribution.Verbosity
 
 -- | The 'Log' datatype.
 --
@@ -30,12 +31,12 @@ 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 = proc mbj l
-                      in go es es -- trace for first error
-                            (showMessages (const True) True ms) -- run with backjump limit applied
+logToProgress :: Verbosity -> Maybe Int -> Log Message a -> Progress String String a
+logToProgress verbosity mbj l =
+    let es = proc (Just 0) l -- catch first error (always)
+        ms = proc mbj l
+    in go es es -- trace for first error
+          (showMessages (const True) True ms) -- run with backjump limit applied
   where
     -- Proc takes the allowed number of backjumps and a 'Progress' and explores the
     -- messages until the maximum number of backjumps has been reached. It filters out
@@ -73,7 +74,11 @@ logToProgress mbj l = let
             Exhaustive ->
                 "After searching the rest of the dependency tree exhaustively, "
                 ++ "these were the goals I've had most trouble fulfilling: "
-                ++ CS.showCSWithFrequency cm cs
+                ++ showCS cm cs
+              where
+                showCS = if verbosity > normal
+                         then CS.showCSWithFrequency
+                         else CS.showCSSortedByFrequency
             BackjumpLimitReached ->
                 "Backjump limit reached (" ++ currlimit mbj ++
                 "change with --max-backjumps or try to run with --reorder-goals).\n"
diff --git a/cabal-install/Distribution/Solver/Modular/Message.hs b/cabal-install/Distribution/Solver/Modular/Message.hs
@@ -140,10 +140,10 @@ showFR _ (GlobalConstraintInstalled src)  = " (" ++ constraintSource src ++ " re
 showFR _ (GlobalConstraintSource src)     = " (" ++ constraintSource src ++ " requires source instance)"
 showFR _ (GlobalConstraintFlag src)       = " (" ++ constraintSource src ++ " requires opposite flag selection)"
 showFR _ ManualFlag                       = " (manual flag can only be changed explicitly)"
-showFR c Backjump                         = " (backjumping, conflict set: " ++ showCS c ++ ")"
+showFR c Backjump                         = " (backjumping, conflict set: " ++ showConflictSet c ++ ")"
 showFR _ MultipleInstances                = " (multiple instances)"
-showFR c (DependenciesNotLinked msg)      = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showCS c ++ ")"
-showFR c CyclicDependencies               = " (cyclic dependencies; conflict set: " ++ showCS c ++ ")"
+showFR c (DependenciesNotLinked msg)      = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")"
+showFR c CyclicDependencies               = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")"
 -- The following are internal failures. They should not occur. In the
 -- interest of not crashing unnecessarily, we still just print an error
 -- message though.
diff --git a/cabal-install/Distribution/Solver/Modular/Solver.hs b/cabal-install/Distribution/Solver/Modular/Solver.hs
@@ -11,6 +11,7 @@ module Distribution.Solver.Modular.Solver
 import Data.Map as M
 import Data.List as L
 import Data.Set as S
+import Distribution.Verbosity
 import Distribution.Version
 
 import Distribution.Compiler (CompilerInfo)
@@ -64,7 +65,8 @@ data SolverConfig = SolverConfig {
   maxBackjumps          :: Maybe Int,
   enableBackjumping     :: EnableBackjumping,
   solveExecutables      :: SolveExecutables,
-  goalOrder             :: Maybe (Variable QPN -> Variable QPN -> Ordering)
+  goalOrder             :: Maybe (Variable QPN -> Variable QPN -> Ordering),
+  solverVerbosity       :: Verbosity
 }
 
 -- | Run all solver phases.
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
@@ -189,6 +189,12 @@ tests = [
                          && length (filter ("trying: A" `isInfixOf`) lg) == 1
               in mkTest db "deduplicate targets" ["A", "A"] $
                  SolverResult p $ Right [("A", 1)]
+        , runTest $
+              let db = [Right $ exAv "A" 1 [ExAny "B"]]
+                  msg = "After searching the rest of the dependency tree exhaustively, "
+                     ++ "these were the goals I've had most trouble fulfilling: A, B"
+              in mkTest db "exhaustive search failure message" ["A"] $
+                 solverFailure (isInfixOf msg)
         ]
     ]
   where
