diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs index 2aac240318f..43d510bd1f2 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(ErrorMessage) ) +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 = ErrorMessage 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 73580aff3e6..855bbbb2647 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs @@ -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,117 @@ 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(..), + EntryMessage(..), + 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 +renderSummarizedMessage :: SummarizedMessage -> String +renderSummarizedMessage (SummarizedMessage i) = displayMessageAtLevel i +renderSummarizedMessage (ErrorMessage s) = s --- | Transforms the structured message type to actual messages (strings). +displayMessageAtLevel :: EntryMessage -> 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 +displayMessage (LogRejectMany qpn is c fr) = "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr + +-- | 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 (SummarizedMessage $ 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 (SummarizedMessage $ 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 (SummarizedMessage $ 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 (SummarizedMessage $ 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 + go !l (Step (TryP qpn i) ms) = Step (SummarizedMessage $ AtLevel l $ (LogTryingP qpn i Nothing)) (go l ms) + go !l (Step (TryF qfn b) ms) = Step (SummarizedMessage $ AtLevel l $ (LogTryingF qfn b)) (go l ms) + go !l (Step (TryS qsn b) ms) = Step (SummarizedMessage $ AtLevel l $ (LogTryingS qsn b)) (go l ms) + go !l (Step (Next (Goal (P qpn) gr)) ms) = Step (SummarizedMessage $ AtLevel l $ (LogPackageGoal qpn gr)) (go l ms) + go !l (Step (Next _) ms) = go l ms -- ignore flag goals in the log - showFailure :: ConflictSet -> FailReason -> String - showFailure c fr = "fail" ++ showFR c fr + -- 'Skip' should always be handled by 'goPSkip' in the case above. + go !l (Step (Skip conflicts) ms) = Step (SummarizedMessage $ AtLevel l $ (LogSkipping conflicts)) (go l ms) + go !l (Step (Success) ms) = Step (SummarizedMessage $ AtLevel l $ LogSuccessMsg) (go l ms) + go !l (Step (Failure c fr) ms) = Step (SummarizedMessage $ AtLevel l $ (LogFailureMsg c fr)) (go l ms) -- special handler for many subsequent package rejections goPReject :: Int @@ -94,11 +135,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' = 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 (SummarizedMessage $ AtLevel l $ (LogRejectMany qpn is c fr)) (go l ms) -- Handle many subsequent skipped package instances. goPSkip :: Int @@ -106,20 +148,11 @@ 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' = 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 (SummarizedMessage $ AtLevel l $ (LogSkipMany qpn is conflicts)) (go l ms) -- | Display the set of 'Conflicts' for a skipped package version. showConflicts :: Set CS.Conflict -> String diff --git a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs index e773492ae74..82742821ecb 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 ( 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..a4c9ffe3260 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs @@ -1,11 +1,25 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE DerivingStrategies #-} module Distribution.Solver.Types.Progress ( Progress(..) , foldProgress + , Message(..) + , Entry(..) + , EntryMessage(..) + , 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 +61,35 @@ 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 + deriving stock (Show, Eq) + +data EntryMessage = AtLevel Int Entry + deriving stock (Show, Eq) + +data SummarizedMessage = SummarizedMessage EntryMessage | ErrorMessage String + deriving stock (Show, Eq) \ No newline at end of file diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index 37e0cbdf1ee..7d91eaa6122 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -14,6 +14,9 @@ -- Portability : portable -- -- Top level interface to dependency resolution. +{-# LANGUAGE InstanceSigs #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module Distribution.Client.Dependency ( -- * The main package dependency resolver DepResolverParams @@ -59,6 +62,7 @@ module Distribution.Client.Dependency , setSolveExecutables , setGoalOrder , setSolverVerbosity + , setSolverOutputJson , removeLowerBounds , removeUpperBounds , addDefaultSetupDependencies @@ -68,27 +72,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 +140,99 @@ 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 + ( SummarizedMessage(..), + Progress(..), + foldProgress, + Entry(..), + EntryMessage(..) ) 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 qualified Data.Map as Map -import qualified Data.Set as Set +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 Distribution.Client.Utils.Json + ( encodeToString, ToJSON(..), (.=), object, Value(String) ) -- ------------------------------------------------------------ @@ -199,6 +273,7 @@ data DepResolverParams = DepResolverParams , depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering) -- ^ Function to override the solver's goal-ordering heuristics. , depResolverVerbosity :: Verbosity + , depResolverOutputJson :: Bool } showDepResolverParams :: DepResolverParams -> String @@ -245,6 +320,8 @@ showDepResolverParams p = showLabeledConstraint (LabeledPackageConstraint pc src) = showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")" + + -- | A package selection preference for a particular package. -- -- Preferences are soft constraints that the dependency resolver should try to @@ -296,6 +373,7 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex = , depResolverSolveExecutables = SolveExecutables True , depResolverGoalOrder = Nothing , depResolverVerbosity = normal + , depResolverOutputJson = False } addTargets @@ -431,6 +509,12 @@ setSolverVerbosity verbosity params = { depResolverVerbosity = verbosity } +setSolverOutputJson :: Bool -> DepResolverParams -> DepResolverParams +setSolverOutputJson outputJson params = + params + { depResolverOutputJson = outputJson + } + -- | Some packages are specific to a given compiler version and should never be -- reinstalled. dontInstallNonReinstallablePackages :: DepResolverParams -> DepResolverParams @@ -769,32 +853,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 @@ -818,11 +903,17 @@ resolveDependencies platform comp pkgConfigDB params = solveExes order verbosity + outputJson ) = if asBool (depResolverAllowBootLibInstalls params) then params else dontInstallNonReinstallablePackages params + formatProgress :: Progress SummarizedMessage String a -> Progress String String a + formatProgress p = foldProgress (\x xs -> Step (formatter x) xs) Fail Done p + where + formatter = if outputJson then encodeToString else renderSummarizedMessage + preferences :: PackageName -> PackagePreferences preferences = interpretPackagesPreference targets defpref prefs @@ -1139,6 +1230,7 @@ resolveWithoutDependencies _onlyConstrained _order _verbosity + _outputJson ) = collectEithers $ map selectPackage (Set.toList targets) where @@ -1215,3 +1307,33 @@ instance Show ResolveNoDepsError where ++ prettyShow name ++ " that satisfies " ++ prettyShow (simplifyVersionRange ver) + +------------------------------------------------------------------------------- +-- Orphans +------------------------------------------------------------------------------- + +instance ToJSON SummarizedMessage where + toJSON :: SummarizedMessage -> Value + toJSON (SummarizedMessage x) = object ["status" .= String "success", "message" .= toJSON x] + toJSON (ErrorMessage x) = object ["status" .= String "failure", "message" .= String x] + +instance ToJSON EntryMessage where + toJSON :: EntryMessage -> Value + toJSON (AtLevel _ x) = toJSON x + +instance ToJSON Entry where + toJSON :: Entry -> Value + toJSON (LogPackageGoal _ _) = error "To be implemented..." + toJSON (LogRejectF _ _ _ _) = error "To be implemented..." + toJSON (LogRejectS _ _ _ _) = error "TODO" + toJSON (LogSkipping _) = error "To be implemented..." + toJSON (LogTryingF _ _) = error "To be implemented..." + toJSON (LogTryingP _ _ _) = error "To be implemented..." + toJSON (LogTryingS _ _) = error "To be implemented..." + toJSON (LogRejectMany _ _ _ _) = error "To be implemented..." + toJSON (LogSkipMany _ _ _) = error "To be implemented..." + toJSON (LogUnknownPackage _ _) = error "To be implemented..." + toJSON (LogSuccessMsg) = error "To be implemented..." + toJSON (LogFailureMsg _ _) = error "To be implemented..." + + -- TODO: write a test that assert that: toJSON fromJson == fromJSON toJson == id \ No newline at end of file