Refactor cabal-install solver config log output

Includes:

* Apply some of @grayjay and @mpickering comments
* Fix #4251

Co-Authored-By: Erik de Castro Lopo <[email protected]>

Author: yvan-sraka

cabal-install-solver/src/Distribution/Solver/Modular.hs

@@ -18,43 +18,60 @@ import Distribution.Solver.Compat.Prelude
 import qualified Data.Map as M
 import Data.Set (isSubsetOf)
 import Distribution.Compat.Graph
-         ( IsNode(..) )
+    ( IsNode(..) )
 import Distribution.Compiler
-         ( CompilerInfo )
+    ( CompilerInfo )
 import Distribution.Solver.Modular.Assignment
-         ( Assignment, toCPs )
+    ( Assignment, toCPs )
 import Distribution.Solver.Modular.ConfiguredConversion
-         ( convCP )
+    ( convCP )
 import qualified Distribution.Solver.Modular.ConflictSet as CS
 import Distribution.Solver.Modular.Dependency
-import Distribution.Solver.Modular.Flag
-import Distribution.Solver.Modular.Index
+    ( Var(..),
+      showVar,
+      ConflictMap,
+      ConflictSet,
+      showConflictSet,
+      RevDepMap )
+import Distribution.Solver.Modular.Flag ( SN(SN), FN(FN) )
+import Distribution.Solver.Modular.Index ( Index )
 import Distribution.Solver.Modular.IndexConversion
-         ( convPIs )
+    ( convPIs )
 import Distribution.Solver.Modular.Log
-         ( SolverFailure(..), displayLogMessages )
+    ( SolverFailure(..), displayLogMessages )
 import Distribution.Solver.Modular.Package
-         ( PN )
+    ( PN )
 import Distribution.Solver.Modular.RetryLog
+    ( RetryLog,
+      toProgress,
+      fromProgress,
+      retry,
+      failWith,
+      continueWith )
 import Distribution.Solver.Modular.Solver
-         ( SolverConfig(..), PruneAfterFirstSuccess(..), solve )
+    ( SolverConfig(..), PruneAfterFirstSuccess(..), solve )
 import Distribution.Solver.Types.DependencyResolver
+    ( DependencyResolver )
 import Distribution.Solver.Types.LabeledPackageConstraint
+    ( LabeledPackageConstraint, unlabelPackageConstraint )
 import Distribution.Solver.Types.PackageConstraint
-import Distribution.Solver.Types.PackagePath
+    ( PackageConstraint(..), scopeToPackageName )
+import Distribution.Solver.Types.PackagePath ( QPN )
 import Distribution.Solver.Types.PackagePreferences
+    ( PackagePreferences )
 import Distribution.Solver.Types.PkgConfigDb
-         ( PkgConfigDb )
+    ( PkgConfigDb )
 import Distribution.Solver.Types.Progress
-import Distribution.Solver.Types.Variable
+    ( Progress(..), foldProgress, SummarizedMessage(ErrorMsg) )
+import Distribution.Solver.Types.Variable ( Variable(..) )
 import Distribution.System
-         ( Platform(..) )
+    ( Platform(..) )
 import Distribution.Simple.Setup
-         ( BooleanFlag(..) )
+    ( BooleanFlag(..) )
 import Distribution.Simple.Utils
-         ( ordNubBy )
-import Distribution.Verbosity
-
+    ( ordNubBy )
+import Distribution.Verbosity ( normal, verbose )
+import Distribution.Solver.Modular.Message ( renderSummarizedMessage )
 
 -- | Ties the two worlds together: classic cabal-install vs. the modular
 -- solver. Performs the necessary translations before and after.
@@ -120,25 +137,25 @@ solve' :: SolverConfig
        -> (PN -> PackagePreferences)
        -> Map PN [LabeledPackageConstraint]
        -> Set PN
-       -> Progress String String (Assignment, RevDepMap)
+       -> Progress SummarizedMessage String (Assignment, RevDepMap)
 solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
     toProgress $ retry (runSolver printFullLog sc) createErrorMsg
   where
     runSolver :: Bool -> SolverConfig
-              -> RetryLog String SolverFailure (Assignment, RevDepMap)
+              -> RetryLog SummarizedMessage SolverFailure (Assignment, RevDepMap)
     runSolver keepLog sc' =
         displayLogMessages keepLog $
         solve sc' cinfo idx pkgConfigDB pprefs gcs pns
 
     createErrorMsg :: SolverFailure
-                   -> RetryLog String String (Assignment, RevDepMap)
-    createErrorMsg failure@(ExhaustiveSearch cs cm) =
+                   -> RetryLog SummarizedMessage String (Assignment, RevDepMap)
+    createErrorMsg failure@(ExhaustiveSearch cs _cm) =
       if asBool $ minimizeConflictSet sc
-      then continueWith ("Found no solution after exhaustively searching the "
+      then continueWith (mkErrorMsg ("Found no solution after exhaustively searching the "
                           ++ "dependency tree. Rerunning the dependency solver "
                           ++ "to minimize the conflict set ({"
-                          ++ showConflictSet cs ++ "}).") $
-           retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs cm) $
+                          ++ showConflictSet cs ++ "}).")) $
+           retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs _cm) $
                \case
                   ExhaustiveSearch cs' cm' ->
                       fromProgress $ Fail $
@@ -151,13 +168,13 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
                        ++ "Original error message:\n"
                        ++ rerunSolverForErrorMsg cs
                        ++ finalErrorMsg sc failure
-      else fromProgress $ Fail $
-           rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure
+      else
+        fromProgress $ Fail $ rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure
     createErrorMsg failure@BackjumpLimitReached     =
         continueWith
-             ("Backjump limit reached. Rerunning dependency solver to generate "
+             (mkErrorMsg ("Backjump limit reached. Rerunning dependency solver to generate "
               ++ "a final conflict set for the search tree containing the "
-              ++ "first backjump.") $
+              ++ "first backjump.")) $
         retry (runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $
             \case
                ExhaustiveSearch cs _ ->
@@ -181,13 +198,16 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
           -- original goal order.
           goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc)
 
-      in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc')))
+      in unlines ("Could not resolve dependencies:" : map renderSummarizedMessage (messages (toProgress (runSolver True sc'))))
 
     printFullLog = solverVerbosity sc >= verbose
 
     messages :: Progress step fail done -> [step]
     messages = foldProgress (:) (const []) (const [])
 
+mkErrorMsg :: String -> SummarizedMessage
+mkErrorMsg msg = ErrorMsg msg
+
 -- | Try to remove variables from the given conflict set to create a minimal
 -- conflict set.
 --
@@ -219,13 +239,13 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
 --    solver to add new unnecessary variables to the conflict set. This function
 --    discards the result from any run that adds new variables to the conflict
 --    set, but the end result may not be completely minimized.
-tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog String SolverFailure a)
+tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog SummarizedMessage SolverFailure a)
                          -> SolverConfig
                          -> ConflictSet
                          -> ConflictMap
-                         -> RetryLog String SolverFailure a
+                         -> RetryLog SummarizedMessage SolverFailure a
 tryToMinimizeConflictSet runSolver sc cs cm =
-    foldl (\r v -> retryNoSolution r $ tryToRemoveOneVar v)
+    foldl (\r v -> retryMap mkErrorMsg $ retryNoSolution (retryMap renderSummarizedMessage r) $ tryToRemoveOneVar v)
           (fromProgress $ Fail $ ExhaustiveSearch cs cm)
           (CS.toList cs)
   where
@@ -258,7 +278,7 @@ tryToMinimizeConflictSet runSolver sc cs cm =
       | otherwise =
         continueWith ("Trying to remove variable " ++ varStr ++ " from the "
                       ++ "conflict set.") $
-        retry (runSolver sc') $ \case
+        retry (retryMap renderSummarizedMessage $ runSolver sc') $ \case
             err@(ExhaustiveSearch cs' _)
               | CS.toSet cs' `isSubsetOf` CS.toSet smallestKnownCS ->
                   let msg = if not $ CS.member v cs'
@@ -297,6 +317,9 @@ tryToMinimizeConflictSet runSolver sc cs cm =
         ExhaustiveSearch cs' cm' -> f cs' cm'
         BackjumpLimitReached     -> fromProgress (Fail BackjumpLimitReached)
 
+    retryMap :: (t -> step) -> RetryLog t fail done -> RetryLog step fail done
+    retryMap f l = fromProgress $ (\p -> foldProgress (\x xs -> Step (f x) xs) Fail Done p) $ toProgress l
+
 -- | Goal ordering that chooses goals contained in the conflict set before
 -- other goals.
 preferGoalsFromConflictSet :: ConflictSet

cabal-install-solver/src/Distribution/Solver/Modular/Log.hs

@@ -7,10 +7,12 @@ import Prelude ()
 import Distribution.Solver.Compat.Prelude
 
 import Distribution.Solver.Types.Progress
-
-import Distribution.Solver.Modular.Dependency
-import Distribution.Solver.Modular.Message
+    ( Progress(Done, Fail), foldProgress, SummarizedMessage, Message )
+import Distribution.Solver.Modular.ConflictSet
+    ( ConflictMap, ConflictSet )
 import Distribution.Solver.Modular.RetryLog
+    ( RetryLog, toProgress, fromProgress )
+import Distribution.Solver.Modular.Message (summarizeMessages)
 
 -- | Information about a dependency solver failure.
 data SolverFailure =
@@ -22,10 +24,10 @@ data SolverFailure =
 -- 'keepLog'), for efficiency.
 displayLogMessages :: Bool
                    -> RetryLog Message SolverFailure a
-                   -> RetryLog String SolverFailure a
+                   -> RetryLog SummarizedMessage SolverFailure a
 displayLogMessages keepLog lg = fromProgress $
     if keepLog
-    then showMessages progress
+    then summarizeMessages progress
     else foldProgress (const id) Fail Done progress
   where
     progress = toProgress lg