Skip to content

Cosmetic changes to cabal-install summarized solver output #9541

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
wants to merge 3 commits into from
Closed
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
91 changes: 57 additions & 34 deletions cabal-install-solver/src/Distribution/Solver/Modular.hs
Original file line number Diff line number Diff line change
@@ -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
12 changes: 7 additions & 5 deletions cabal-install-solver/src/Distribution/Solver/Modular/Log.hs
Original file line number Diff line number Diff line change
@@ -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
168 changes: 115 additions & 53 deletions cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
Original file line number Diff line number Diff line change
@@ -1,8 +1,11 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE InstanceSigs #-}

module Distribution.Solver.Modular.Message (
Message(..),
showMessages
SummarizedMessage(..),
summarizeMessages,
renderSummarizedMessage,
) where

import qualified Data.List as L
@@ -13,79 +16,146 @@ import qualified Data.Set as S
import Data.Maybe (catMaybes, mapMaybe)
import Prelude hiding (pi)

import Distribution.Pretty (prettyShow) -- from Cabal
import Distribution.Pretty ( prettyShow ) -- from Cabal

import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Modular.Dependency
( Var(P),
ConflictSet,
showConflictSet,
QGoalReason,
GoalReason(DependencyGoal, UserGoal),
Goal(Goal),
DependencyReason(DependencyReason),
ExposedComponent(..),
PkgComponent(PkgComponent),
CI(Constrained, Fixed),
showDependencyReason )
import Distribution.Solver.Modular.Flag
( showQFNBool, showQSNBool, showQFN, showQSN )
import Distribution.Solver.Modular.MessageUtils
(showUnsupportedExtension, showUnsupportedLanguage)
( showUnsupportedExtension, showUnsupportedLanguage )
import Distribution.Solver.Modular.Package
( PI(PI), showI, showPI )
import Distribution.Solver.Modular.Tree
( FailReason(..), POption(..), ConflictingDep(..) )
( FailReason(..), POption(..), ConflictingDep(..) )
import Distribution.Solver.Modular.Version
( VR, Ver, showVer, showVR, (.||.) )
import Distribution.Solver.Types.ConstraintSource
( ConstraintSource, showConstraintSource )
import Distribution.Solver.Types.PackagePath
( QPN, Qualified(Q), showQPN )
import Distribution.Solver.Types.Progress
( Progress(..),
SummarizedMessage(..),
EntryMsg(..),
Entry(..),
Message(..) )
import Distribution.Types.LibraryName
( LibraryName(LSubLibName, LMainLibName) )
import Distribution.Types.UnqualComponentName
( unUnqualComponentName )

data Message =
Enter -- ^ increase indentation level
| Leave -- ^ decrease indentation level
| TryP QPN POption
| TryF QFN Bool
| TryS QSN Bool
| Next (Goal QPN)
| Skip (Set CS.Conflict)
| Success
| Failure ConflictSet FailReason

-- | Transforms the structured message type to actual messages (strings).
renderSummarizedMessage :: SummarizedMessage -> String
renderSummarizedMessage (SummarizedMsg i) = displayMessageAtLevel i
renderSummarizedMessage (ErrorMsg s) = s

displayMessageAtLevel :: EntryMsg -> String
displayMessageAtLevel (AtLevel l msg) =
let s = show l
in "[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ displayMessage msg

displayMessage :: Entry -> String
displayMessage (LogPackageGoal qpn gr) = "next goal: " ++ showQPN qpn ++ showGR gr
displayMessage (LogRejectF qfn b c fr) = "rejecting: " ++ showQFNBool qfn b ++ showFR c fr
displayMessage (LogRejectS qsn b c fr) = "rejecting: " ++ showQSNBool qsn b ++ showFR c fr
displayMessage (LogSkipping cs) = "skipping: " ++ showConflicts cs
displayMessage (LogTryingF qfn b) = "trying: " ++ showQFNBool qfn b
displayMessage (LogTryingP qpn i mgr) = "trying: " ++ showQPNPOpt qpn i ++ maybe "" showGR mgr
displayMessage (LogTryingS qsn b) = "trying: " ++ showQSNBool qsn b
displayMessage (LogUnknownPackage qpn gr) = "unknown package" ++ showQPN qpn ++ showGR gr
displayMessage LogSuccessMsg = "done"
displayMessage (LogFailureMsg c fr) = "fail: " ++ showFR c fr
displayMessage (LogSkipMany _ _ cs) = "skipping: " ++ showConflicts cs
-- Instead of displaying `aeson-1.0.2.1, aeson-1.0.2.0, aeson-1.0.1.0, ...`,
-- the following line aim to display `aeson: 1.0.2.1, 1.0.2.0, 1.0.1.0, ...`.
--
displayMessage (LogRejectMany qpn is c fr) = "rejecting: " ++ fmtPkgsGroupedByName (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr

-- TODO: This function should take as input the Index? So even without calling the solver, We can say things as
-- "There is no version in the Hackage index that match the given constraints".
--
-- Alternatively, by passing this to the solver, we could get a more semantic output like:
-- `all versions of aeson available are in conflict with ...`. Isn't already what `tryToMinimizeConflictSet` is doing?
fmtPkgsGroupedByName :: [String] -> String
fmtPkgsGroupedByName pkgs = L.intercalate " " $ fmtPkgGroup (groupByName pkgs)
where
groupByName :: [String] -> M.Map String [String]
groupByName = foldr f M.empty
where
f versionString m = let (pkg, ver) = splitOnLastHyphen versionString
in M.insertWith (++) pkg [ver] m
-- FIXME: This is not a very robust way to split the package name and version.
-- I should rather retrieve the package name and version from the QPN ...
splitOnLastHyphen :: String -> (String, String)
splitOnLastHyphen s =
case reverse (L.elemIndices '-' s) of
(x:_) -> (take x s, drop (x + 1) s)
_ -> error "splitOnLastHyphen: no hyphen found"

fmtPkgGroup :: M.Map String [String] -> [String]
fmtPkgGroup = map formatEntry . M.toList
where
formatEntry (pkg, versions) = pkg ++ ": " ++ L.intercalate ", " versions

-- | Transforms the structured message type to actual messages (SummarizedMsg s).
--
-- The log contains level numbers, which are useful for any trace that involves
-- backtracking, because only the level numbers will allow to keep track of
-- backjumps.
showMessages :: Progress Message a b -> Progress String a b
showMessages = go 0
summarizeMessages :: Progress Message a b -> Progress SummarizedMessage a b
summarizeMessages = go 0
where
-- 'go' increments the level for a recursive call when it encounters
-- 'TryP', 'TryF', or 'TryS' and decrements the level when it encounters 'Leave'.
go :: Int -> Progress Message a b -> Progress String a b
go :: Int -> Progress Message a b -> Progress SummarizedMessage a b
go !_ (Done x) = Done x
go !_ (Fail x) = Fail x

-- complex patterns
go !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
goPReject l qpn [i] c fr ms

go !l (Step (TryP qpn i) (Step Enter (Step (Skip conflicts) (Step Leave ms)))) =
goPSkip l qpn [i] conflicts ms

go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
(atLevel l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go l ms)
Step (SummarizedMsg $ AtLevel l $ (LogRejectF qfn b c fr)) (go l ms)

go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
(atLevel l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go l ms)
Step (SummarizedMsg $ AtLevel l $ (LogRejectS qsn b c fr)) (go l ms)

-- "Trying ..." message when a new goal is started
go !l (Step (Next (Goal (P _ ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =
(atLevel l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go l ms)
Step (SummarizedMsg $ AtLevel l $ (LogTryingP qpn' i (Just gr))) (go l ms)

go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) =
atLevel l ("unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms
Step (SummarizedMsg $ AtLevel l $ (LogUnknownPackage qpn gr)) (go l ms)

-- standard display
go !l (Step Enter ms) = go (l+1) ms
go !l (Step Leave ms) = go (l-1) ms
go !l (Step (TryP qpn i) ms) = (atLevel l $ "trying: " ++ showQPNPOpt qpn i) (go l ms)
go !l (Step (TryF qfn b) ms) = (atLevel l $ "trying: " ++ showQFNBool qfn b) (go l ms)
go !l (Step (TryS qsn b) ms) = (atLevel l $ "trying: " ++ showQSNBool qsn b) (go l ms)
go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms)
go !l (Step (Next _) ms) = go l ms -- ignore flag goals in the log
go !l (Step (Skip conflicts) ms) =
-- 'Skip' should always be handled by 'goPSkip' in the case above.
(atLevel l $ "skipping: " ++ showConflicts conflicts) (go l ms)
go !l (Step (Success) ms) = (atLevel l $ "done") (go l ms)
go !l (Step (Failure c fr) ms) = (atLevel l $ showFailure c fr) (go l ms)

showPackageGoal :: QPN -> QGoalReason -> String
showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr

showFailure :: ConflictSet -> FailReason -> String
showFailure c fr = "fail" ++ showFR c fr

go !l (Step (TryP qpn i) ms) = Step (SummarizedMsg $ AtLevel l $ (LogTryingP qpn i Nothing)) (go l ms)
go !l (Step (TryF qfn b) ms) = Step (SummarizedMsg $ AtLevel l $ (LogTryingF qfn b)) (go l ms)
go !l (Step (TryS qsn b) ms) = Step (SummarizedMsg $ AtLevel l $ (LogTryingS qsn b)) (go l ms)
go !l (Step (Next (Goal (P qpn) gr)) ms) = Step (SummarizedMsg $ AtLevel l $ (LogPackageGoal qpn gr)) (go l ms)
go !l (Step (Next _) ms) = go l ms -- ignore flag goals in the log

-- 'Skip' should always be handled by 'goPSkip' in the case above.
go !l (Step (Skip conflicts) ms) = Step (SummarizedMsg $ AtLevel l $ (LogSkipping conflicts)) (go l ms)
go !l (Step (Success) ms) = Step (SummarizedMsg $ AtLevel l $ LogSuccessMsg) (go l ms)
go !l (Step (Failure c fr) ms) = Step (SummarizedMsg $ AtLevel l $ (LogFailureMsg c fr)) (go l ms)

-- special handler for many subsequent package rejections
goPReject :: Int
@@ -94,32 +164,24 @@ showMessages = go 0
-> ConflictSet
-> FailReason
-> Progress Message a b
-> Progress String a b
-> Progress SummarizedMessage a b
goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))
| qpn == qpn' && fr == fr' = goPReject l qpn (i : is) c fr ms
| qpn == qpn' && fr == fr' =
goPReject l qpn (i : is) c fr ms
goPReject l qpn is c fr ms =
(atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms)
Step (SummarizedMsg $ AtLevel l $ (LogRejectMany qpn is c fr)) (go l ms)

-- Handle many subsequent skipped package instances.
goPSkip :: Int
-> QPN
-> [POption]
-> Set CS.Conflict
-> Progress Message a b
-> Progress String a b
-> Progress SummarizedMessage a b
goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms))))
| qpn == qpn' && conflicts == conflicts' = goPSkip l qpn (i : is) conflicts ms
goPSkip l qpn is conflicts ms =
let msg = "skipping: "
++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is))
++ showConflicts conflicts
in atLevel l msg (go l ms)

-- write a message with the current level number
atLevel :: Int -> String -> Progress String a b -> Progress String a b
atLevel l x xs =
let s = show l
in Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs
Step (SummarizedMsg $ AtLevel l $ (LogSkipMany qpn is conflicts)) (go l ms)

-- | Display the set of 'Conflicts' for a skipped package version.
showConflicts :: Set CS.Conflict -> String
Original file line number Diff line number Diff line change
@@ -2,16 +2,20 @@ module Distribution.Solver.Types.DependencyResolver
( DependencyResolver
) where

import Distribution.Solver.Compat.Prelude
import Distribution.Solver.Compat.Prelude ( String, Set )
import Prelude ()

import Distribution.Solver.Types.LabeledPackageConstraint
( LabeledPackageConstraint )
import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb )
import Distribution.Solver.Types.PackagePreferences
( PackagePreferences )
import Distribution.Solver.Types.PackageIndex ( PackageIndex )
import Distribution.Solver.Types.Progress
( Progress, SummarizedMessage )
import Distribution.Solver.Types.ResolverPackage
import Distribution.Solver.Types.SourcePackage
( ResolverPackage )
import Distribution.Solver.Types.SourcePackage ( SourcePackage )

import Distribution.Simple.PackageIndex ( InstalledPackageIndex )
import Distribution.Package ( PackageName )
@@ -34,4 +38,4 @@ type DependencyResolver loc = Platform
-> (PackageName -> PackagePreferences)
-> [LabeledPackageConstraint]
-> Set PackageName
-> Progress String String [ResolverPackage loc]
-> Progress SummarizedMessage String [ResolverPackage loc]
41 changes: 41 additions & 0 deletions cabal-install-solver/src/Distribution/Solver/Types/Progress.hs
Original file line number Diff line number Diff line change
@@ -1,11 +1,23 @@
module Distribution.Solver.Types.Progress
( Progress(..)
, foldProgress
, Message(..)
, Entry(..)
, EntryMsg(..)
, SummarizedMessage(..)
) where

import Prelude ()
import Distribution.Solver.Compat.Prelude hiding (fail)

import Distribution.Solver.Modular.Tree
( FailReason(..), POption(..) )
import Distribution.Solver.Types.PackagePath ( QPN )
import Distribution.Solver.Modular.Flag ( QSN, QFN )
import Distribution.Solver.Modular.Dependency
( ConflictSet, QGoalReason, GoalReason, Goal )
import qualified Distribution.Solver.Modular.ConflictSet as CS

-- | A type to represent the unfolding of an expensive long running
-- calculation that may fail. We may get intermediate steps before the final
-- result which may be used to indicate progress and\/or logging messages.
@@ -47,3 +59,32 @@ instance Applicative (Progress step fail) where
instance Monoid fail => Alternative (Progress step fail) where
empty = Fail mempty
p <|> q = foldProgress Step (const q) Done p

data Message =
Enter -- ^ increase indentation level
| Leave -- ^ decrease indentation level
| TryP QPN POption
| TryF QFN Bool
| TryS QSN Bool
| Next (Goal QPN)
| Skip (Set CS.Conflict)
| Success
| Failure ConflictSet FailReason

data Entry
= LogPackageGoal QPN QGoalReason
| LogRejectF QFN Bool ConflictSet FailReason
| LogRejectS QSN Bool ConflictSet FailReason
| LogSkipping (Set CS.Conflict)
| LogTryingF QFN Bool
| LogTryingP QPN POption (Maybe (GoalReason QPN))
| LogTryingS QSN Bool
| LogRejectMany QPN [POption] ConflictSet FailReason
| LogSkipMany QPN [POption] (Set CS.Conflict)
| LogUnknownPackage QPN (GoalReason QPN)
| LogSuccessMsg
| LogFailureMsg ConflictSet FailReason

data EntryMsg = AtLevel Int Entry

data SummarizedMessage = SummarizedMsg EntryMsg | ErrorMsg String
171 changes: 121 additions & 50 deletions cabal-install/src/Distribution/Client/Dependency.hs
Original file line number Diff line number Diff line change
@@ -68,27 +68,41 @@ module Distribution.Client.Dependency

import Distribution.Client.Compat.Prelude

import Control.Exception
( assert
)
import Data.List
( maximumBy
)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Client.Dependency.Types
( PackagesPreferenceDefault (..)
)
import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.Client.Types
import Distribution.Client.Types.AllowNewer
( AllowNewer (..)
, AllowOlder (..)
, PackageSpecifier (..)
, RelaxDepMod (..)
, RelaxDepScope (..)
, RelaxDepSubject (..)
, RelaxDeps (..)
, RelaxedDep (..)
, SourcePackageDb (SourcePackageDb)
, UnresolvedPkgLoc
, UnresolvedSourcePackage
, isRelaxDeps
)
import Distribution.Client.Types.PackageLocation
( UnresolvedPkgLoc
, UnresolvedSourcePackage
)
import Distribution.Client.Types.PackageSpecifier
( PackageSpecifier (..)
, pkgSpecifierConstraints
, pkgSpecifierTarget
)
import Distribution.Client.Types.SourcePackageDb
( SourcePackageDb (SourcePackageDb)
)
import Distribution.Client.Utils
( MergeResult (..)
, duplicatesBy
@@ -122,43 +136,96 @@ import Distribution.Solver.Modular
, SolverConfig (..)
, modularResolver
)
import Distribution.System
( Platform
)
import Distribution.Types.Dependency
import Distribution.Verbosity
( normal
)
import Distribution.Version

import Distribution.Solver.Modular.Message (renderSummarizedMessage)
import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Solver.Types.ConstraintSource
( ConstraintSource
( ConstraintSetupCabalMaxVersion
, ConstraintSetupCabalMinVersion
, ConstraintSourceNonReinstallablePackage
)
, showConstraintSource
)
import Distribution.Solver.Types.DependencyResolver
( DependencyResolver
)
import Distribution.Solver.Types.InstalledPreference as Preference
( InstalledPreference (..)
)
import Distribution.Solver.Types.LabeledPackageConstraint
( LabeledPackageConstraint (..)
, unlabelPackageConstraint
)
import Distribution.Solver.Types.OptionalStanza
( OptionalStanza
, enableStanzas
)
import Distribution.Solver.Types.PackageConstraint
( ConstraintScope (ScopeAnyQualifier, ScopeAnySetupQualifier)
, PackageConstraint (..)
, PackageProperty (..)
, scopeToPackageName
, scopeToplevel
, showPackageConstraint
)
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.PackagePath (QPN)
import Distribution.Solver.Types.PackagePreferences
( PackagePreferences (..)
)
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
import Distribution.Solver.Types.Progress
( Progress (..)
, SummarizedMessage
, foldProgress
)
import Distribution.Solver.Types.ResolverPackage
( ResolverPackage (Configured)
)
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SolverId
( AllowBootLibInstalls (..)
, AvoidReinstalls (..)
, CountConflicts (..)
, EnableBackjumping (..)
, FineGrainedConflicts (..)
, IndependentGoals (..)
, MinimizeConflictSet (..)
, OnlyConstrained (OnlyConstrainedNone)
, ReorderGoals (..)
, ShadowPkgs (..)
, SolveExecutables (..)
, StrongFlags (..)
)
import Distribution.Solver.Types.SolverId (SolverId (solverSrcId))
import Distribution.Solver.Types.SolverPackage
( SolverPackage (SolverPackage)
)
import Distribution.Solver.Types.SourcePackage
import Distribution.Solver.Types.Variable

import Control.Exception
( assert
( SourcePackage (srcpkgDescription)
)
import Data.List
( maximumBy
import Distribution.Solver.Types.Variable (Variable)
import Distribution.System
( Platform
)
import Distribution.Types.Dependency (Dependency (..), mainLibSet)
import Distribution.Verbosity
( normal
)
import Distribution.Version
( Version
, VersionRange
, anyVersion
, earlierVersion
, mkVersion
, orLaterVersion
, removeLowerBound
, removeUpperBound
, simplifyVersionRange
, transformCaretLower
, transformCaretUpper
, withinRange
)
import qualified Data.Map as Map
import qualified Data.Set as Set

-- ------------------------------------------------------------

@@ -769,32 +836,33 @@ resolveDependencies
resolveDependencies platform comp pkgConfigDB params =
Step (showDepResolverParams finalparams) $
fmap (validateSolverResult platform comp indGoals) $
runSolver
( SolverConfig
reordGoals
cntConflicts
fineGrained
minimize
indGoals
noReinstalls
shadowing
strFlags
onlyConstrained_
maxBkjumps
enableBj
solveExes
order
verbosity
(PruneAfterFirstSuccess False)
)
platform
comp
installedPkgIndex
sourcePkgIndex
pkgConfigDB
preferences
constraints
targets
formatProgress $
runSolver
( SolverConfig
reordGoals
cntConflicts
fineGrained
minimize
indGoals
noReinstalls
shadowing
strFlags
onlyConstrained_
maxBkjumps
enableBj
solveExes
order
verbosity
(PruneAfterFirstSuccess False)
)
platform
comp
installedPkgIndex
sourcePkgIndex
pkgConfigDB
preferences
constraints
targets
where
finalparams@( DepResolverParams
targets
@@ -823,6 +891,9 @@ resolveDependencies platform comp pkgConfigDB params =
then params
else dontInstallNonReinstallablePackages params

formatProgress :: Progress SummarizedMessage String a -> Progress String String a
formatProgress p = foldProgress (\x xs -> Step (renderSummarizedMessage x) xs) Fail Done p

preferences :: PackageName -> PackagePreferences
preferences = interpretPackagesPreference targets defpref prefs