diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs index 9111b2d78d0..0372ef24548 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular.hs +++ b/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 diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs index 321a051070b..64365d8ffc0 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs +++ b/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 diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs index 2bc28286df0..211fb465a87 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs @@ -1,9 +1,14 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} module Distribution.Solver.Modular.Message ( Message(..), - showMessages + SummarizedMessage(..), + summarizeMessages, + renderSummarizedMessage, + + -- Requird by the doctests, but not used elsewhere so export this + -- to avoid compiler warnings. + showOptions, ) where import qualified Data.List as L @@ -14,82 +19,132 @@ import qualified Data.Set as S import Data.Maybe (catMaybes, mapMaybe, isJust) 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 -import Distribution.Solver.Modular.Flag ( QFN, QSN ) -import qualified Distribution.Solver.Modular.Flag as Flag ( showQFN, showQFNBool, showQSN, showQSNBool ) + ( 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 -import Distribution.Solver.Types.ProjectConfigPath (docProjectConfigPathFailReason) + ( Progress(..), + SummarizedMessage(..), + EntryMsg(..), + Entry(..), + Message(..) ) +import Distribution.Solver.Types.ProjectConfigPath + ( docProjectConfigPathFailReason) import Distribution.Types.LibraryName + ( LibraryName(LSubLibName, LMainLibName) ) import Distribution.Types.UnqualComponentName -import Text.PrettyPrint (nest, render) - -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). + ( unUnqualComponentName ) + +import Text.PrettyPrint ( nest, render ) + +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 qsn b cs) = "skipping: " ++ showOptions qsn b ++ " " ++ 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: " ++ showQPNConflictSet qpn (reverse is) ++ showFR c fr + +showQPNConflictSet :: QPN -> [POption] -> String +showQPNConflictSet qpn popts = + case popts of + [] -> "" + [x] -> showQPNPOpt qpn x + (x:xs) -> showQPNPOpt qpn x ++ ", " ++ L.intercalate ", " (map (\(POption i _) -> showI i) xs) + +-- | 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 $ blurbQFNBool Rejecting 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 $ blurbQSNBool Rejecting 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 $ blurbOption Trying 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 $ blurbOption Trying qpn i) (go l ms) - go !l (Step (TryF qfn b) ms) = (atLevel l $ blurbQFNBool Trying qfn b) (go l ms) - go !l (Step (TryS qsn b) ms) = (atLevel l $ blurbQSNBool Trying 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 $ blurb 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 @@ -98,14 +153,12 @@ 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' = - -- By prepending (i : is) we reverse the order of the instances. goPReject l qpn (i : is) c fr ms goPReject l qpn is c fr ms = - (atLevel l $ blurbOptions Rejecting 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 @@ -113,25 +166,18 @@ showMessages = go 0 -> [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' = -- By prepending (i : is) we reverse the order of the instances. goPSkip l qpn (i : is) conflicts ms goPSkip l qpn is conflicts ms = - let msg = blurbOptions Skipping 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 showConflicts conflicts = - " (has the same characteristics that caused the previous version to fail: " + "(has the same characteristics that caused the previous version to fail: " ++ conflictMsg ++ ")" where conflictMsg :: String @@ -213,29 +259,6 @@ data MergedPackageConflict = MergedPackageConflict { , versionConflict :: Maybe VR } -data ProgressAction = - Trying - | Skipping - | Rejecting - -blurb :: ProgressAction -> String -blurb = \case - Trying -> "trying: " - Skipping -> "skipping: " - Rejecting -> "rejecting: " - -blurbQFNBool :: ProgressAction -> QFN -> Bool -> String -blurbQFNBool a q b = blurb a ++ Flag.showQFNBool q b - -blurbQSNBool :: ProgressAction -> QSN -> Bool -> String -blurbQSNBool a q b = blurb a ++ Flag.showQSNBool q b - -blurbOption :: ProgressAction -> QPN -> POption -> String -blurbOption a q p = blurb a ++ showOption q p - -blurbOptions :: ProgressAction -> QPN -> [POption] -> String -blurbOptions a q ps = blurb a ++ showOptions q ps - showOption :: QPN -> POption -> String showOption qpn@(Q _pp pn) (POption i linkedTo) = case linkedTo of @@ -270,6 +293,12 @@ showOptions q xs = showQPN q ++ "; " ++ (L.intercalate ", " | x@(POption i linkedTo) <- xs ]) +showQPNPOpt :: QPN -> POption -> String +showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) = + case linkedTo of + Nothing -> showPI (PI qpn i) -- Consistent with prior to POption + Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i) + showGR :: QGoalReason -> String showGR UserGoal = " (user goal)" showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")" @@ -306,8 +335,8 @@ showFR _ (UnsupportedSpecVer ver) = " (unsupported spec-version " ++ pre -- The following are internal failures. They should not occur. In the -- interest of not crashing unnecessarily, we still just print an error -- message though. -showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ Flag.showQFN qfn ++ ")" -showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ Flag.showQSN qsn ++ ")" +showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")" +showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")" showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)" showExposedComponent :: ExposedComponent -> String @@ -332,7 +361,9 @@ showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) = componentStr ++ showVR vr -- $setup +-- >>> import Distribution.Solver.Modular.Package -- >>> import Distribution.Solver.Types.PackagePath +-- >>> import Distribution.Types.PackageName -- >>> import Distribution.Types.Version -- >>> import Distribution.Types.UnitId -- >>> let foobarPN = PackagePath DefaultNamespace QualToplevel diff --git a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs index 139a6d2b33d..4dc1a265d73 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs @@ -2,16 +2,20 @@ module Distribution.Solver.Types.DependencyResolver ( DependencyResolver ) where -import Distribution.Solver.Compat.Prelude +import Distribution.Solver.Compat.Prelude ( Maybe, 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] diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs b/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs index a47e651d1c4..3cfe82e258f 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs @@ -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 diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index d59bc611c44..2882484b125 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -69,27 +69,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 @@ -123,46 +137,100 @@ import Distribution.Solver.Modular , SolverConfig (..) , modularResolver ) -import Distribution.System - ( Platform - ) -import Distribution.Types.Dependency -import Distribution.Types.DependencySatisfaction - ( DependencySatisfaction (..) - ) -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 + , ConstraintSourceProfiledDynamic + ) + , 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.Types.DependencySatisfaction + ( DependencySatisfaction (..) + ) +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 -- ------------------------------------------------------------ @@ -790,32 +858,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 @@ -844,6 +913,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 diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs index a1f5eed3c62..b0d13c85da3 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -208,7 +208,7 @@ tests = solverSuccess [("base", 1), ("ghc-prim", 1), ("integer-gmp", 1), ("integer-simple", 1)] , runTest $ mkTest dbNonupgrade "Refuse to install newer ghc requested by another library" ["A"] $ - solverFailure (isInfixOf "rejecting: ghc-2.0.0 (constraint from non-reinstallable package requires installed instance)") + solverFailure (isInfixOf "rejecting: ghc-1.0.0/installed-1 (conflict: A => ghc==2.0.0)") ] , testGroup "reject-unconstrained" @@ -623,7 +623,7 @@ tests = , "[__2] unknown package: unknown2 (dependency of B)" , "[__2] fail (backjumping, conflict set: B, unknown2)" , "[__1] fail (backjumping, conflict set: A, B, unknown1, unknown2)" - , "[__0] skipping: A; 3.0.0, 2.0.0 (has the same characteristics that " + , "[__0] skipping: A; 2.0.0, 3.0.0 (has the same characteristics that " ++ "caused the previous version to fail: depends on 'B')" , "[__0] trying: A-1.0.0" , "[__1] done" @@ -652,7 +652,7 @@ tests = , "[__1] next goal: B (dependency of A)" , "[__1] rejecting: B-11.0.0 (conflict: A => B==14.0.0)" , "[__1] fail (backjumping, conflict set: A, B)" - , "[__0] skipping: A; 3.0.0, 2.0.0 (has the same characteristics that " + , "[__0] skipping: A; 2.0.0, 3.0.0 (has the same characteristics that " ++ "caused the previous version to fail: depends on 'B' but excludes " ++ "version 11.0.0)" , "[__0] trying: A-1.0.0" @@ -777,7 +777,7 @@ tests = , "[__2] next goal: C (dependency of A)" , "[__2] rejecting: C-2.0.0 (conflict: A => C==1.0.0)" , "[__2] fail (backjumping, conflict set: A, C)" - , "[__0] skipping: A; 3.0.0, 2.0.0 (has the same characteristics that caused the " + , "[__0] skipping: A; 2.0.0, 3.0.0 (has the same characteristics that caused the " ++ "previous version to fail: depends on 'C' but excludes version 2.0.0)" , "[__0] trying: A-1.0.0" , "[__1] next goal: C (dependency of A)" @@ -950,7 +950,7 @@ tests = , Right $ exAv "B" 1 [ExFix "A" 4] ] rejecting = "rejecting: A-3.0.0" - skipping = "skipping: A; 2.0.0, 1.0.0" + skipping = "skipping: A; 1.0.0, 2.0.0" in mkTest db "show skipping versions list" ["B"] $ solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg) , runTest $ @@ -961,7 +961,7 @@ tests = , Right $ exAv "B" 1 [ExFix "A" 4] ] rejecting = "rejecting: A-3.0.0/installed-3.0.0" - skipping = "skipping: A; 2.0.0/installed-2.0.0, 1.0.0/installed-1.0.0" + skipping = "skipping: A; 1.0.0/installed-1.0.0, 2.0.0/installed-2.0.0 " in mkTest db "show skipping versions list, installed" ["B"] $ solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg) ]