Refactor cabal-install solver config log output

cabal-install-solver/cabal-install-solver.cabal

@@ -95,6 +95,7 @@ library
     Distribution.Solver.Types.SolverId
     Distribution.Solver.Types.SolverPackage
     Distribution.Solver.Types.SourcePackage
+    Distribution.Solver.Types.SummarizedMessage
     Distribution.Solver.Types.Variable
 
   build-depends:

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

@@ -27,34 +27,51 @@ import Distribution.Solver.Modular.ConfiguredConversion
          ( 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 )
 import Distribution.Solver.Modular.Log
          ( SolverFailure(..), displayLogMessages )
 import Distribution.Solver.Modular.Package
          ( PN )
 import Distribution.Solver.Modular.RetryLog
+    ( RetryLog,
+      toProgress,
+      fromProgress,
+      retry,
+      failWith,
+      continueWith )
 import Distribution.Solver.Modular.Solver
          ( 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 )
 import Distribution.Solver.Types.Progress
-import Distribution.Solver.Types.Variable
+    ( Progress(..), foldProgress, SummarizedMessage(ErrorMsg) )
+import Distribution.Solver.Types.Variable ( Variable(..) )
 import Distribution.System
          ( Platform(..) )
 import Distribution.Simple.Setup
          ( 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,24 +137,24 @@ 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)
+                   -> 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 ++ "}).") $
+                          ++ showConflictSet cs ++ "}).")) $
            retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs cm) $
                \case
                   ExhaustiveSearch cs' cm' ->
@@ -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,11 +239,11 @@ 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)
           (fromProgress $ Fail $ ExhaustiveSearch cs cm)
@@ -249,14 +269,14 @@ tryToMinimizeConflictSet runSolver sc cs cm =
     tryToRemoveOneVar :: Var QPN
                       -> ConflictSet
                       -> ConflictMap
-                      -> RetryLog String SolverFailure a
+                      -> RetryLog SummarizedMessage SolverFailure a
     tryToRemoveOneVar v smallestKnownCS smallestKnownCM
         -- Check whether v is still present, because it may have already been
         -- removed in a previous solver rerun.
       | not (v `CS.member` smallestKnownCS) =
           fromProgress $ Fail $ ExhaustiveSearch smallestKnownCS smallestKnownCM
       | otherwise =
-        continueWith ("Trying to remove variable " ++ varStr ++ " from the "
+        continueWith (mkErrorMsg $ "Trying to remove variable " ++ varStr ++ " from the "
                       ++ "conflict set.") $
         retry (runSolver sc') $ \case
             err@(ExhaustiveSearch cs' _)
@@ -268,14 +288,14 @@ tryToMinimizeConflictSet runSolver sc cs cm =
                                   ++ "conflict set."
                   in -- Use the new conflict set, even if v wasn't removed,
                      -- because other variables may have been removed.
-                     failWith (msg ++ " Continuing with " ++ showCS cs' ++ ".") err
+                     failWith (mkErrorMsg $ msg ++ " Continuing with " ++ showCS cs' ++ ".") err
               | otherwise ->
-                  failWith ("Failed to find a smaller conflict set. The new "
+                  failWith (mkErrorMsg $ "Failed to find a smaller conflict set. The new "
                              ++ "conflict set is not a subset of the previous "
                              ++ "conflict set: " ++ showCS cs') $
                   ExhaustiveSearch smallestKnownCS smallestKnownCM
             BackjumpLimitReached ->
-                failWith "Reached backjump limit while minimizing conflict set."
+                failWith (mkErrorMsg "Reached backjump limit while minimizing conflict set.")
                          BackjumpLimitReached
       where
         varStr = "\"" ++ showVar v ++ "\""
@@ -290,9 +310,9 @@ tryToMinimizeConflictSet runSolver sc cs cm =
 
     -- Like 'retry', except that it only applies the input function when the
     -- backjump limit has not been reached.
-    retryNoSolution :: RetryLog step SolverFailure done
-                    -> (ConflictSet -> ConflictMap -> RetryLog step SolverFailure done)
-                    -> RetryLog step SolverFailure done
+    retryNoSolution :: RetryLog SummarizedMessage SolverFailure done
+                    -> (ConflictSet -> ConflictMap -> RetryLog SummarizedMessage SolverFailure done)
+                    -> RetryLog SummarizedMessage SolverFailure done
     retryNoSolution lg f = retry lg $ \case
         ExhaustiveSearch cs' cm' -> f cs' cm'
         BackjumpLimitReached     -> fromProgress (Fail BackjumpLimitReached)

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 )
+import Distribution.Solver.Modular.ConflictSet
+    ( ConflictMap, ConflictSet )
 import Distribution.Solver.Modular.RetryLog
+    ( RetryLog, toProgress, fromProgress )
+import Distribution.Solver.Modular.Message (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