Skip to content

Commit 5e1fd2a

Browse files
authored
Merge pull request #10854 from erikd/erikd/cosmetic-changes-2
Refactor cabal-install solver config log output
2 parents 8bd0d51 + aecf41e commit 5e1fd2a

File tree

8 files changed

+250
-127
lines changed

8 files changed

+250
-127
lines changed

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -95,6 +95,7 @@ library
9595
Distribution.Solver.Types.SolverId
9696
Distribution.Solver.Types.SolverPackage
9797
Distribution.Solver.Types.SourcePackage
98+
Distribution.Solver.Types.SummarizedMessage
9899
Distribution.Solver.Types.Variable
99100

100101
build-depends:

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

Lines changed: 42 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -27,34 +27,53 @@ import Distribution.Solver.Modular.ConfiguredConversion
2727
( convCP )
2828
import qualified Distribution.Solver.Modular.ConflictSet as CS
2929
import Distribution.Solver.Modular.Dependency
30-
import Distribution.Solver.Modular.Flag
31-
import Distribution.Solver.Modular.Index
30+
( Var(..),
31+
showVar,
32+
ConflictMap,
33+
ConflictSet,
34+
showConflictSet,
35+
RevDepMap )
36+
import Distribution.Solver.Modular.Flag ( SN(SN), FN(FN) )
37+
import Distribution.Solver.Modular.Index ( Index )
3238
import Distribution.Solver.Modular.IndexConversion
3339
( convPIs )
3440
import Distribution.Solver.Modular.Log
3541
( SolverFailure(..), displayLogMessages )
3642
import Distribution.Solver.Modular.Package
3743
( PN )
3844
import Distribution.Solver.Modular.RetryLog
45+
( RetryLog,
46+
toProgress,
47+
fromProgress,
48+
retry,
49+
failWith,
50+
continueWith )
3951
import Distribution.Solver.Modular.Solver
4052
( SolverConfig(..), PruneAfterFirstSuccess(..), solve )
4153
import Distribution.Solver.Types.DependencyResolver
54+
( DependencyResolver )
4255
import Distribution.Solver.Types.LabeledPackageConstraint
56+
( LabeledPackageConstraint, unlabelPackageConstraint )
4357
import Distribution.Solver.Types.PackageConstraint
44-
import Distribution.Solver.Types.PackagePath
58+
( PackageConstraint(..), scopeToPackageName )
59+
import Distribution.Solver.Types.PackagePath ( QPN )
4560
import Distribution.Solver.Types.PackagePreferences
61+
( PackagePreferences )
4662
import Distribution.Solver.Types.PkgConfigDb
4763
( PkgConfigDb )
4864
import Distribution.Solver.Types.Progress
49-
import Distribution.Solver.Types.Variable
65+
( Progress(..), foldProgress )
66+
import Distribution.Solver.Types.SummarizedMessage
67+
( SummarizedMessage(StringMsg) )
68+
import Distribution.Solver.Types.Variable ( Variable(..) )
5069
import Distribution.System
5170
( Platform(..) )
5271
import Distribution.Simple.Setup
5372
( BooleanFlag(..) )
5473
import Distribution.Simple.Utils
55-
( ordNubBy )
56-
import Distribution.Verbosity
57-
74+
( ordNubBy )
75+
import Distribution.Verbosity ( normal, verbose )
76+
import Distribution.Solver.Modular.Message ( renderSummarizedMessage )
5877

5978
-- | Ties the two worlds together: classic cabal-install vs. the modular
6079
-- solver. Performs the necessary translations before and after.
@@ -120,21 +139,21 @@ solve' :: SolverConfig
120139
-> (PN -> PackagePreferences)
121140
-> Map PN [LabeledPackageConstraint]
122141
-> Set PN
123-
-> Progress String String (Assignment, RevDepMap)
142+
-> Progress SummarizedMessage String (Assignment, RevDepMap)
124143
solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
125144
toProgress $ retry (runSolver printFullLog sc) createErrorMsg
126145
where
127146
runSolver :: Bool -> SolverConfig
128-
-> RetryLog String SolverFailure (Assignment, RevDepMap)
147+
-> RetryLog SummarizedMessage SolverFailure (Assignment, RevDepMap)
129148
runSolver keepLog sc' =
130149
displayLogMessages keepLog $
131150
solve sc' cinfo idx pkgConfigDB pprefs gcs pns
132151

133152
createErrorMsg :: SolverFailure
134-
-> RetryLog String String (Assignment, RevDepMap)
153+
-> RetryLog SummarizedMessage String (Assignment, RevDepMap)
135154
createErrorMsg failure@(ExhaustiveSearch cs cm) =
136155
if asBool $ minimizeConflictSet sc
137-
then continueWith ("Found no solution after exhaustively searching the "
156+
then continueWith (mkStringMsg $ "Found no solution after exhaustively searching the "
138157
++ "dependency tree. Rerunning the dependency solver "
139158
++ "to minimize the conflict set ({"
140159
++ showConflictSet cs ++ "}).") $
@@ -155,7 +174,7 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
155174
rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure
156175
createErrorMsg failure@BackjumpLimitReached =
157176
continueWith
158-
("Backjump limit reached. Rerunning dependency solver to generate "
177+
(mkStringMsg $ "Backjump limit reached. Rerunning dependency solver to generate "
159178
++ "a final conflict set for the search tree containing the "
160179
++ "first backjump.") $
161180
retry (runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $
@@ -181,13 +200,16 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
181200
-- original goal order.
182201
goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc)
183202

184-
in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc')))
203+
in unlines ("Could not resolve dependencies:" : map renderSummarizedMessage (messages (toProgress (runSolver True sc'))))
185204

186205
printFullLog = solverVerbosity sc >= verbose
187206

188207
messages :: Progress step fail done -> [step]
189208
messages = foldProgress (:) (const []) (const [])
190209

210+
mkStringMsg :: String -> SummarizedMessage
211+
mkStringMsg msg = StringMsg msg
212+
191213
-- | Try to remove variables from the given conflict set to create a minimal
192214
-- conflict set.
193215
--
@@ -219,11 +241,11 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
219241
-- solver to add new unnecessary variables to the conflict set. This function
220242
-- discards the result from any run that adds new variables to the conflict
221243
-- set, but the end result may not be completely minimized.
222-
tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog String SolverFailure a)
244+
tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog SummarizedMessage SolverFailure a)
223245
-> SolverConfig
224246
-> ConflictSet
225247
-> ConflictMap
226-
-> RetryLog String SolverFailure a
248+
-> RetryLog SummarizedMessage SolverFailure a
227249
tryToMinimizeConflictSet runSolver sc cs cm =
228250
foldl (\r v -> retryNoSolution r $ tryToRemoveOneVar v)
229251
(fromProgress $ Fail $ ExhaustiveSearch cs cm)
@@ -249,14 +271,14 @@ tryToMinimizeConflictSet runSolver sc cs cm =
249271
tryToRemoveOneVar :: Var QPN
250272
-> ConflictSet
251273
-> ConflictMap
252-
-> RetryLog String SolverFailure a
274+
-> RetryLog SummarizedMessage SolverFailure a
253275
tryToRemoveOneVar v smallestKnownCS smallestKnownCM
254276
-- Check whether v is still present, because it may have already been
255277
-- removed in a previous solver rerun.
256278
| not (v `CS.member` smallestKnownCS) =
257279
fromProgress $ Fail $ ExhaustiveSearch smallestKnownCS smallestKnownCM
258280
| otherwise =
259-
continueWith ("Trying to remove variable " ++ varStr ++ " from the "
281+
continueWith (mkStringMsg $ "Trying to remove variable " ++ varStr ++ " from the "
260282
++ "conflict set.") $
261283
retry (runSolver sc') $ \case
262284
err@(ExhaustiveSearch cs' _)
@@ -268,14 +290,14 @@ tryToMinimizeConflictSet runSolver sc cs cm =
268290
++ "conflict set."
269291
in -- Use the new conflict set, even if v wasn't removed,
270292
-- because other variables may have been removed.
271-
failWith (msg ++ " Continuing with " ++ showCS cs' ++ ".") err
293+
failWith (mkStringMsg $ msg ++ " Continuing with " ++ showCS cs' ++ ".") err
272294
| otherwise ->
273-
failWith ("Failed to find a smaller conflict set. The new "
295+
failWith (mkStringMsg $ "Failed to find a smaller conflict set. The new "
274296
++ "conflict set is not a subset of the previous "
275297
++ "conflict set: " ++ showCS cs') $
276298
ExhaustiveSearch smallestKnownCS smallestKnownCM
277299
BackjumpLimitReached ->
278-
failWith "Reached backjump limit while minimizing conflict set."
300+
failWith (mkStringMsg "Reached backjump limit while minimizing conflict set.")
279301
BackjumpLimitReached
280302
where
281303
varStr = "\"" ++ showVar v ++ "\""

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

Lines changed: 9 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -7,11 +7,14 @@ import Prelude ()
77
import Distribution.Solver.Compat.Prelude
88

99
import Distribution.Solver.Types.Progress
10-
11-
import Distribution.Solver.Modular.Dependency
12-
import Distribution.Solver.Modular.Message
10+
( Progress(Done, Fail), foldProgress )
11+
import Distribution.Solver.Modular.ConflictSet
12+
( ConflictMap, ConflictSet )
1313
import Distribution.Solver.Modular.RetryLog
14-
14+
( RetryLog, toProgress, fromProgress )
15+
import Distribution.Solver.Modular.Message (Message, summarizeMessages)
16+
import Distribution.Solver.Types.SummarizedMessage
17+
( SummarizedMessage(..) )
1518
-- | Information about a dependency solver failure.
1619
data SolverFailure =
1720
ExhaustiveSearch ConflictSet ConflictMap
@@ -22,10 +25,10 @@ data SolverFailure =
2225
-- 'keepLog'), for efficiency.
2326
displayLogMessages :: Bool
2427
-> RetryLog Message SolverFailure a
25-
-> RetryLog String SolverFailure a
28+
-> RetryLog SummarizedMessage SolverFailure a
2629
displayLogMessages keepLog lg = fromProgress $
2730
if keepLog
28-
then showMessages progress
31+
then summarizeMessages progress
2932
else foldProgress (const id) Fail Done progress
3033
where
3134
progress = toProgress lg

0 commit comments

Comments
 (0)