diff --git a/Cabal/doc/nix-local-build.rst b/Cabal/doc/nix-local-build.rst index dbba194206f..1535cbb2b37 100644 --- a/Cabal/doc/nix-local-build.rst +++ b/Cabal/doc/nix-local-build.rst @@ -2115,6 +2115,23 @@ Most users generally won't need these. The command line variant of this field is ``--(no-)count-conflicts``. +.. cfg-field:: fine-grained-conflicts: boolean + --fine-grained-conflicts + --no-fine-grained-conflicts + :synopsis: Skip a version of a package if it does not resolve any conflicts + encountered in the last version (solver optimization). + + :default: True + + When enabled, the solver will skip a version of a package if it does not + resolve any of the conflicts encountered in the last version of that + package. For example, if ``foo-1.2`` depended on ``bar``, and the solver + couldn't find consistent versions for ``bar``'s dependencies, then the + solver would skip ``foo-1.1`` if it also depended on ``bar``. + + The command line variant of this field is + ``--(no-)fine-grained-conflicts``. + .. cfg-field:: minimize-conflict-set: boolean --minimize-conflict-set --no-minimize-conflict-set diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 944175725c8..5072cab7189 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -312,6 +312,7 @@ instance Semigroup SavedConfig where installMaxBackjumps = combine installMaxBackjumps, installReorderGoals = combine installReorderGoals, installCountConflicts = combine installCountConflicts, + installFineGrainedConflicts = combine installFineGrainedConflicts, installMinimizeConflictSet = combine installMinimizeConflictSet, installIndependentGoals = combine installIndependentGoals, installShadowPkgs = combine installShadowPkgs, diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs index faef55062a5..f73f2e46086 100644 --- a/cabal-install/Distribution/Client/Dependency.hs +++ b/cabal-install/Distribution/Client/Dependency.hs @@ -47,6 +47,7 @@ module Distribution.Client.Dependency ( setPreferenceDefault, setReorderGoals, setCountConflicts, + setFineGrainedConflicts, setMinimizeConflictSet, setIndependentGoals, setAvoidReinstalls, @@ -159,6 +160,7 @@ data DepResolverParams = DepResolverParams { depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage, depResolverReorderGoals :: ReorderGoals, depResolverCountConflicts :: CountConflicts, + depResolverFineGrainedConflicts :: FineGrainedConflicts, depResolverMinimizeConflictSet :: MinimizeConflictSet, depResolverIndependentGoals :: IndependentGoals, depResolverAvoidReinstalls :: AvoidReinstalls, @@ -197,6 +199,7 @@ showDepResolverParams p = ++ "\nstrategy: " ++ show (depResolverPreferenceDefault p) ++ "\nreorder goals: " ++ show (asBool (depResolverReorderGoals p)) ++ "\ncount conflicts: " ++ show (asBool (depResolverCountConflicts p)) + ++ "\nfine grained conflicts: " ++ show (asBool (depResolverFineGrainedConflicts p)) ++ "\nminimize conflict set: " ++ show (asBool (depResolverMinimizeConflictSet p)) ++ "\nindependent goals: " ++ show (asBool (depResolverIndependentGoals p)) ++ "\navoid reinstalls: " ++ show (asBool (depResolverAvoidReinstalls p)) @@ -254,6 +257,7 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex = depResolverSourcePkgIndex = sourcePkgIndex, depResolverReorderGoals = ReorderGoals False, depResolverCountConflicts = CountConflicts True, + depResolverFineGrainedConflicts = FineGrainedConflicts True, depResolverMinimizeConflictSet = MinimizeConflictSet False, depResolverIndependentGoals = IndependentGoals False, depResolverAvoidReinstalls = AvoidReinstalls False, @@ -310,6 +314,12 @@ setCountConflicts count params = depResolverCountConflicts = count } +setFineGrainedConflicts :: FineGrainedConflicts -> DepResolverParams -> DepResolverParams +setFineGrainedConflicts fineGrained params = + params { + depResolverFineGrainedConflicts = fineGrained + } + setMinimizeConflictSet :: MinimizeConflictSet -> DepResolverParams -> DepResolverParams setMinimizeConflictSet minimize params = params { @@ -755,7 +765,8 @@ resolveDependencies platform comp pkgConfigDB solver params = Step (showDepResolverParams finalparams) $ fmap (validateSolverResult platform comp indGoals) - $ runSolver solver (SolverConfig reordGoals cntConflicts minimize indGoals noReinstalls + $ runSolver solver (SolverConfig reordGoals cntConflicts fineGrained minimize + indGoals noReinstalls shadowing strFlags allowBootLibs onlyConstrained_ maxBkjumps enableBj solveExes order verbosity (PruneAfterFirstSuccess False)) platform comp installedPkgIndex sourcePkgIndex @@ -769,6 +780,7 @@ resolveDependencies platform comp pkgConfigDB solver params = sourcePkgIndex reordGoals cntConflicts + fineGrained minimize indGoals noReinstalls @@ -1015,9 +1027,9 @@ resolveWithoutDependencies :: DepResolverParams -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] resolveWithoutDependencies (DepResolverParams targets constraints prefs defpref installedPkgIndex sourcePkgIndex - _reorderGoals _countConflicts _minimizeConflictSet - _indGoals _avoidReinstalls _shadowing _strFlags - _maxBjumps _enableBj _solveExes + _reorderGoals _countConflicts _fineGrained + _minimizeConflictSet _indGoals _avoidReinstalls + _shadowing _strFlags _maxBjumps _enableBj _solveExes _allowBootLibInstalls _onlyConstrained _order _verbosity) = collectEithers $ map selectPackage (Set.toList targets) where diff --git a/cabal-install/Distribution/Client/Fetch.hs b/cabal-install/Distribution/Client/Fetch.hs index ac0a74a907d..11d8cfa299e 100644 --- a/cabal-install/Distribution/Client/Fetch.hs +++ b/cabal-install/Distribution/Client/Fetch.hs @@ -162,6 +162,8 @@ planPackages verbosity comp platform fetchFlags . setCountConflicts countConflicts + . setFineGrainedConflicts fineGrainedConflicts + . setMinimizeConflictSet minimizeConflictSet . setShadowPkgs shadowPkgs @@ -199,6 +201,7 @@ planPackages verbosity comp platform fetchFlags reorderGoals = fromFlag (fetchReorderGoals fetchFlags) countConflicts = fromFlag (fetchCountConflicts fetchFlags) + fineGrainedConflicts = fromFlag (fetchFineGrainedConflicts fetchFlags) minimizeConflictSet = fromFlag (fetchMinimizeConflictSet fetchFlags) independentGoals = fromFlag (fetchIndependentGoals fetchFlags) shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags) diff --git a/cabal-install/Distribution/Client/Freeze.hs b/cabal-install/Distribution/Client/Freeze.hs index 3b8b2c193ab..99694ed9d3b 100644 --- a/cabal-install/Distribution/Client/Freeze.hs +++ b/cabal-install/Distribution/Client/Freeze.hs @@ -175,6 +175,8 @@ planPackages verbosity comp platform mSandboxPkgInfo freezeFlags . setCountConflicts countConflicts + . setFineGrainedConflicts fineGrainedConflicts + . setMinimizeConflictSet minimizeConflictSet . setShadowPkgs shadowPkgs @@ -207,6 +209,7 @@ planPackages verbosity comp platform mSandboxPkgInfo freezeFlags reorderGoals = fromFlag (freezeReorderGoals freezeFlags) countConflicts = fromFlag (freezeCountConflicts freezeFlags) + fineGrainedConflicts = fromFlag (freezeFineGrainedConflicts freezeFlags) minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags) independentGoals = fromFlag (freezeIndependentGoals freezeFlags) shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags) diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index 82f91e83a2d..229816d4457 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -395,6 +395,8 @@ planPackages verbosity comp platform mSandboxPkgInfo solver . setCountConflicts countConflicts + . setFineGrainedConflicts fineGrainedConflicts + . setMinimizeConflictSet minimizeConflictSet . setAvoidReinstalls avoidReinstalls @@ -463,6 +465,7 @@ planPackages verbosity comp platform mSandboxPkgInfo solver fromFlag (installReinstall installFlags) reorderGoals = fromFlag (installReorderGoals installFlags) countConflicts = fromFlag (installCountConflicts installFlags) + fineGrainedConflicts = fromFlag (installFineGrainedConflicts installFlags) minimizeConflictSet = fromFlag (installMinimizeConflictSet installFlags) independentGoals = fromFlag (installIndependentGoals installFlags) avoidReinstalls = fromFlag (installAvoidReinstalls installFlags) diff --git a/cabal-install/Distribution/Client/ProjectConfig.hs b/cabal-install/Distribution/Client/ProjectConfig.hs index 8282a6beaf2..234c5f13395 100644 --- a/cabal-install/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/Distribution/Client/ProjectConfig.hs @@ -250,6 +250,7 @@ resolveSolverSettings ProjectConfig{ | otherwise -> Just n solverSettingReorderGoals = fromFlag projectConfigReorderGoals solverSettingCountConflicts = fromFlag projectConfigCountConflicts + solverSettingFineGrainedConflicts = fromFlag projectConfigFineGrainedConflicts solverSettingMinimizeConflictSet = fromFlag projectConfigMinimizeConflictSet solverSettingStrongFlags = fromFlag projectConfigStrongFlags solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls @@ -271,6 +272,7 @@ resolveSolverSettings ProjectConfig{ projectConfigMaxBackjumps = Flag defaultMaxBackjumps, projectConfigReorderGoals = Flag (ReorderGoals False), projectConfigCountConflicts = Flag (CountConflicts True), + projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts True), projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet False), projectConfigStrongFlags = Flag (StrongFlags False), projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False), diff --git a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs index 53975930bf2..66f009a5855 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs @@ -374,6 +374,7 @@ convertLegacyAllPackageFlags globalFlags configFlags --installUpgradeDeps = projectConfigUpgradeDeps, installReorderGoals = projectConfigReorderGoals, installCountConflicts = projectConfigCountConflicts, + installFineGrainedConflicts = projectConfigFineGrainedConflicts, installMinimizeConflictSet = projectConfigMinimizeConflictSet, installPerComponent = projectConfigPerComponent, installIndependentGoals = projectConfigIndependentGoals, @@ -611,6 +612,7 @@ convertToLegacySharedConfig installUpgradeDeps = mempty, --projectConfigUpgradeDeps, installReorderGoals = projectConfigReorderGoals, installCountConflicts = projectConfigCountConflicts, + installFineGrainedConflicts = projectConfigFineGrainedConflicts, installMinimizeConflictSet = projectConfigMinimizeConflictSet, installIndependentGoals = projectConfigIndependentGoals, installShadowPkgs = mempty, --projectConfigShadowPkgs, @@ -1004,8 +1006,9 @@ legacySharedConfigFieldDescrs = , "one-shot", "jobs", "keep-going", "offline", "per-component" -- solver flags: , "max-backjumps", "reorder-goals", "count-conflicts" - , "minimize-conflict-set", "independent-goals" - , "strong-flags" , "allow-boot-library-installs", "reject-unconstrained-dependencies", "index-state" + , "fine-grained-conflicts" , "minimize-conflict-set", "independent-goals" + , "strong-flags" , "allow-boot-library-installs" + , "reject-unconstrained-dependencies", "index-state" ] . commandOptionsToFields ) (installOptions ParseArgs) diff --git a/cabal-install/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/Distribution/Client/ProjectConfig/Types.hs index 7e02e3863a9..8b504f94568 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Types.hs @@ -195,6 +195,7 @@ data ProjectConfigShared projectConfigMaxBackjumps :: Flag Int, projectConfigReorderGoals :: Flag ReorderGoals, projectConfigCountConflicts :: Flag CountConflicts, + projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts, projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet, projectConfigStrongFlags :: Flag StrongFlags, projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls, @@ -400,6 +401,7 @@ data SolverSettings solverSettingMaxBackjumps :: Maybe Int, solverSettingReorderGoals :: ReorderGoals, solverSettingCountConflicts :: CountConflicts, + solverSettingFineGrainedConflicts :: FineGrainedConflicts, solverSettingMinimizeConflictSet :: MinimizeConflictSet, solverSettingStrongFlags :: StrongFlags, solverSettingAllowBootLibInstalls :: AllowBootLibInstalls, diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index d139379da06..ae31ebb06da 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -958,6 +958,8 @@ planPackages verbosity comp platform solver SolverSettings{..} . setCountConflicts solverSettingCountConflicts + . setFineGrainedConflicts solverSettingFineGrainedConflicts + . setMinimizeConflictSet solverSettingMinimizeConflictSet --TODO: [required eventually] should only be configurable for diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index b063c03c80b..9dce8c24dc8 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -1003,6 +1003,7 @@ data FetchFlags = FetchFlags { fetchMaxBackjumps :: Flag Int, fetchReorderGoals :: Flag ReorderGoals, fetchCountConflicts :: Flag CountConflicts, + fetchFineGrainedConflicts :: Flag FineGrainedConflicts, fetchMinimizeConflictSet :: Flag MinimizeConflictSet, fetchIndependentGoals :: Flag IndependentGoals, fetchShadowPkgs :: Flag ShadowPkgs, @@ -1023,6 +1024,7 @@ defaultFetchFlags = FetchFlags { fetchMaxBackjumps = Flag defaultMaxBackjumps, fetchReorderGoals = Flag (ReorderGoals False), fetchCountConflicts = Flag (CountConflicts True), + fetchFineGrainedConflicts = Flag (FineGrainedConflicts True), fetchMinimizeConflictSet = Flag (MinimizeConflictSet False), fetchIndependentGoals = Flag (IndependentGoals False), fetchShadowPkgs = Flag (ShadowPkgs False), @@ -1085,6 +1087,7 @@ fetchCommand = CommandUI { fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v }) fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v }) fetchCountConflicts (\v flags -> flags { fetchCountConflicts = v }) + fetchFineGrainedConflicts (\v flags -> flags { fetchFineGrainedConflicts = v }) fetchMinimizeConflictSet (\v flags -> flags { fetchMinimizeConflictSet = v }) fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v }) fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v }) @@ -1106,6 +1109,7 @@ data FreezeFlags = FreezeFlags { freezeMaxBackjumps :: Flag Int, freezeReorderGoals :: Flag ReorderGoals, freezeCountConflicts :: Flag CountConflicts, + freezeFineGrainedConflicts :: Flag FineGrainedConflicts, freezeMinimizeConflictSet :: Flag MinimizeConflictSet, freezeIndependentGoals :: Flag IndependentGoals, freezeShadowPkgs :: Flag ShadowPkgs, @@ -1124,6 +1128,7 @@ defaultFreezeFlags = FreezeFlags { freezeMaxBackjumps = Flag defaultMaxBackjumps, freezeReorderGoals = Flag (ReorderGoals False), freezeCountConflicts = Flag (CountConflicts True), + freezeFineGrainedConflicts = Flag (FineGrainedConflicts True), freezeMinimizeConflictSet = Flag (MinimizeConflictSet False), freezeIndependentGoals = Flag (IndependentGoals False), freezeShadowPkgs = Flag (ShadowPkgs False), @@ -1177,6 +1182,7 @@ freezeCommand = CommandUI { freezeMaxBackjumps (\v flags -> flags { freezeMaxBackjumps = v }) freezeReorderGoals (\v flags -> flags { freezeReorderGoals = v }) freezeCountConflicts (\v flags -> flags { freezeCountConflicts = v }) + freezeFineGrainedConflicts (\v flags -> flags { freezeFineGrainedConflicts = v }) freezeMinimizeConflictSet (\v flags -> flags { freezeMinimizeConflictSet = v }) freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v }) freezeShadowPkgs (\v flags -> flags { freezeShadowPkgs = v }) @@ -1749,6 +1755,7 @@ data InstallFlags = InstallFlags { installMaxBackjumps :: Flag Int, installReorderGoals :: Flag ReorderGoals, installCountConflicts :: Flag CountConflicts, + installFineGrainedConflicts :: Flag FineGrainedConflicts, installMinimizeConflictSet :: Flag MinimizeConflictSet, installIndependentGoals :: Flag IndependentGoals, installShadowPkgs :: Flag ShadowPkgs, @@ -1798,6 +1805,7 @@ defaultInstallFlags = InstallFlags { installMaxBackjumps = Flag defaultMaxBackjumps, installReorderGoals = Flag (ReorderGoals False), installCountConflicts = Flag (CountConflicts True), + installFineGrainedConflicts = Flag (FineGrainedConflicts True), installMinimizeConflictSet = Flag (MinimizeConflictSet False), installIndependentGoals= Flag (IndependentGoals False), installShadowPkgs = Flag (ShadowPkgs False), @@ -2028,6 +2036,7 @@ installOptions showOrParseArgs = installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v }) installReorderGoals (\v flags -> flags { installReorderGoals = v }) installCountConflicts (\v flags -> flags { installCountConflicts = v }) + installFineGrainedConflicts (\v flags -> flags { installFineGrainedConflicts = v }) installMinimizeConflictSet (\v flags -> flags { installMinimizeConflictSet = v }) installIndependentGoals (\v flags -> flags { installIndependentGoals = v }) installShadowPkgs (\v flags -> flags { installShadowPkgs = v }) @@ -2860,6 +2869,7 @@ optionSolverFlags :: ShowOrParseArgs -> (flags -> Flag Int ) -> (Flag Int -> flags -> flags) -> (flags -> Flag ReorderGoals) -> (Flag ReorderGoals -> flags -> flags) -> (flags -> Flag CountConflicts) -> (Flag CountConflicts -> flags -> flags) + -> (flags -> Flag FineGrainedConflicts) -> (Flag FineGrainedConflicts -> flags -> flags) -> (flags -> Flag MinimizeConflictSet) -> (Flag MinimizeConflictSet -> flags -> flags) -> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags) -> (flags -> Flag ShadowPkgs) -> (Flag ShadowPkgs -> flags -> flags) @@ -2868,8 +2878,8 @@ optionSolverFlags :: ShowOrParseArgs -> (flags -> Flag OnlyConstrained) -> (Flag OnlyConstrained -> flags -> flags) -> [OptionField flags] optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc - getmc setmc getig setig getsip setsip getstrfl setstrfl - getib setib getoc setoc = + getfgc setfgc getmc setmc getig setig getsip setsip + getstrfl setstrfl getib setib getoc setoc = [ option [] ["max-backjumps"] ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") getmbj setmbj @@ -2885,6 +2895,11 @@ optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc (fmap asBool . getcc) (setcc . fmap CountConflicts) (yesNoOpt showOrParseArgs) + , option [] ["fine-grained-conflicts"] + "Skip a version of a package if it does not resolve the conflicts encountered in the last version, as a solver optimization (default)." + (fmap asBool . getfgc) + (setfgc . fmap FineGrainedConflicts) + (yesNoOpt showOrParseArgs) , option [] ["minimize-conflict-set"] ("When there is no solution, try to improve the error message by finding " ++ "a minimal conflict set (default: false). May increase run time " diff --git a/cabal-install/Distribution/Solver/Modular/Builder.hs b/cabal-install/Distribution/Solver/Modular/Builder.hs index 322d1056820..eb11a36aa16 100644 --- a/cabal-install/Distribution/Solver/Modular/Builder.hs +++ b/cabal-install/Distribution/Solver/Modular/Builder.hs @@ -145,7 +145,9 @@ addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals }) -- and then handle each instance in turn. addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) = case M.lookup pn idx of - Nothing -> FailF (varToConflictSet (P qpn) `CS.union` goalReasonToCS gr) UnknownPackage + Nothing -> FailF + (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr) + UnknownPackage Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) -> ([], POption i Nothing, bs { next = Instance qpn info })) (M.toList pis))) diff --git a/cabal-install/Distribution/Solver/Modular/ConflictSet.hs b/cabal-install/Distribution/Solver/Modular/ConflictSet.hs index 28991e3da04..190e811f06f 100644 --- a/cabal-install/Distribution/Solver/Modular/ConflictSet.hs +++ b/cabal-install/Distribution/Solver/Modular/ConflictSet.hs @@ -10,7 +10,9 @@ -- > import qualified Distribution.Solver.Modular.ConflictSet as CS module Distribution.Solver.Modular.ConflictSet ( ConflictSet -- opaque + , Conflict(..) , ConflictMap + , OrderedVersionRange(..) #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin #endif @@ -26,19 +28,21 @@ module Distribution.Solver.Modular.ConflictSet ( , delete , empty , singleton + , singletonWithConflict , size , member + , lookup , filter , fromList ) where -import Prelude hiding (filter) +import Prelude hiding (lookup) import Data.List (intercalate, sortBy) import Data.Map (Map) import Data.Set (Set) import Data.Function (on) +import qualified Data.Map.Strict as M import qualified Data.Set as S -import qualified Data.Map as M #ifdef DEBUG_CONFLICT_SETS import Data.Tree @@ -46,15 +50,14 @@ import GHC.Stack #endif import Distribution.Solver.Modular.Var +import Distribution.Solver.Modular.Version import Distribution.Solver.Types.PackagePath --- | The set of variables involved in a solver conflict --- --- Since these variables should be preprocessed in some way, this type is --- kept abstract. +-- | The set of variables involved in a solver conflict, each paired with +-- details about the conflict. data ConflictSet = CS { - -- | The set of variables involved on the conflict - conflictSetToSet :: !(Set (Var QPN)) + -- | The set of variables involved in the conflict + conflictSetToMap :: !(Map (Var QPN) (Set Conflict)) #ifdef DEBUG_CONFLICT_SETS -- | The origin of the conflict set @@ -72,11 +75,48 @@ data ConflictSet = CS { } deriving (Show) +-- | More detailed information about how a conflict set variable caused a +-- conflict. This information can be used to determine whether a second value +-- for that variable would lead to the same conflict. +-- +-- TODO: Handle dependencies under flags or stanzas. +data Conflict = + + -- | The conflict set variable represents a package which depends on the + -- specified problematic package. For example, the conflict set entry + -- '(P x, GoalConflict y)' means that package x introduced package y, and y + -- led to a conflict. + GoalConflict QPN + + -- | The conflict set variable represents a package with a constraint that + -- excluded the specified package and version. For example, the conflict set + -- entry '(P x, VersionConstraintConflict y (mkVersion [2, 0]))' means that + -- package x's constraint on y excluded y-2.0. + | VersionConstraintConflict QPN Ver + + -- | The conflict set variable represents a package that was excluded by a + -- constraint from the specified package. For example, the conflict set + -- entry '(P x, VersionConflict y (orLaterVersion (mkVersion [2, 0])))' + -- means that package y's constraint 'x >= 2.0' excluded some version of x. + | VersionConflict QPN OrderedVersionRange + + -- | Any other conflict. + | OtherConflict + deriving (Eq, Ord, Show) + +-- | Version range with an 'Ord' instance. +newtype OrderedVersionRange = OrderedVersionRange VR + deriving (Eq, Show) + +-- TODO: Avoid converting the version ranges to strings. +instance Ord OrderedVersionRange where + compare = compare `on` show + instance Eq ConflictSet where - (==) = (==) `on` conflictSetToSet + (==) = (==) `on` conflictSetToMap instance Ord ConflictSet where - compare = compare `on` conflictSetToSet + compare = compare `on` conflictSetToMap showConflictSet :: ConflictSet -> String showConflictSet = intercalate ", " . map showVar . toList @@ -102,10 +142,10 @@ showCS showCount cm = -------------------------------------------------------------------------------} toSet :: ConflictSet -> Set (Var QPN) -toSet = conflictSetToSet +toSet = M.keysSet . conflictSetToMap toList :: ConflictSet -> [Var QPN] -toList = S.toList . conflictSetToSet +toList = M.keys . conflictSetToMap union :: #ifdef DEBUG_CONFLICT_SETS @@ -113,7 +153,7 @@ union :: #endif ConflictSet -> ConflictSet -> ConflictSet union cs cs' = CS { - conflictSetToSet = S.union (conflictSetToSet cs) (conflictSetToSet cs') + conflictSetToMap = M.unionWith S.union (conflictSetToMap cs) (conflictSetToMap cs') #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc (map conflictSetOrigin [cs, cs']) #endif @@ -125,7 +165,7 @@ unions :: #endif [ConflictSet] -> ConflictSet unions css = CS { - conflictSetToSet = S.unions (map conflictSetToSet css) + conflictSetToMap = M.unionsWith S.union (map conflictSetToMap css) #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc (map conflictSetOrigin css) #endif @@ -137,7 +177,7 @@ insert :: #endif Var QPN -> ConflictSet -> ConflictSet insert var cs = CS { - conflictSetToSet = S.insert var (conflictSetToSet cs) + conflictSetToMap = M.insert var (S.singleton OtherConflict) (conflictSetToMap cs) #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [conflictSetOrigin cs] #endif @@ -145,7 +185,7 @@ insert var cs = CS { delete :: Var QPN -> ConflictSet -> ConflictSet delete var cs = CS { - conflictSetToSet = S.delete var (conflictSetToSet cs) + conflictSetToMap = M.delete var (conflictSetToMap cs) } empty :: @@ -154,7 +194,7 @@ empty :: #endif ConflictSet empty = CS { - conflictSetToSet = S.empty + conflictSetToMap = M.empty #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [] #endif @@ -165,30 +205,28 @@ singleton :: (?loc :: CallStack) => #endif Var QPN -> ConflictSet -singleton var = CS { - conflictSetToSet = S.singleton var +singleton var = singletonWithConflict var OtherConflict + +singletonWithConflict :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + Var QPN -> Conflict -> ConflictSet +singletonWithConflict var conflict = CS { + conflictSetToMap = M.singleton var (S.singleton conflict) #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [] #endif } size :: ConflictSet -> Int -size = S.size . conflictSetToSet +size = M.size . conflictSetToMap member :: Var QPN -> ConflictSet -> Bool -member var = S.member var . conflictSetToSet +member var = M.member var . conflictSetToMap -filter :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - (Var QPN -> Bool) -> ConflictSet -> ConflictSet -filter p cs = CS { - conflictSetToSet = S.filter p (conflictSetToSet cs) -#ifdef DEBUG_CONFLICT_SETS - , conflictSetOrigin = Node ?loc [conflictSetOrigin cs] -#endif - } +lookup :: Var QPN -> ConflictSet -> Maybe (Set Conflict) +lookup var = M.lookup var . conflictSetToMap fromList :: #ifdef DEBUG_CONFLICT_SETS @@ -196,7 +234,7 @@ fromList :: #endif [Var QPN] -> ConflictSet fromList vars = CS { - conflictSetToSet = S.fromList vars + conflictSetToMap = M.fromList [(var, S.singleton OtherConflict) | var <- vars] #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [] #endif diff --git a/cabal-install/Distribution/Solver/Modular/Dependency.hs b/cabal-install/Distribution/Solver/Modular/Dependency.hs index 6a6bb333c85..8fc55f5724d 100644 --- a/cabal-install/Distribution/Solver/Modular/Dependency.hs +++ b/cabal-install/Distribution/Solver/Modular/Dependency.hs @@ -32,8 +32,11 @@ module Distribution.Solver.Modular.Dependency ( , QGoalReason , goalToVar , varToConflictSet - , goalReasonToCS - , dependencyReasonToCS + , goalReasonToConflictSet + , goalReasonToConflictSetWithConflict + , dependencyReasonToConflictSet + , dependencyReasonToConflictSetWithVersionConstraintConflict + , dependencyReasonToConflictSetWithVersionConflict ) where import Prelude () @@ -279,14 +282,30 @@ goalToVar (Goal v _) = v varToConflictSet :: Var QPN -> ConflictSet varToConflictSet = CS.singleton -goalReasonToCS :: GoalReason QPN -> ConflictSet -goalReasonToCS UserGoal = CS.empty -goalReasonToCS (DependencyGoal dr) = dependencyReasonToCS dr +-- | Convert a 'GoalReason' to a 'ConflictSet' that can be used when the goal +-- leads to a conflict. +goalReasonToConflictSet :: GoalReason QPN -> ConflictSet +goalReasonToConflictSet UserGoal = CS.empty +goalReasonToConflictSet (DependencyGoal dr) = dependencyReasonToConflictSet dr + +-- | Convert a 'GoalReason' to a 'ConflictSet' containing the reason that the +-- conflict occurred, namely the conflict set variables caused a conflict by +-- introducing the given package goal. See the documentation for 'GoalConflict'. +-- +-- This function currently only specifies the reason for the conflict in the +-- simple case where the 'GoalReason' does not involve any flags or stanzas. +-- Otherwise, it falls back to calling 'goalReasonToConflictSet'. +goalReasonToConflictSetWithConflict :: QPN -> GoalReason QPN -> ConflictSet +goalReasonToConflictSetWithConflict goal (DependencyGoal (DependencyReason qpn flags stanzas)) + | M.null flags && S.null stanzas = + CS.singletonWithConflict (P qpn) $ CS.GoalConflict goal +goalReasonToConflictSetWithConflict _ gr = goalReasonToConflictSet gr -- | This function returns the solver variables responsible for the dependency. --- It drops the flag and stanza values, which are only needed for log messages. -dependencyReasonToCS :: DependencyReason QPN -> ConflictSet -dependencyReasonToCS (DependencyReason qpn flags stanzas) = +-- It drops the values chosen for flag and stanza variables, which are only +-- needed for log messages. +dependencyReasonToConflictSet :: DependencyReason QPN -> ConflictSet +dependencyReasonToConflictSet (DependencyReason qpn flags stanzas) = CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas) where -- Filter out any flags that introduced the dependency with both values. @@ -297,3 +316,40 @@ dependencyReasonToCS (DependencyReason qpn flags stanzas) = stanzaToVar :: Stanza -> Var QPN stanzaToVar = S . SN qpn + +-- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the +-- conflict occurred because the conflict set variables introduced a problematic +-- version constraint. See the documentation for 'VersionConstraintConflict'. +-- +-- This function currently only specifies the reason for the conflict in the +-- simple case where the 'DependencyReason' does not involve any flags or +-- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. +dependencyReasonToConflictSetWithVersionConstraintConflict :: QPN + -> Ver + -> DependencyReason QPN + -> ConflictSet +dependencyReasonToConflictSetWithVersionConstraintConflict + dependency excludedVersion dr@(DependencyReason qpn flags stanzas) + | M.null flags && S.null stanzas = + CS.singletonWithConflict (P qpn) $ + CS.VersionConstraintConflict dependency excludedVersion + | otherwise = dependencyReasonToConflictSet dr + +-- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the +-- conflict occurred because the conflict set variables introduced a version of +-- a package that was excluded by a version constraint. See the documentation +-- for 'VersionConflict'. +-- +-- This function currently only specifies the reason for the conflict in the +-- simple case where the 'DependencyReason' does not involve any flags or +-- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. +dependencyReasonToConflictSetWithVersionConflict :: QPN + -> CS.OrderedVersionRange + -> DependencyReason QPN + -> ConflictSet +dependencyReasonToConflictSetWithVersionConflict + pkgWithVersionConstraint constraint dr@(DependencyReason qpn flags stanzas) + | M.null flags && S.null stanzas = + CS.singletonWithConflict (P qpn) $ + CS.VersionConflict pkgWithVersionConstraint constraint + | otherwise = dependencyReasonToConflictSet dr diff --git a/cabal-install/Distribution/Solver/Modular/Explore.hs b/cabal-install/Distribution/Solver/Modular/Explore.hs index f3bfb7c30a4..3ac28a462ad 100644 --- a/cabal-install/Distribution/Solver/Modular/Explore.hs +++ b/cabal-install/Distribution/Solver/Modular/Explore.hs @@ -7,19 +7,28 @@ import qualified Distribution.Solver.Types.Progress as P import Data.Foldable as F import Data.List as L (foldl') +import Data.Maybe (fromMaybe) import Data.Map.Strict as M +import Data.Set as S + +import Distribution.Simple.Setup (asBool) import Distribution.Solver.Modular.Assignment import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Log import Distribution.Solver.Modular.Message +import Distribution.Solver.Modular.Package import qualified Distribution.Solver.Modular.PSQ as P import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.RetryLog import Distribution.Solver.Modular.Tree +import Distribution.Solver.Modular.Version import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts(..)) +import Distribution.Solver.Types.Settings + (CountConflicts(..), EnableBackjumping(..), FineGrainedConflicts(..)) +import Distribution.Types.VersionRange (anyVersion) -- | This function takes the variable we're currently considering, a -- last conflict set and a list of children's logs. Each log yields @@ -43,25 +52,70 @@ import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts -- with the (virtual) option not to choose anything for the current -- variable. See also the comments for 'avoidSet'. -- -backjump :: Maybe Int -> EnableBackjumping -> Var QPN - -> ConflictSet -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a) +-- We can also skip a child if it does not resolve any of the conflicts paired +-- with the current variable in the previous child's conflict set. 'backjump' +-- takes a function to determine whether a child can be skipped. If the child +-- can be skipped, the function returns a new conflict set to be merged with the +-- previous conflict set. +-- +backjump :: forall w k a . Maybe Int + -> EnableBackjumping + -> FineGrainedConflicts + + -> (k -> S.Set CS.Conflict -> Maybe ConflictSet) + -- ^ Function that determines whether the given choice could resolve + -- the given conflict. It indicates false by returning 'Just', + -- with the new conflicts to be added to the conflict set. + + -> (k -> ConflictSet -> ExploreState -> ConflictSetLog a) + -- ^ Function that logs the given choice that was skipped. + + -> Var QPN -- ^ The current variable. + + -> ConflictSet -- ^ Conflict set representing the reason that the goal + -- was introduced. + + -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a) + -- ^ List of children's logs. + -> ExploreState -> ConflictSetLog a -backjump mbj (EnableBackjumping enableBj) var lastCS xs = - F.foldr combine avoidGoal xs CS.empty +backjump mbj enableBj fineGrainedConflicts couldResolveConflicts + logSkippedChoice var lastCS xs = + F.foldr combine avoidGoal [(k, v) | (_, k, v) <- W.toList xs] CS.empty Nothing where - combine :: forall a . (ExploreState -> ConflictSetLog a) - -> (ConflictSet -> ExploreState -> ConflictSetLog a) - -> ConflictSet -> ExploreState -> ConflictSetLog a - combine x f csAcc es = retryNoSolution (x es) next + combine :: (k, ExploreState -> ConflictSetLog a) + -> (ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a) + -> ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a + combine (k, x) f csAcc mPreviousCS es = + case (asBool fineGrainedConflicts, mPreviousCS) of + (True, Just previousCS) -> + case CS.lookup var previousCS of + Just conflicts -> + case couldResolveConflicts k conflicts of + Nothing -> retryNoSolution (x es) next + Just newConflicts -> skipChoice (previousCS `CS.union` newConflicts) + _ -> skipChoice previousCS + _ -> retryNoSolution (x es) next where next :: ConflictSet -> ExploreState -> ConflictSetLog a - next !cs es' = if enableBj && not (var `CS.member` cs) + next !cs es' = if asBool enableBj && not (var `CS.member` cs) then skipLoggingBackjump cs es' - else f (csAcc `CS.union` cs) es' + else f (csAcc `CS.union` cs) (Just cs) es' + + -- This function is for skipping the choice when it cannot resolve any + -- of the previous conflicts. + skipChoice :: ConflictSet -> ConflictSetLog a + skipChoice newCS = + retryNoSolution (logSkippedChoice k newCS es) $ \cs' es' -> + f (csAcc `CS.union` cs') (Just cs') $ + + -- Update the conflict map with the conflict set, to make up for + -- skipping the whole subtree. + es' { esConflictMap = updateCM cs' (esConflictMap es') } -- This function represents the option to not choose a value for this goal. - avoidGoal :: ConflictSet -> ExploreState -> ConflictSetLog a - avoidGoal cs !es = + avoidGoal :: ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a + avoidGoal cs _mPreviousCS !es = logBackjump mbj (cs `CS.union` lastCS) $ -- Use 'lastCS' below instead of 'cs' since we do not want to @@ -86,7 +140,7 @@ logBackjump mbj cs es = where reachedBjLimit = case mbj of Nothing -> const False - Just limit -> (== limit) + Just limit -> (>= limit) -- | Like 'retry', except that it only applies the input function when the -- backjump limit has not been reached. @@ -144,15 +198,20 @@ assign tree = cata go tree $ A M.empty M.empty M.empty -- | A tree traversal that simultaneously propagates conflict sets up -- the tree from the leaves and creates a log. -exploreLog :: Maybe Int -> EnableBackjumping -> CountConflicts +exploreLog :: Maybe Int + -> EnableBackjumping + -> FineGrainedConflicts + -> CountConflicts + -> Index -> Tree Assignment QGoalReason -> ConflictSetLog (Assignment, RevDepMap) -exploreLog mbj enableBj (CountConflicts countConflicts) t = para go t initES +exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx t = + para go t initES where getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a) getBestGoal' - | countConflicts = \ ts cm -> getBestGoal cm ts - | otherwise = \ ts _ -> getFirstGoal ts + | asBool countConflicts = \ ts cm -> getBestGoal cm ts + | otherwise = \ ts _ -> getFirstGoal ts go :: TreeF Assignment QGoalReason (ExploreState -> ConflictSetLog (Assignment, RevDepMap), Tree Assignment QGoalReason) @@ -162,20 +221,29 @@ exploreLog mbj enableBj (CountConflicts countConflicts) t = para go t initES in failWith (Failure c fr) (NoSolution c es') go (DoneF rdm a) = \ _ -> succeedWith Success (a, rdm) go (PChoiceF qpn _ gr ts) = - backjump mbj enableBj (P qpn) (avoidSet (P qpn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r es -> tryWith (TryP qpn k) (r es)) - (fmap fst ts) + backjump mbj enableBj fineGrainedConflicts + (couldResolveConflicts qpn) + (logSkippedPackage qpn) + (P qpn) (avoidSet (P qpn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r es -> tryWith (TryP qpn k) (r es)) + (fmap fst ts) go (FChoiceF qfn _ gr _ _ _ ts) = - backjump mbj enableBj (F qfn) (avoidSet (F qfn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r es -> tryWith (TryF qfn k) (r es)) - (fmap fst ts) + backjump mbj enableBj fineGrainedConflicts + (\_ _ -> Nothing) + (const logSkippedChoiceSimple) + (F qfn) (avoidSet (F qfn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r es -> tryWith (TryF qfn k) (r es)) + (fmap fst ts) go (SChoiceF qsn _ gr _ ts) = - backjump mbj enableBj (S qsn) (avoidSet (S qsn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r es -> tryWith (TryS qsn k) (r es)) - (fmap fst ts) + backjump mbj enableBj fineGrainedConflicts + (\_ _ -> Nothing) + (const logSkippedChoiceSimple) + (S qsn) (avoidSet (S qsn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r es -> tryWith (TryS qsn k) (r es)) + (fmap fst ts) go (GoalChoiceF _ ts) = \ es -> let (k, (v, tree)) = getBestGoal' ts (esConflictMap es) in continueWith (Next k) $ @@ -194,6 +262,59 @@ exploreLog mbj enableBj (CountConflicts countConflicts) t = para go t initES , esBackjumps = 0 } + -- Is it possible for this package instance (QPN and POption) to resolve any + -- of the conflicts that were caused by the previous instance? The default + -- is true, because it is always safe to explore a package instance. + -- Skipping it is an optimization. If false, it returns a new conflict set + -- to be merged with the previous one. + couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet + couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts = + let (PInfo deps _ _ _) = idx ! pn ! i + qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps + + couldBeResolved :: CS.Conflict -> Maybe ConflictSet + couldBeResolved CS.OtherConflict = Nothing + couldBeResolved (CS.GoalConflict conflictingDep) = + -- Check whether this package instance also has 'conflictingDep' + -- as a dependency (ignoring flag and stanza choices). + if F.null [() | Simple (LDep _ (Dep (PkgComponent qpn _) _)) _ <- qdeps, qpn == conflictingDep] + then Nothing + else Just CS.empty + couldBeResolved (CS.VersionConstraintConflict dep excludedVersion) = + -- Check whether this package instance also excludes version + -- 'excludedVersion' of 'dep' (ignoring flag and stanza choices). + let vrs = [vr | Simple (LDep _ (Dep (PkgComponent qpn _) (Constrained vr))) _ <- qdeps, qpn == dep ] + vrIntersection = L.foldl' (.&&.) anyVersion vrs + in if checkVR vrIntersection excludedVersion + then Nothing + else -- If we skip this package instance, we need to update the + -- conflict set to say that 'dep' was also excluded by + -- this package instance's constraint. + Just $ CS.singletonWithConflict (P dep) $ + CS.VersionConflict currentQPN (CS.OrderedVersionRange vrIntersection) + couldBeResolved (CS.VersionConflict reverseDep (CS.OrderedVersionRange excludingVR)) = + -- Check whether this package instance's version is also excluded + -- by 'excludingVR'. + if checkVR excludingVR v + then Nothing + else -- If we skip this version, we need to update the conflict + -- set to say that the reverse dependency also excluded this + -- version. + Just $ CS.singletonWithConflict (P reverseDep) (CS.VersionConstraintConflict currentQPN v) + in fmap CS.unions $ traverse couldBeResolved (S.toList conflicts) + + logSkippedPackage :: QPN -> POption -> ConflictSet -> ExploreState -> ConflictSetLog a + logSkippedPackage qpn pOption cs es = + tryWith (TryP qpn pOption) $ + failWith (Skip (fromMaybe S.empty $ CS.lookup (P qpn) cs)) $ + NoSolution cs es + + -- This function is used for flag and stanza choices, but it should not be + -- called, because there is currently no way to skip a value for a flag or + -- stanza. + logSkippedChoiceSimple :: ConflictSet -> ExploreState -> ConflictSetLog a + logSkippedChoiceSimple cs es = fromProgress $ P.Fail $ NoSolution cs es + -- | Build a conflict set corresponding to the (virtual) option not to -- choose a solution for a goal at all. -- @@ -219,8 +340,10 @@ exploreLog mbj enableBj (CountConflicts countConflicts) t = para go t initES -- conflict set. -- avoidSet :: Var QPN -> QGoalReason -> ConflictSet -avoidSet var gr = - CS.union (CS.singleton var) (goalReasonToCS gr) +avoidSet var@(P qpn) gr = + CS.union (CS.singleton var) (goalReasonToConflictSetWithConflict qpn gr) +avoidSet var gr = + CS.union (CS.singleton var) (goalReasonToConflictSet gr) -- | Interface. -- @@ -229,11 +352,15 @@ avoidSet var gr = -- backtracking is completely disabled. backjumpAndExplore :: Maybe Int -> EnableBackjumping + -> FineGrainedConflicts -> CountConflicts + -> Index -> Tree d QGoalReason -> RetryLog Message SolverFailure (Assignment, RevDepMap) -backjumpAndExplore mbj enableBj countConflicts = - mapFailure convertFailure . exploreLog mbj enableBj countConflicts . assign +backjumpAndExplore mbj enableBj fineGrainedConflicts countConflicts idx = + mapFailure convertFailure + . exploreLog mbj enableBj fineGrainedConflicts countConflicts idx + . assign where convertFailure (NoSolution cs es) = ExhaustiveSearch cs (esConflictMap es) convertFailure BackjumpLimit = BackjumpLimitReached diff --git a/cabal-install/Distribution/Solver/Modular/Linking.hs b/cabal-install/Distribution/Solver/Modular/Linking.hs index 60438e98af7..d5522cd9d89 100644 --- a/cabal-install/Distribution/Solver/Modular/Linking.hs +++ b/cabal-install/Distribution/Solver/Modular/Linking.hs @@ -251,7 +251,7 @@ linkDeps target = \deps -> do vs <- get let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs - lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToCS) dr1 dr2) lg lg' + lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToConflictSet) dr1 dr2) lg lg' updateLinkGroup lg'' (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do vs <- get diff --git a/cabal-install/Distribution/Solver/Modular/Message.hs b/cabal-install/Distribution/Solver/Modular/Message.hs index 24d968bce33..5d642d32c14 100644 --- a/cabal-install/Distribution/Solver/Modular/Message.hs +++ b/cabal-install/Distribution/Solver/Modular/Message.hs @@ -6,10 +6,16 @@ module Distribution.Solver.Modular.Message ( ) where import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import Data.Maybe (catMaybes, mapMaybe) import Prelude hiding (pi) import Distribution.Pretty (prettyShow) -- from Cabal +import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package @@ -28,6 +34,7 @@ data Message = | TryF QFN Bool | TryS QSN Bool | Next (Goal QPN) + | Skip (Set CS.Conflict) | Success | Failure ConflictSet FailReason @@ -47,6 +54,8 @@ showMessages = go 0 -- 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) go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = @@ -63,6 +72,9 @@ showMessages = go 0 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) @@ -85,12 +97,112 @@ showMessages = go 0 goPReject l qpn is c fr ms = (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR 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 + 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 +-- | 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: " + ++ conflictMsg ++ ")" + where + conflictMsg :: String + conflictMsg = + if S.member CS.OtherConflict conflicts + then + -- This case shouldn't happen, because an unknown conflict should not + -- cause a version to be skipped. + "unknown conflict" + else let mergedConflicts = + [ showConflict qpn conflict + | (qpn, conflict) <- M.toList (mergeConflicts conflicts) ] + in if L.null mergedConflicts + then + -- This case shouldn't happen unless backjumping is turned off. + "none" + else L.intercalate "; " mergedConflicts + + -- Merge conflicts to simplify the log message. + mergeConflicts :: Set CS.Conflict -> Map QPN MergedPackageConflict + mergeConflicts = M.fromListWith mergeConflict . mapMaybe toMergedConflict . S.toList + where + mergeConflict :: MergedPackageConflict + -> MergedPackageConflict + -> MergedPackageConflict + mergeConflict mergedConflict1 mergedConflict2 = MergedPackageConflict { + isGoalConflict = + isGoalConflict mergedConflict1 || isGoalConflict mergedConflict2 + , versionConstraintConflict = + L.nub $ versionConstraintConflict mergedConflict1 + ++ versionConstraintConflict mergedConflict2 + , versionConflict = + mergeVersionConflicts (versionConflict mergedConflict1) + (versionConflict mergedConflict2) + } + where + mergeVersionConflicts (Just vr1) (Just vr2) = Just (vr1 .||. vr2) + mergeVersionConflicts (Just vr1) Nothing = Just vr1 + mergeVersionConflicts Nothing (Just vr2) = Just vr2 + mergeVersionConflicts Nothing Nothing = Nothing + + toMergedConflict :: CS.Conflict -> Maybe (QPN, MergedPackageConflict) + toMergedConflict (CS.GoalConflict qpn) = + Just (qpn, MergedPackageConflict True [] Nothing) + toMergedConflict (CS.VersionConstraintConflict qpn v) = + Just (qpn, MergedPackageConflict False [v] Nothing) + toMergedConflict (CS.VersionConflict qpn (CS.OrderedVersionRange vr)) = + Just (qpn, MergedPackageConflict False [] (Just vr)) + toMergedConflict CS.OtherConflict = Nothing + + showConflict :: QPN -> MergedPackageConflict -> String + showConflict qpn mergedConflict = L.intercalate "; " conflictStrings + where + conflictStrings = catMaybes [ + case () of + () | isGoalConflict mergedConflict -> Just $ + "depends on '" ++ showQPN qpn ++ "'" ++ + (if null (versionConstraintConflict mergedConflict) + then "" + else " but excludes " + ++ showVersions (versionConstraintConflict mergedConflict)) + | not $ L.null (versionConstraintConflict mergedConflict) -> Just $ + "excludes '" ++ showQPN qpn + ++ "' " ++ showVersions (versionConstraintConflict mergedConflict) + | otherwise -> Nothing + , (\vr -> "excluded by constraint '" ++ showVR vr ++ "' from '" ++ showQPN qpn ++ "'") + <$> versionConflict mergedConflict + ] + + showVersions [] = "no versions" + showVersions [v] = "version " ++ showVer v + showVersions vs = "versions " ++ L.intercalate ", " (map showVer vs) + +-- | All conflicts related to one package, used for simplifying the display of +-- a 'Set CS.Conflict'. +data MergedPackageConflict = MergedPackageConflict { + isGoalConflict :: Bool + , versionConstraintConflict :: [Ver] + , versionConflict :: Maybe VR + } + showQPNPOpt :: QPN -> POption -> String showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) = case linkedTo of diff --git a/cabal-install/Distribution/Solver/Modular/Preference.hs b/cabal-install/Distribution/Solver/Modular/Preference.hs index 856993f2ef3..5eb2c6a1bf9 100644 --- a/cabal-install/Distribution/Solver/Modular/Preference.hs +++ b/cabal-install/Distribution/Solver/Modular/Preference.hs @@ -343,7 +343,9 @@ onlyConstrained :: (PN -> Bool) -> Tree d QGoalReason -> Tree d QGoalReason onlyConstrained p = trav go where go (PChoiceF v@(Q _ pn) _ gr _) | not (p pn) - = FailF (varToConflictSet (P v) `CS.union` goalReasonToCS gr) NotExplicit + = FailF + (varToConflictSet (P v) `CS.union` goalReasonToConflictSetWithConflict v gr) + NotExplicit go x = x diff --git a/cabal-install/Distribution/Solver/Modular/Solver.hs b/cabal-install/Distribution/Solver/Modular/Solver.hs index b0e40cb9a0a..32452550556 100644 --- a/cabal-install/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install/Distribution/Solver/Modular/Solver.hs @@ -57,6 +57,7 @@ import Debug.Trace.Tree.Assoc (Assoc(..)) data SolverConfig = SolverConfig { reorderGoals :: ReorderGoals, countConflicts :: CountConflicts, + fineGrainedConflicts :: FineGrainedConflicts, minimizeConflictSet :: MinimizeConflictSet, independentGoals :: IndependentGoals, avoidReinstalls :: AvoidReinstalls, @@ -104,7 +105,9 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = where explorePhase = backjumpAndExplore (maxBackjumps sc) (enableBackjumping sc) + (fineGrainedConflicts sc) (countConflicts sc) + idx detectCycles = traceTree "cycles.json" id . detectCyclesPhase heuristicsPhase = let heuristicsTree = traceTree "heuristics.json" id diff --git a/cabal-install/Distribution/Solver/Modular/Validate.hs b/cabal-install/Distribution/Solver/Modular/Validate.hs index 4f63f073e5e..6195d101b02 100644 --- a/cabal-install/Distribution/Solver/Modular/Validate.hs +++ b/cabal-install/Distribution/Solver/Modular/Validate.hs @@ -320,7 +320,7 @@ checkComponentsInNewPackage required qpn providedComps = -> (ExposedComponent -> DependencyReason QPN -> FailReason) -> Conflict mkConflict comp dr mkFailure = - (CS.insert (P qpn) (dependencyReasonToCS dr), mkFailure comp dr) + (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure comp dr) buildableProvidedComps :: [ExposedComponent] buildableProvidedComps = [comp | (comp, IsBuildable True) <- M.toList providedComps] @@ -393,13 +393,13 @@ extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment extendSingle a (LDep dr (Ext ext )) = if extSupported ext then Right a - else Left (dependencyReasonToCS dr, UnsupportedExtension ext) + else Left (dependencyReasonToConflictSet dr, UnsupportedExtension ext) extendSingle a (LDep dr (Lang lang)) = if langSupported lang then Right a - else Left (dependencyReasonToCS dr, UnsupportedLanguage lang) + else Left (dependencyReasonToConflictSet dr, UnsupportedLanguage lang) extendSingle a (LDep dr (Pkg pn vr)) = if pkgPresent pn vr then Right a - else Left (dependencyReasonToCS dr, MissingPkgconfigPackage pn vr) + else Left (dependencyReasonToConflictSet dr, MissingPkgconfigPackage pn vr) extendSingle a (LDep dr (Dep dep@(PkgComponent qpn _) ci)) = let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr dep ci) of @@ -448,14 +448,14 @@ merge :: merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i2)) | i1 == i2 = Right $ MergedDepFixed comp1 vs1 i1 | otherwise = - Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 + Left ( (CS.union `on` dependencyReasonToConflictSet) vs1 vs2 , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) merge (MergedDepFixed comp1 vs1 i@(I v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr)) | checkVR vr v = Right $ MergedDepFixed comp1 vs1 i | otherwise = - Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 + Left ( createConflictSetForVersionConflict p v vs1 vr vs2 , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) @@ -467,7 +467,7 @@ merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fi go ((vr, comp1, vs1) : vros) | checkVR vr v = go vros | otherwise = - Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 + Left ( createConflictSetForVersionConflict p v vs2 vr vs1 , ( ConflictingDep vs1 (PkgComponent p comp1) (Constrained vr) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) @@ -479,6 +479,45 @@ merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent _ comp2) (Const -- no negative performance impact. vrOrigins ++ [(vr, comp2, vs2)]) +-- | Creates a conflict set representing a conflict between a version constraint +-- and the fixed version chosen for a package. +createConflictSetForVersionConflict :: QPN + -> Ver + -> DependencyReason QPN + -> VR + -> DependencyReason QPN + -> ConflictSet +createConflictSetForVersionConflict pkg + conflictingVersion + versionDR@(DependencyReason p1 _ _) + conflictingVersionRange + versionRangeDR@(DependencyReason p2 _ _) = + let hasFlagsOrStanzas (DependencyReason _ fs ss) = not (M.null fs) || not (S.null ss) + in + -- The solver currently only optimizes the case where there is a conflict + -- between the version chosen for a package and a version constraint that + -- is not under any flags or stanzas. Here is how we check for this case: + -- + -- (1) Choosing a specific version for a package foo is implemented as + -- adding a dependency from foo to that version of foo (See + -- extendWithPackageChoice), so we check that the DependencyReason + -- contains the current package and no flag or stanza choices. + -- + -- (2) We check that the DependencyReason for the version constraint also + -- contains no flag or stanza choices. + -- + -- When these criteria are not met, we fall back to calling + -- dependencyReasonToConflictSet. + if p1 == pkg && not (hasFlagsOrStanzas versionDR) && not (hasFlagsOrStanzas versionRangeDR) + then let cs1 = dependencyReasonToConflictSetWithVersionConflict + p2 + (CS.OrderedVersionRange conflictingVersionRange) + versionDR + cs2 = dependencyReasonToConflictSetWithVersionConstraintConflict + pkg conflictingVersion versionRangeDR + in cs1 `CS.union` cs2 + else dependencyReasonToConflictSet versionRangeDR `CS.union` dependencyReasonToConflictSet versionDR + -- | Takes a list of new dependencies and uses it to try to update the map of -- known component dependencies. It returns a failure when a new dependency -- requires a component that is missing or unbuildable in a previously chosen @@ -512,7 +551,7 @@ extendRequiredComponents available = foldM extendSingle -> (QPN -> ExposedComponent -> FailReason) -> Conflict mkConflict qpn comp dr mkFailure = - (CS.insert (P qpn) (dependencyReasonToCS dr), mkFailure qpn comp) + (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure qpn comp) buildableComps :: Map comp IsBuildable -> [comp] buildableComps comps = [comp | (comp, IsBuildable True) <- M.toList comps] diff --git a/cabal-install/Distribution/Solver/Types/Settings.hs b/cabal-install/Distribution/Solver/Types/Settings.hs index 79bc3a017d4..c8a4f7e99fc 100644 --- a/cabal-install/Distribution/Solver/Types/Settings.hs +++ b/cabal-install/Distribution/Solver/Types/Settings.hs @@ -11,6 +11,7 @@ module Distribution.Solver.Types.Settings , OnlyConstrained(..) , EnableBackjumping(..) , CountConflicts(..) + , FineGrainedConflicts(..) , SolveExecutables(..) ) where @@ -30,6 +31,9 @@ newtype ReorderGoals = ReorderGoals Bool newtype CountConflicts = CountConflicts Bool deriving (BooleanFlag, Eq, Generic, Show) +newtype FineGrainedConflicts = FineGrainedConflicts Bool + deriving (BooleanFlag, Eq, Generic, Show) + newtype MinimizeConflictSet = MinimizeConflictSet Bool deriving (BooleanFlag, Eq, Generic, Show) @@ -63,6 +67,7 @@ newtype SolveExecutables = SolveExecutables Bool instance Binary ReorderGoals instance Binary CountConflicts +instance Binary FineGrainedConflicts instance Binary IndependentGoals instance Binary MinimizeConflictSet instance Binary AvoidReinstalls @@ -74,6 +79,7 @@ instance Binary SolveExecutables instance Structured ReorderGoals instance Structured CountConflicts +instance Structured FineGrainedConflicts instance Structured IndependentGoals instance Structured MinimizeConflictSet instance Structured AvoidReinstalls diff --git a/cabal-install/changelog b/cabal-install/changelog index b5d1b72bbb3..93fdd2d6a92 100644 --- a/cabal-install/changelog +++ b/cabal-install/changelog @@ -4,6 +4,9 @@ * `v2-build` (and other `v2-`prefixed commands) now accept the `--benchmark-option(s)` flags, which pass options to benchmark executables (analogous to how `--test-option(s)` works). (#6209) + * Add solver optimization to skip a version of a package if it does not resolve + any conflicts encountered in the last version, controlled by flag + '--fine-grained-conflicts'. (#5918) 3.0.0.0 Mikhail Glushenkov August 2019 * Parse comma-separated lists for extra-prog-path, extra-lib-dirs, extra-framework-dirs, diff --git a/cabal-install/solver-dsl/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/solver-dsl/UnitTests/Distribution/Solver/Modular/DSL.hs index 87d728e9544..4d356615826 100644 --- a/cabal-install/solver-dsl/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/solver-dsl/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -655,6 +655,7 @@ exResolve :: ExampleDb -> [ExamplePkgName] -> Maybe Int -> CountConflicts + -> FineGrainedConflicts -> MinimizeConflictSet -> IndependentGoals -> ReorderGoals @@ -669,9 +670,9 @@ exResolve :: ExampleDb -> EnableAllTests -> Progress String String CI.SolverInstallPlan.SolverInstallPlan exResolve db exts langs pkgConfigDb targets mbj countConflicts - minimizeConflictSet indepGoals reorder allowBootLibInstalls - onlyConstrained enableBj solveExes goalOrder constraints - prefs verbosity enableAllTests + fineGrainedConflicts minimizeConflictSet indepGoals reorder + allowBootLibInstalls onlyConstrained enableBj solveExes goalOrder + constraints prefs verbosity enableAllTests = resolveDependencies C.buildPlatform compiler pkgConfigDb Modular params where defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag @@ -695,6 +696,7 @@ exResolve db exts langs pkgConfigDb targets mbj countConflicts $ addConstraints (fmap toLpc enableTests) $ addPreferences (fmap toPref prefs) $ setCountConflicts countConflicts + $ setFineGrainedConflicts fineGrainedConflicts $ setMinimizeConflictSet minimizeConflictSet $ setIndependentGoals indepGoals $ setReorderGoals reorder diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index ceada5bd7c2..0ef0ff003c0 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -472,6 +472,7 @@ instance Arbitrary ProjectConfigShared where <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> (toNubList <$> listOf arbitraryShortToken) where arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)] @@ -498,15 +499,16 @@ instance Arbitrary ProjectConfigShared where , projectConfigMaxBackjumps = x16 , projectConfigReorderGoals = x17 , projectConfigCountConflicts = x18 - , projectConfigMinimizeConflictSet = x19 - , projectConfigStrongFlags = x20 - , projectConfigAllowBootLibInstalls = x21 - , projectConfigOnlyConstrained = x22 - , projectConfigPerComponent = x23 - , projectConfigIndependentGoals = x24 - , projectConfigConfigFile = x25 - , projectConfigProgPathExtra = x26 - , projectConfigStoreDir = x27 } = + , projectConfigFineGrainedConflicts = x19 + , projectConfigMinimizeConflictSet = x20 + , projectConfigStrongFlags = x21 + , projectConfigAllowBootLibInstalls = x22 + , projectConfigOnlyConstrained = x23 + , projectConfigPerComponent = x24 + , projectConfigIndependentGoals = x25 + , projectConfigConfigFile = x26 + , projectConfigProgPathExtra = x27 + , projectConfigStoreDir = x28 } = [ ProjectConfigShared { projectConfigDistDir = x00' , projectConfigProjectFile = x01' , projectConfigHcFlavor = x02' @@ -527,26 +529,27 @@ instance Arbitrary ProjectConfigShared where , projectConfigMaxBackjumps = x16' , projectConfigReorderGoals = x17' , projectConfigCountConflicts = x18' - , projectConfigMinimizeConflictSet = x19' - , projectConfigStrongFlags = x20' - , projectConfigAllowBootLibInstalls = x21' - , projectConfigOnlyConstrained = x22' - , projectConfigPerComponent = x23' - , projectConfigIndependentGoals = x24' - , projectConfigConfigFile = x25' - , projectConfigProgPathExtra = x26' - , projectConfigStoreDir = x27' } - | ((x00', x01', x02', x03', x04'), - (x05', x06', x07', x07b', x08', x09'), - (x10', x11', x12', x13', x14', x15'), - (x16', x17', x18', x19', x20', x21'), - x22', x23', x24', x25', x26', x27') + , projectConfigFineGrainedConflicts = x19' + , projectConfigMinimizeConflictSet = x20' + , projectConfigStrongFlags = x21' + , projectConfigAllowBootLibInstalls = x22' + , projectConfigOnlyConstrained = x23' + , projectConfigPerComponent = x24' + , projectConfigIndependentGoals = x25' + , projectConfigConfigFile = x26' + , projectConfigProgPathExtra = x27' + , projectConfigStoreDir = x28' } + | ((x00', x01', x02', x03', x04', x05'), + (x06', x07', x07b', x08', x09', x10'), + (x11', x12', x13', x14', x15', x16'), + (x17', x18', x19', x20', x21', x22'), + x23', x24', x25', x26', x27', x28') <- shrink - ((x00, x01, x02, fmap NonEmpty x03, fmap NonEmpty x04), - (x05, x06, x07, x07b, x08, preShrink_Constraints x09), - (x10, x11, x12, x13, x14, x15), - (x16, x17, x18, x19, x20, x21), - x22, x23, x24, x25, x26, x27) + ((x00, x01, x02, fmap NonEmpty x03, fmap NonEmpty x04, x05), + (x06, x07, x07b, x08, preShrink_Constraints x09, x10), + (x11, x12, x13, x14, x15, x16), + (x17, x18, x19, x20, x21, x22), + x23, x24, x25, x26, x27, x28) ] where preShrink_Constraints = map fst @@ -877,6 +880,9 @@ instance Arbitrary ReorderGoals where instance Arbitrary CountConflicts where arbitrary = CountConflicts <$> arbitrary +instance Arbitrary FineGrainedConflicts where + arbitrary = FineGrainedConflicts <$> arbitrary + instance Arbitrary MinimizeConflictSet where arbitrary = MinimizeConflictSet <$> arbitrary diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs index a04eb105522..58f6870d28b 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -55,6 +55,7 @@ instance ToExpr CompilerFlavor instance ToExpr ConstraintSource instance ToExpr CountConflicts instance ToExpr DebugInfoLevel +instance ToExpr FineGrainedConflicts instance ToExpr FlagAssignment instance ToExpr FlagName where toExpr = defaultExprViaShow instance ToExpr HaddockTarget diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs index 2f8c7a69f59..6135f571951 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs @@ -4,6 +4,7 @@ module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils ( SolverTest , SolverResult(..) , maxBackjumps + , disableFineGrainedConflicts , minimizeConflictSet , independentGoals , allowBootLibInstalls @@ -54,6 +55,10 @@ import UnitTests.Options maxBackjumps :: Maybe Int -> SolverTest -> SolverTest maxBackjumps mbj test = test { testMaxBackjumps = mbj } +disableFineGrainedConflicts :: SolverTest -> SolverTest +disableFineGrainedConflicts test = + test { testFineGrainedConflicts = FineGrainedConflicts False } + minimizeConflictSet :: SolverTest -> SolverTest minimizeConflictSet test = test { testMinimizeConflictSet = MinimizeConflictSet True } @@ -105,6 +110,7 @@ data SolverTest = SolverTest { , testTargets :: [String] , testResult :: SolverResult , testMaxBackjumps :: Maybe Int + , testFineGrainedConflicts :: FineGrainedConflicts , testMinimizeConflictSet :: MinimizeConflictSet , testIndepGoals :: IndependentGoals , testAllowBootLibInstalls :: AllowBootLibInstalls @@ -201,6 +207,7 @@ mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest { , testTargets = targets , testResult = result , testMaxBackjumps = Nothing + , testFineGrainedConflicts = FineGrainedConflicts True , testMinimizeConflictSet = MinimizeConflictSet False , testIndepGoals = IndependentGoals False , testAllowBootLibInstalls = AllowBootLibInstalls False @@ -224,8 +231,8 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) -> let progress = exResolve testDb testSupportedExts testSupportedLangs testPkgConfigDb testTargets testMaxBackjumps (CountConflicts True) - testMinimizeConflictSet testIndepGoals - (ReorderGoals False) testAllowBootLibInstalls + testFineGrainedConflicts testMinimizeConflictSet + testIndepGoals (ReorderGoals False) testAllowBootLibInstalls testOnlyConstrained testEnableBackjumping testSolveExecutables (sortGoals <$> testGoalOrder) testConstraints testSoftConstraints testVerbosity testEnableAllTests diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs index f1bc388d40d..93f7c5a5d20 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs @@ -17,12 +17,14 @@ tests = [ -- | This test solves for n packages that each have two versions. There is no -- solution, because the nth package depends on another package that doesn't fit --- its version constraint. Backjumping is disabled, so the solver must explore a --- search tree of size 2^n. It should fail if memory usage is proportional to --- the size of the tree. +-- its version constraint. Backjumping and fine grained conflicts are disabled, +-- so the solver must explore a search tree of size 2^n. It should fail if +-- memory usage is proportional to the size of the tree. basicTest :: String -> SolverTest basicTest name = - disableBackjumping $ mkTest pkgs name ["target"] anySolverFailure + disableBackjumping $ + disableFineGrainedConflicts $ + mkTest pkgs name ["target"] anySolverFailure where n :: Int n = 18 @@ -44,6 +46,7 @@ basicTest name = flagsTest :: String -> SolverTest flagsTest name = disableBackjumping $ + disableFineGrainedConflicts $ goalOrder orderedFlags $ mkTest pkgs name ["pkg"] anySolverFailure where n :: Int @@ -69,14 +72,16 @@ flagsTest name = -- has a long chain of dependencies (pkg-1 through pkg-n). However, pkg-n -- depends on pkg-n+1, which doesn't exist, so there is no solution. Since each -- dependency has two versions, the solver must try 2^n combinations when --- backjumping is disabled. These combinations create large search trees under --- each of the two choices for target-setup.setup-dep. Although the choice to --- not link is disallowed by the Single Instance Restriction, the solver doesn't --- know that until it has explored (and evaluated) the whole tree under the --- choice to link. If the two trees are shared, memory usage spikes. +-- backjumping and fine grained conflicts are disabled. These combinations +-- create large search trees under each of the two choices for +-- target-setup.setup-dep. Although the choice to not link is disallowed by the +-- Single Instance Restriction, the solver doesn't know that until it has +-- explored (and evaluated) the whole tree under the choice to link. If the two +-- trees are shared, memory usage spikes. issue2899 :: String -> SolverTest issue2899 name = disableBackjumping $ + disableFineGrainedConflicts $ goalOrder goals $ mkTest pkgs name ["target"] anySolverFailure where n :: Int diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index 96243613ee6..a1a6412d014 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -57,8 +57,8 @@ tests = [ let r1 = solve' mGoalOrder1 test r2 = solve' mGoalOrder2 test { testTargets = targets2 } solve' goalOrder = - solve (EnableBackjumping True) (ReorderGoals False) - (CountConflicts True) indepGoals + solve (EnableBackjumping True) (FineGrainedConflicts True) + (ReorderGoals False) (CountConflicts True) indepGoals (getBlind <$> goalOrder) targets = testTargets test targets2 = case targetOrder of @@ -73,8 +73,9 @@ tests = [ \test reorderGoals -> let r1 = solve' (IndependentGoals False) test r2 = solve' (IndependentGoals True) test - solve' indep = solve (EnableBackjumping True) reorderGoals - (CountConflicts True) indep Nothing + solve' indep = + solve (EnableBackjumping True) (FineGrainedConflicts True) + reorderGoals (CountConflicts True) indep Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) `implies` isRight (resultPlan r2) @@ -83,26 +84,52 @@ tests = [ \test reorderGoals indepGoals -> let r1 = solve' (EnableBackjumping True) test r2 = solve' (EnableBackjumping False) test - solve' enableBj = solve enableBj reorderGoals - (CountConflicts True) indepGoals Nothing + solve' enableBj = + solve enableBj (FineGrainedConflicts False) reorderGoals + (CountConflicts True) indepGoals Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) === isRight (resultPlan r2) - -- This test uses --no-count-conflicts, because the goal order used with - -- --count-conflicts depends on the total set of conflicts seen by the + , testPropertyWithSeed "fine-grained conflicts does not affect solvability" $ + \test reorderGoals indepGoals -> + let r1 = solve' (FineGrainedConflicts True) test + r2 = solve' (FineGrainedConflicts False) test + solve' fineGrainedConflicts = + solve (EnableBackjumping True) fineGrainedConflicts + reorderGoals (CountConflicts True) indepGoals Nothing + in counterexample (showResults r1 r2) $ + noneReachedBackjumpLimit [r1, r2] ==> + isRight (resultPlan r1) === isRight (resultPlan r2) + + -- The next two tests use --no-count-conflicts, because the goal order used + -- with --count-conflicts depends on the total set of conflicts seen by the -- solver. The solver explores more of the tree and encounters more -- conflicts when it doesn't backjump. The different goal orders can lead to -- different solutions and cause the test to fail. -- TODO: Find a faster way to randomly sort goals, and then use a random - -- goal order in this test. + -- goal order in these tests. + , testPropertyWithSeed "backjumping does not affect the result (with static goal order)" $ \test reorderGoals indepGoals -> let r1 = solve' (EnableBackjumping True) test r2 = solve' (EnableBackjumping False) test - solve' enableBj = solve enableBj reorderGoals - (CountConflicts False) indepGoals Nothing + solve' enableBj = + solve enableBj (FineGrainedConflicts False) reorderGoals + (CountConflicts False) indepGoals Nothing + in counterexample (showResults r1 r2) $ + noneReachedBackjumpLimit [r1, r2] ==> + resultPlan r1 === resultPlan r2 + + , testPropertyWithSeed + "fine-grained conflicts does not affect the result (with static goal order)" $ + \test reorderGoals indepGoals -> + let r1 = solve' (FineGrainedConflicts True) test + r2 = solve' (FineGrainedConflicts False) test + solve' fineGrainedConflicts = + solve (EnableBackjumping True) fineGrainedConflicts + reorderGoals (CountConflicts False) indepGoals Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> resultPlan r1 === resultPlan r2 @@ -132,10 +159,15 @@ newtype VarOrdering = VarOrdering { unVarOrdering :: Variable P.QPN -> Variable P.QPN -> Ordering } -solve :: EnableBackjumping -> ReorderGoals -> CountConflicts -> IndependentGoals +solve :: EnableBackjumping + -> FineGrainedConflicts + -> ReorderGoals + -> CountConflicts + -> IndependentGoals -> Maybe VarOrdering - -> SolverTest -> Result -solve enableBj reorder countConflicts indep goalOrder test = + -> SolverTest + -> Result +solve enableBj fineGrainedConflicts reorder countConflicts indep goalOrder test = let (lg, result) = runProgress $ exResolve (unTestDb (testDb test)) Nothing Nothing (pkgConfigDbFromList []) @@ -143,7 +175,8 @@ solve enableBj reorder countConflicts indep goalOrder test = -- The backjump limit prevents individual tests from using -- too much time and memory. (Just defaultMaxBackjumps) - countConflicts (MinimizeConflictSet False) indep reorder + countConflicts fineGrainedConflicts + (MinimizeConflictSet False) indep reorder (AllowBootLibInstalls False) OnlyConstrainedNone enableBj (SolveExecutables True) (unVarOrdering <$> goalOrder) (testConstraints test) (testPreferences test) normal diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs index 3e725c16acf..c4405a9974e 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -331,7 +331,7 @@ tests = [ -- and an executable conflict apply to the same package version. "[__1] rejecting: H:bt-pkg:exe.bt-pkg-4.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)\n" ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-3.0.0 (does not contain executable 'exe1', which is required by H)\n" - ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-2.0.0, H:bt-pkg:exe.bt-pkg-1.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)" + ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-2.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)" , runTest $ chooseExeAfterBuildToolsPackage True "choose exe after choosing its package - success" @@ -408,6 +408,266 @@ tests = [ chooseUnbuildableExeAfterBuildToolsPackage "choose unbuildable exe after choosing its package" ] + + , testGroup "--fine-grained-conflicts" [ + + -- Skipping a version because of a problematic dependency: + -- + -- When the solver explores A-4, it finds that it cannot satisfy B's + -- dependencies. This allows the solver to skip the subsequent + -- versions of A that also depend on B. + runTest $ + let db = [ + Right $ exAv "A" 4 [ExAny "B"] + , Right $ exAv "A" 3 [ExAny "B"] + , Right $ exAv "A" 2 [ExAny "B"] + , Right $ exAv "A" 1 [] + , Right $ exAv "B" 2 [ExAny "unknown1"] + , Right $ exAv "B" 1 [ExAny "unknown2"] + ] + msg = [ + "[__0] trying: A-4.0.0 (user goal)" + , "[__1] trying: B-2.0.0 (dependency of A)" + , "[__2] unknown package: unknown1 (dependency of B)" + , "[__2] fail (backjumping, conflict set: B, unknown1)" + , "[__1] trying: B-1.0.0" + , "[__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, A-2.0.0 (has the same characteristics that " + ++ "caused the previous version to fail: depends on 'B')" + , "[__0] trying: A-1.0.0" + , "[__1] done" + ] + in setVerbose $ + mkTest db "skip version due to problematic dependency" ["A"] $ + SolverResult (isInfixOf msg) $ Right [("A", 1)] + + , -- Skipping a version because of a restrictive constraint on a + -- dependency: + -- + -- The solver rejects A-4 because its constraint on B excludes B-1. + -- Then the solver is able to skip A-3 and A-2 because they also + -- exclude B-1, even though they don't have the exact same constraints + -- on B. + runTest $ + let db = [ + Right $ exAv "A" 4 [ExFix "B" 14] + , Right $ exAv "A" 3 [ExFix "B" 13] + , Right $ exAv "A" 2 [ExFix "B" 12] + , Right $ exAv "A" 1 [ExFix "B" 11] + , Right $ exAv "B" 11 [] + ] + msg = [ + "[__0] trying: A-4.0.0 (user goal)" + , "[__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, A-2.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" + , "[__1] next goal: B (dependency of A)" + , "[__1] trying: B-11.0.0" + , "[__2] done" + ] + in setVerbose $ + mkTest db "skip version due to restrictive constraint on its dependency" ["A"] $ + SolverResult (isInfixOf msg) $ Right [("A", 1), ("B", 11)] + + , -- This test tests the case where the solver chooses a version for one + -- package, B, before choosing a version for one of its reverse + -- dependencies, C. While the solver is exploring the subtree rooted + -- at B-3, it finds that C-2's dependency on B conflicts with B-3. + -- Then the solver is able to skip C-1, because it also excludes B-3. + -- + -- --fine-grained-conflicts could have a benefit in this case even + -- though the solver would have found the conflict between B-3 and C-1 + -- immediately after trying C-1 anyway. It prevents C-1 from + -- introducing any other conflicts which could increase the size of + -- the conflict set. + runTest $ + let db = [ + Right $ exAv "A" 1 [ExAny "B", ExAny "C"] + , Right $ exAv "B" 3 [] + , Right $ exAv "B" 2 [] + , Right $ exAv "B" 1 [] + , Right $ exAv "C" 2 [ExFix "B" 2] + , Right $ exAv "C" 1 [ExFix "B" 1] + ] + goals = [P QualNone pkg | pkg <- ["A", "B", "C"]] + expectedMsg = [ + "[__0] trying: A-1.0.0 (user goal)" + , "[__1] trying: B-3.0.0 (dependency of A)" + , "[__2] next goal: C (dependency of A)" + , "[__2] rejecting: C-2.0.0 (conflict: B==3.0.0, C => B==2.0.0)" + , "[__2] skipping: C-1.0.0 (has the same characteristics that caused the " + ++ "previous version to fail: excludes 'B' version 3.0.0)" + , "[__2] fail (backjumping, conflict set: A, B, C)" + , "[__1] trying: B-2.0.0" + , "[__2] next goal: C (dependency of A)" + , "[__2] trying: C-2.0.0" + , "[__3] done" + ] + in setVerbose $ goalOrder goals $ + mkTest db "skip version that excludes dependency that was already chosen" ["A"] $ + SolverResult (isInfixOf expectedMsg) $ Right [("A", 1), ("B", 2), ("C", 2)] + + , -- This test tests how the solver merges conflicts when it has + -- multiple reasons to add a variable to the conflict set. In this + -- case, package A conflicts with B and C. The solver should take the + -- union of the conflicts and then only skip a version if it does not + -- resolve any of the conflicts. + -- + -- The solver rejects A-3 because it can't find consistent versions for + -- its two dependencies, B and C. Then it skips A-2 because A-2 also + -- depends on B and C. This test ensures that the solver considers + -- A-1 even though A-1 only resolves one of the conflicts (A-1 removes + -- the dependency on C). + runTest $ + let db = [ + Right $ exAv "A" 3 [ExAny "B", ExAny "C"] + , Right $ exAv "A" 2 [ExAny "B", ExAny "C"] + , Right $ exAv "A" 1 [ExAny "B"] + , Right $ exAv "B" 1 [ExFix "D" 1] + , Right $ exAv "C" 1 [ExFix "D" 2] + , Right $ exAv "D" 1 [] + , Right $ exAv "D" 2 [] + ] + goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]] + msg = [ + "[__0] trying: A-3.0.0 (user goal)" + , "[__1] trying: B-1.0.0 (dependency of A)" + , "[__2] trying: C-1.0.0 (dependency of A)" + , "[__3] next goal: D (dependency of B)" + , "[__3] rejecting: D-2.0.0 (conflict: B => D==1.0.0)" + , "[__3] rejecting: D-1.0.0 (conflict: C => D==2.0.0)" + , "[__3] fail (backjumping, conflict set: B, C, D)" + , "[__2] fail (backjumping, conflict set: A, B, C, D)" + , "[__1] fail (backjumping, conflict set: A, B, C, D)" + , "[__0] skipping: A-2.0.0 (has the same characteristics that caused the " + ++ "previous version to fail: depends on 'B'; depends on 'C')" + , "[__0] trying: A-1.0.0" + , "[__1] trying: B-1.0.0 (dependency of A)" + , "[__2] next goal: D (dependency of B)" + , "[__2] rejecting: D-2.0.0 (conflict: B => D==1.0.0)" + , "[__2] trying: D-1.0.0" + , "[__3] done" + ] + in setVerbose $ goalOrder goals $ + mkTest db "only skip a version if it resolves none of the previous conflicts" ["A"] $ + SolverResult (isInfixOf msg) $ Right [("A", 1), ("B", 1), ("D", 1)] + + , -- This test ensures that the solver log doesn't show all conflicts + -- that the solver encountered in a subtree. The solver should only + -- show the conflicts that are contained in the current conflict set. + -- + -- The goal order forces the solver to try A-4, encounter a conflict + -- with B-2, try B-1, and then try C. A-4 conflicts with the only + -- version of C, so the solver backjumps with a conflict set of + -- {A, C}. When the solver skips the next version of A, the log should + -- mention the conflict with C but not B. + runTest $ + let db = [ + Right $ exAv "A" 4 [ExFix "B" 1, ExFix "C" 1] + , Right $ exAv "A" 3 [ExFix "B" 1, ExFix "C" 1] + , Right $ exAv "A" 2 [ExFix "C" 1] + , Right $ exAv "A" 1 [ExFix "C" 2] + , Right $ exAv "B" 2 [] + , Right $ exAv "B" 1 [] + , Right $ exAv "C" 2 [] + ] + goals = [P QualNone pkg | pkg <- ["A", "B", "C"]] + msg = [ + "[__0] trying: A-4.0.0 (user goal)" + , "[__1] next goal: B (dependency of A)" + , "[__1] rejecting: B-2.0.0 (conflict: A => B==1.0.0)" + , "[__1] trying: B-1.0.0" + , "[__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, A-2.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)" + , "[__1] trying: C-2.0.0" + , "[__2] done" + ] + in setVerbose $ goalOrder goals $ + mkTest db "don't show conflicts that aren't part of the conflict set" ["A"] $ + SolverResult (isInfixOf msg) $ Right [("A", 1), ("C", 2)] + + , -- Tests that the conflict set is properly updated when a version is + -- skipped due to being excluded by one of its reverse dependencies' + -- constraints. + runTest $ + let db = [ + Right $ exAv "A" 2 [ExFix "B" 3] + , Right $ exAv "A" 1 [ExFix "B" 1] + , Right $ exAv "B" 2 [] + , Right $ exAv "B" 1 [] + ] + msg = [ + "[__0] trying: A-2.0.0 (user goal)" + , "[__1] next goal: B (dependency of A)" + + -- During this step, the solver adds A and B to the + -- conflict set, with the details of each package's + -- conflict: + -- + -- A: A's constraint rejected B-2. + -- B: B was rejected by A's B==3 constraint + , "[__1] rejecting: B-2.0.0 (conflict: A => B==3.0.0)" + + -- When the solver skips B-1, it cannot simply reuse the + -- previous conflict set. It also needs to update A's + -- entry to say that A also rejected B-1. Otherwise, the + -- solver wouldn't know that A-1 could resolve one of + -- the conflicts encountered while exploring A-2. The + -- solver would skip A-1, even though it leads to the + -- solution. + , "[__1] skipping: B-1.0.0 (has the same characteristics that caused " + ++ "the previous version to fail: excluded by constraint '==3.0.0' from 'A')" + + , "[__1] fail (backjumping, conflict set: A, B)" + , "[__0] trying: A-1.0.0" + , "[__1] next goal: B (dependency of A)" + , "[__1] rejecting: B-2.0.0 (conflict: A => B==1.0.0)" + , "[__1] trying: B-1.0.0" + , "[__2] done" + ] + in setVerbose $ + mkTest db "update conflict set after skipping version - 1" ["A"] $ + SolverResult (isInfixOf msg) $ Right [("A", 1), ("B", 1)] + + , -- Tests that the conflict set is properly updated when a version is + -- skipped due to excluding a version of one of its dependencies. + -- This test is similar the previous one, with the goal order reversed. + runTest $ + let db = [ + Right $ exAv "A" 2 [] + , Right $ exAv "A" 1 [] + , Right $ exAv "B" 2 [ExFix "A" 3] + , Right $ exAv "B" 1 [ExFix "A" 1] + ] + goals = [P QualNone pkg | pkg <- ["A", "B"]] + msg = [ + "[__0] trying: A-2.0.0 (user goal)" + , "[__1] next goal: B (user goal)" + , "[__1] rejecting: B-2.0.0 (conflict: A==2.0.0, B => A==3.0.0)" + , "[__1] skipping: B-1.0.0 (has the same characteristics that caused " + ++ "the previous version to fail: excludes 'A' version 2.0.0)" + , "[__1] fail (backjumping, conflict set: A, B)" + , "[__0] trying: A-1.0.0" + , "[__1] next goal: B (user goal)" + , "[__1] rejecting: B-2.0.0 (conflict: A==1.0.0, B => A==3.0.0)" + , "[__1] trying: B-1.0.0" + , "[__2] done" + ] + in setVerbose $ goalOrder goals $ + mkTest db "update conflict set after skipping version - 2" ["A", "B"] $ + SolverResult (isInfixOf msg) $ Right [("A", 1), ("B", 1)] + ] -- Tests for the contents of the solver's log , testGroup "Solver log" [ -- See issue #3203. The solver should only choose a version for A once. @@ -428,16 +688,15 @@ tests = [ , testSummarizedLog "show conflicts from final conflict set after exhaustive search" Nothing $ "Could not resolve dependencies:\n" ++ "[__0] trying: A-1.0.0 (user goal)\n" - ++ "[__1] unknown package: D (dependency of A)\n" - ++ "[__1] fail (backjumping, conflict set: A, D)\n" + ++ "[__1] unknown package: F (dependency of A)\n" + ++ "[__1] fail (backjumping, conflict set: A, F)\n" ++ "After searching the rest of the dependency tree exhaustively, " - ++ "these were the goals I've had most trouble fulfilling: A, D" + ++ "these were the goals I've had most trouble fulfilling: A, F" , testSummarizedLog "show first conflicts after inexhaustive search" (Just 3) $ "Could not resolve dependencies:\n" ++ "[__0] trying: A-1.0.0 (user goal)\n" ++ "[__1] trying: B-3.0.0 (dependency of A)\n" - ++ "[__2] next goal: C (dependency of B)\n" - ++ "[__2] rejecting: C-1.0.0 (conflict: B => C==3.0.0)\n" + ++ "[__2] unknown package: C (dependency of B)\n" ++ "[__2] fail (backjumping, conflict set: B, C)\n" ++ "Backjump limit reached (currently 3, change with --max-backjumps " ++ "or try to run with --reorder-goals).\n" @@ -1399,28 +1658,27 @@ dbPC1 = [ , Right $ exAv "C" 1 [ExAny "B"] ] --- | Test for the solver's summarized log. The final conflict set is {A, D}, +-- | Test for the solver's summarized log. The final conflict set is {A, F}, -- though the goal order forces the solver to find the (avoidable) conflict --- between B >= 2 and C first. When the solver reaches the backjump limit, it --- should only show the log to the first conflict. When the backjump limit is --- high enough to allow an exhaustive search, the solver should make use of the --- final conflict set to only show the conflict between A and D in the --- summarized log. +-- between B and C first. When the solver reaches the backjump limit, it should +-- only show the log to the first conflict. When the backjump limit is high +-- enough to allow an exhaustive search, the solver should make use of the final +-- conflict set to only show the conflict between A and F in the summarized log. testSummarizedLog :: String -> Maybe Int -> String -> TestTree testSummarizedLog testName mbj expectedMsg = runTest $ maxBackjumps mbj $ goalOrder goals $ mkTest db testName ["A"] $ solverFailure (== expectedMsg) where db = [ - Right $ exAv "A" 1 [ExAny "B", ExAny "D"] - , Right $ exAv "B" 3 [ExFix "C" 3] - , Right $ exAv "B" 2 [ExFix "C" 2] - , Right $ exAv "B" 1 [ExAny "C"] - , Right $ exAv "C" 1 [] + Right $ exAv "A" 1 [ExAny "B", ExAny "F"] + , Right $ exAv "B" 3 [ExAny "C"] + , Right $ exAv "B" 2 [ExAny "D"] + , Right $ exAv "B" 1 [ExAny "E"] + , Right $ exAv "E" 1 [] ] goals :: [ExampleVar] - goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]] + goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D", "E", "F"]] dbMinimizeConflictSet :: ExampleDb dbMinimizeConflictSet = [ @@ -1453,9 +1711,7 @@ testMinimizeConflictSet testName = , "Trying to remove variable \"A\" from the conflict set." , "Failed to remove \"A\" from the conflict set. Continuing with {A, B, C, D}." , "Trying to remove variable \"B\" from the conflict set." - , "Successfully removed \"B\" from the conflict set. Continuing with {A, C, D}." - , "Trying to remove variable \"C\" from the conflict set." - , "Successfully removed \"C\" from the conflict set. Continuing with {A, D}." + , "Successfully removed \"B\" from the conflict set. Continuing with {A, D}." , "Trying to remove variable \"D\" from the conflict set." , "Failed to remove \"D\" from the conflict set. Continuing with {A, D}." ] @@ -1467,7 +1723,7 @@ testMinimizeConflictSet testName = ++ "[__1] rejecting: D-1.0.0 (conflict: A => D==2.0.0)\n" ++ "[__1] fail (backjumping, conflict set: A, D)\n" ++ "After searching the rest of the dependency tree exhaustively, these " - ++ "were the goals I've had most trouble fulfilling: A (7), D (6)" + ++ "were the goals I've had most trouble fulfilling: A (5), D (4)" goals :: [ExampleVar] goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]]