Unverified Commit 86af280b authored by Mikhail Glushenkov's avatar Mikhail Glushenkov Committed by GitHub
Browse files

Merge pull request #4929 from grayjay/duplicate-flag-message

Solver: Deduplicate flags and stanzas in DependencyReason.
parents 912f2236 4f7ac10d
......@@ -21,6 +21,7 @@ module Distribution.Solver.Modular.Builder (
import Data.List as L
import Data.Map as M
import Data.Set as S
import Prelude hiding (sequence, mapM)
import Distribution.Solver.Modular.Dependency
......@@ -86,7 +87,7 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
-- GoalReason for a flag or stanza. Each flag/stanza is introduced only by
-- its containing package.
flagGR :: qpn -> GoalReason qpn
flagGR qpn = DependencyGoal (DependencyReason qpn [] [])
flagGR qpn = DependencyGoal (DependencyReason qpn M.empty S.empty)
-- | Given the current scope, qualify all the package names in the given set of
-- dependencies and then extend the set of open goals accordingly.
......
......@@ -35,6 +35,8 @@ module Distribution.Solver.Modular.Dependency (
) where
import Prelude ()
import qualified Data.Map as M
import qualified Data.Set as S
import Distribution.Client.Compat.Prelude hiding (pi)
import Language.Haskell.Extension (Extension(..), Language(..))
......@@ -120,7 +122,7 @@ data Dep qpn = Dep (Maybe UnqualComponentName) qpn CI -- ^ dependency on a pack
-- flag and stanza choices that introduced the dependency. It contains
-- everything needed for creating ConflictSets or describing conflicts in solver
-- log messages.
data DependencyReason qpn = DependencyReason qpn [(Flag, FlagValue)] [Stanza]
data DependencyReason qpn = DependencyReason qpn (Map Flag FlagValue) (S.Set Stanza)
deriving (Functor, Eq, Show)
-- | Print the reason that a dependency was introduced.
......@@ -128,7 +130,8 @@ showDependencyReason :: DependencyReason QPN -> String
showDependencyReason (DependencyReason qpn flags stanzas) =
intercalate " " $
showQPN qpn
: map (uncurry showFlagValue) flags ++ map (\s -> showSBool s True) stanzas
: map (uncurry showFlagValue) (M.toList flags)
++ map (\s -> showSBool s True) (S.toList stanzas)
-- | Options for goal qualification (used in 'qualifyDeps')
--
......@@ -270,13 +273,13 @@ goalReasonToCS (DependencyGoal dr) = dependencyReasonToCS dr
-- It drops the flag and stanza values, which are only needed for log messages.
dependencyReasonToCS :: DependencyReason QPN -> ConflictSet
dependencyReasonToCS (DependencyReason qpn flags stanzas) =
CS.fromList $ P qpn : flagVars ++ map stanzaToVar stanzas
CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas)
where
-- Filter out any flags that introduced the dependency with both values.
-- They don't need to be included in the conflict set, because changing the
-- flag value can't remove the dependency.
flagVars :: [Var QPN]
flagVars = [F (FN qpn fn) | (fn, fv) <- flags, fv /= FlagBoth]
flagVars = [F (FN qpn fn) | (fn, fv) <- M.toList flags, fv /= FlagBoth]
stanzaToVar :: Stanza -> Var QPN
stanzaToVar = S . SN qpn
......@@ -3,7 +3,8 @@ module Distribution.Solver.Modular.IndexConversion
) where
import Data.List as L
import Data.Map as M
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid as Mon
import Data.Set as S
......@@ -84,7 +85,7 @@ convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi)
-- | Convert a single installed package into the solver-specific format.
convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo)
convIP idx ipi =
case mapM (convIPId (DependencyReason pn [] []) comp idx) (IPI.depends ipi) of
case mapM (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of
Nothing -> (pn, i, PInfo [] [] M.empty (Just Broken))
Just fds -> (pn, i, PInfo fds [] M.empty Nothing)
where
......@@ -172,10 +173,10 @@ convGPD os arch cinfo strfl solveExes pn
conv :: Mon.Monoid a => Component -> (a -> BuildInfo) -> DependencyReason PN ->
CondTree ConfVar [Dependency] a -> FlaggedDeps PN
conv comp getInfo dr =
convCondTree dr pkg os arch cinfo pn fds comp getInfo ipns solveExes .
convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo ipns solveExes .
PDC.addBuildableCondition getInfo
initDR = DependencyReason pn [] []
initDR = DependencyReason pn M.empty S.empty
flagged_deps
= concatMap (\ds -> conv ComponentLib libBuildInfo initDR ds) (maybeToList mlib)
......@@ -191,7 +192,7 @@ convGPD os arch cinfo strfl solveExes pn
++ maybe [] (convSetupBuildInfo pn) (setupBuildInfo pkg)
addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn
addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (s : ss)
addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (S.insert s ss)
-- | We infer the maximally supported spec-version from @lib:Cabal@'s version
--
......@@ -245,42 +246,56 @@ flagInfo (StrongFlags strfl) =
-- dependencies.
type IPNs = Set PN
-- | Convenience function to delete a 'FlaggedDep' if it's
-- | Convenience function to delete a 'Dependency' if it's
-- for a 'PN' that isn't actually real.
filterIPNs :: IPNs -> Dependency -> FlaggedDep PN -> FlaggedDeps PN
filterIPNs ipns (Dependency pn _) fd
| S.notMember pn ipns = [fd]
| otherwise = []
filterIPNs :: IPNs -> Dependency -> Maybe Dependency
filterIPNs ipns d@(Dependency pn _)
| S.notMember pn ipns = Just d
| otherwise = Nothing
-- | Convert condition trees to flagged dependencies. Mutually
-- recursive with 'convBranch'. See 'convBranch' for an explanation
-- of all arguments preceeding the input 'CondTree'.
convCondTree :: DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo ->
convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo ->
Component ->
(a -> BuildInfo) ->
IPNs ->
SolveExecutables ->
CondTree ConfVar [Dependency] a -> FlaggedDeps PN
convCondTree dr pkg os arch cinfo pn fds comp getInfo ipns solveExes@(SolveExecutables solveExes') (CondNode info ds branches) =
concatMap
(\d -> filterIPNs ipns d (D.Simple (convLibDep dr d) comp)) ds -- unconditional package dependencies
convCondTree flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes@(SolveExecutables solveExes') (CondNode info ds branches) =
L.map (\d -> D.Simple (convLibDep dr d) comp)
(mergeDeps $ mapMaybe (filterIPNs ipns) ds) -- unconditional package dependencies
++ L.map (\e -> D.Simple (LDep dr (Ext e)) comp) (PD.allExtensions bi) -- unconditional extension dependencies
++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (PD.allLanguages bi) -- unconditional language dependencies
++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies
++ concatMap (convBranch dr pkg os arch cinfo pn fds comp getInfo ipns solveExes) branches
++ concatMap (convBranch flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes) branches
-- build-tools dependencies
-- NB: Only include these dependencies if SolveExecutables
-- is True. It might be false in the legacy solver
-- codepath, in which case there won't be any record of
-- an executable we need.
++ [ D.Simple (convExeDep dr exeDep) comp
++ L.map (\d -> D.Simple (convExeDep dr d) comp)
(mergeExeDeps
[ exeDep
| solveExes'
, exeDep <- getAllToolDependencies pkg bi
, not $ isInternal pkg exeDep
]
])
where
bi = getInfo info
-- Combine dependencies on the same package.
mergeDeps :: [Dependency] -> [Dependency]
mergeDeps deps =
L.map (uncurry Dependency) $ M.toList $
M.fromListWith (.&&.) [(p, vr) | Dependency p vr <- deps]
-- Combine dependencies on the same package and executable.
mergeExeDeps :: [ExeDependency] -> [ExeDependency]
mergeExeDeps deps =
L.map (\((p, exe), vr) -> ExeDependency p exe vr) $ M.toList $
M.fromListWith (.&&.) [((p, exe), vr) | ExeDependency p exe vr <- deps]
-- | Branch interpreter. Mutually recursive with 'convCondTree'.
--
-- Here, we try to simplify one of Cabal's condition tree branches into the
......@@ -292,61 +307,81 @@ convCondTree dr pkg os arch cinfo pn fds comp getInfo ipns solveExes@(SolveExecu
--
-- This function takes a number of arguments:
--
-- 1. Some pre dependency-solving known information ('OS', 'Arch',
-- 1. A map of flag values that have already been chosen. It allows
-- convBranch to avoid creating nested FlaggedDeps that are
-- controlled by the same flag and avoid creating DependencyReasons with
-- conflicting values for the same flag.
--
-- 2. The DependencyReason calculated at this point in the tree of
-- conditionals. The flag values in the DependencyReason are similar to
-- the values in the map above, except for the use of FlagBoth.
--
-- 3. Some pre dependency-solving known information ('OS', 'Arch',
-- 'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables,
--
-- 2. The package name @'PN'@ which this condition tree
-- 4. The package name @'PN'@ which this condition tree
-- came from, so that we can correctly associate @flag()@
-- variables with the correct package name qualifier,
--
-- 3. The flag defaults 'FlagInfo' so that we can populate
-- 5. The flag defaults 'FlagInfo' so that we can populate
-- 'Flagged' dependencies with 'FInfo',
--
-- 4. The name of the component 'Component' so we can record where
-- 6. The name of the component 'Component' so we can record where
-- the fine-grained information about where the component came
-- from (see 'convCondTree'), and
--
-- 5. A selector to extract the 'BuildInfo' from the leaves of
-- 7. A selector to extract the 'BuildInfo' from the leaves of
-- the 'CondTree' (which actually contains the needed
-- dependency information.)
--
-- 6. The set of package names which should be considered internal
-- 8. The set of package names which should be considered internal
-- dependencies, and thus not handled as dependencies.
convBranch :: DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo ->
PN -> FlagInfo ->
Component ->
(a -> BuildInfo) ->
IPNs ->
SolveExecutables ->
CondBranch ConfVar [Dependency] a ->
FlaggedDeps PN
convBranch dr pkg os arch cinfo pn fds comp getInfo ipns solveExes (CondBranch c' t' mf') =
convBranch :: Map FlagName Bool
-> DependencyReason PN
-> PackageDescription
-> OS
-> Arch
-> CompilerInfo
-> PN
-> FlagInfo
-> Component
-> (a -> BuildInfo)
-> IPNs
-> SolveExecutables
-> CondBranch ConfVar [Dependency] a
-> FlaggedDeps PN
convBranch flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes (CondBranch c' t' mf') =
go c'
(\dr' -> convCondTree dr' pkg os arch cinfo pn fds comp getInfo ipns solveExes t')
(\dr' -> maybe [] (convCondTree dr' pkg os arch cinfo pn fds comp getInfo ipns solveExes) mf')
dr
(\flags' dr' -> convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo ipns solveExes t')
(\flags' dr' -> maybe [] (convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo ipns solveExes) mf')
flags dr
where
go :: Condition ConfVar
-> (DependencyReason PN -> FlaggedDeps PN)
-> (DependencyReason PN -> FlaggedDeps PN)
-> DependencyReason PN -> FlaggedDeps PN
-> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN)
-> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN)
-> Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN
go (Lit True) t _ = t
go (Lit False) _ f = f
go (CNot c) t f = go c f t
go (CAnd c d) t f = go c (go d t f) f
go (COr c d) t f = go c t (go d t f)
go (Var (Flag fn)) t f = \dr' ->
-- Add each flag to the DependencyReason for all dependencies below,
-- including any extracted dependencies. Extracted dependencies are
-- introduced by both flag values (FlagBoth). Note that we don't
-- actually need to add the flag to the extracted dependencies for
-- correct backjumping; the information only improves log messages by
-- giving the user the full reason for each dependency.
let addFlagVal v = addFlag fn v dr'
in extractCommon (t (addFlagVal FlagBoth))
(f (addFlagVal FlagBoth))
++ [ Flagged (FN pn fn) (fds ! fn) (t (addFlagVal FlagTrue))
(f (addFlagVal FlagFalse)) ]
go (Var (Flag fn)) t f = \flags' ->
case M.lookup fn flags' of
Just True -> t flags'
Just False -> f flags'
Nothing -> \dr' ->
-- Add each flag to the DependencyReason for all dependencies below,
-- including any extracted dependencies. Extracted dependencies are
-- introduced by both flag values (FlagBoth). Note that we don't
-- actually need to add the flag to the extracted dependencies for
-- correct backjumping; the information only improves log messages
-- by giving the user the full reason for each dependency.
let addFlagValue v = addFlagToDependencyReason fn v dr'
addFlag v = M.insert fn v flags'
in extractCommon (t (addFlag True) (addFlagValue FlagBoth))
(f (addFlag False) (addFlagValue FlagBoth))
++ [ Flagged (FN pn fn) (fds M.! fn) (t (addFlag True) (addFlagValue FlagTrue))
(f (addFlag False) (addFlagValue FlagFalse)) ]
go (Var (OS os')) t f
| os == os' = t
| otherwise = f
......@@ -364,9 +399,9 @@ convBranch dr pkg os arch cinfo pn fds comp getInfo ipns solveExes (CondBranch c
where
matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv
addFlag :: FlagName -> FlagValue -> DependencyReason pn -> DependencyReason pn
addFlag fn v (DependencyReason pn' flags stanzas) =
DependencyReason pn' ((fn, v) : flags) stanzas
addFlagToDependencyReason :: FlagName -> FlagValue -> DependencyReason pn -> DependencyReason pn
addFlagToDependencyReason fn v (DependencyReason pn' fs ss) =
DependencyReason pn' (M.insert fn v fs) ss
-- If both branches contain the same package as a simple dep, we lift it to
-- the next higher-level, but with the union of version ranges. This
......@@ -393,7 +428,7 @@ convBranch dr pkg os arch cinfo pn fds comp getInfo ipns solveExes (CondBranch c
-- conditional.
mergeDRs :: DependencyReason pn -> DependencyReason pn -> DependencyReason pn
mergeDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) =
DependencyReason pn' (nub $ fs1 ++ fs2) (nub $ ss1 ++ ss2)
DependencyReason pn' (M.union fs1 fs2) (S.union ss1 ss2)
-- | Convert a Cabal dependency on a library to a solver-specific dependency.
convLibDep :: DependencyReason PN -> Dependency -> LDep PN
......@@ -406,4 +441,5 @@ convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (Just exe) pn (Constrain
-- | Convert setup dependencies
convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN
convSetupBuildInfo pn nfo =
L.map (\d -> D.Simple (convLibDep (DependencyReason pn [] []) d) ComponentSetup) (PD.setupDepends nfo)
L.map (\d -> D.Simple (convLibDep (DependencyReason pn M.empty S.empty) d) ComponentSetup)
(PD.setupDepends nfo)
......@@ -232,4 +232,4 @@ _removeGR = trav go
DependencyGoal $
DependencyReason
(Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$"))
[] []
M.empty S.empty
......@@ -397,7 +397,7 @@ extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle
extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment
extendWithPackageChoice (PI qpn i) ppa =
let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa
newChoice = PkgDep (DependencyReason qpn [] []) Nothing qpn (Fixed i)
newChoice = PkgDep (DependencyReason qpn M.empty S.empty) Nothing qpn (Fixed i)
in case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of
Left (c, (d, _d')) -> -- Don't include the package choice in the
-- FailReason, because it is redundant.
......
......@@ -38,11 +38,11 @@ eqVR = CV.thisVersion
-- | Intersect two version ranges.
(.&&.) :: VR -> VR -> VR
(.&&.) = CV.intersectVersionRanges
v1 .&&. v2 = simplifyVR $ CV.intersectVersionRanges v1 v2
-- | Union of two version ranges.
(.||.) :: VR -> VR -> VR
(.||.) = CV.unionVersionRanges
v1 .||. v2 = simplifyVR $ CV.unionVersionRanges v1 v2
-- | Simplify a version range.
simplifyVR :: VR -> VR
......
......@@ -11,6 +11,7 @@ tests = [
runTest $ basicTest "basic space leak test"
, runTest $ flagsTest "package with many flags"
, runTest $ issue2899 "issue #2899"
, runTest $ duplicateDependencies "duplicate dependencies"
]
-- | This test solves for n packages that each have two versions. There is no
......@@ -95,3 +96,68 @@ issue2899 name =
goals :: [ExampleVar]
goals = [P QualNone "setup-dep", P (QualSetup "target") "setup-dep"]
-- | Test for an issue related to lifting dependencies out of conditionals when
-- converting a PackageDescription to the solver's internal representation.
--
-- Issue:
-- For each conditional and each package B, the solver combined each dependency
-- on B in the true branch with each dependency on B in the false branch. It
-- added the combined dependencies to the build-depends outside of the
-- conditional. Since dependencies could be lifted out of multiple levels of
-- conditionals, the number of new dependencies could grow exponentially in the
-- number of levels. For example, the following package generated 4 copies of B
-- under flag-2=False, 8 copies under flag-1=False, and 16 copies at the top
-- level:
--
-- if flag(flag-1)
-- build-depends: B, B
-- else
-- if flag(flag-2)
-- build-depends: B, B
-- else
-- if flag(flag-3)
-- build-depends: B, B
-- else
-- build-depends: B, B
--
-- This issue caused the quickcheck tests to start frequently running out of
-- memory after an optimization that pruned unreachable branches (See PR #4929).
-- Each problematic test case contained at least one build-depends field with
-- duplicate dependencies, which was then duplicated under multiple levels of
-- conditionals by the solver's "buildable: False" transformation, when
-- "buildable: False" was under multiple flags. Finally, the branch pruning
-- feature put all build-depends fields in consecutive levels of the condition
-- tree, causing the solver's representation of the package to follow the
-- pattern in the example above.
--
-- Now the solver avoids this issue by combining all dependencies on the same
-- package within a build-depends field before lifting them out of conditionals.
--
-- This test case is an expanded version of the example above, with library and
-- build-tool dependencies.
duplicateDependencies :: String -> SolverTest
duplicateDependencies name =
mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)]
where
copies, depth :: Int
copies = 50
depth = 50
pkgs :: ExampleDb
pkgs = [
Right $ exAv "A" 1 (flaggedDependencies 1)
, Right $ exAv "B" 1 [] `withExe` ExExe "exe" []
]
flaggedDependencies :: Int -> [ExampleDependency]
flaggedDependencies n
| n > depth = buildDepends
| otherwise = [exFlagged (flagName n) buildDepends
(flaggedDependencies (n + 1))]
where
buildDepends = replicate copies (ExFix "B" 1)
++ replicate copies (ExBuildToolFix "B" "exe" 1)
flagName :: Int -> ExampleFlagName
flagName x = "flag-" ++ show x
......@@ -51,6 +51,11 @@ tests = [
, runTest $ indep $ mkTest db4 "linkFlags2" ["C", "D"] anySolverFailure
, runTest $ indep $ mkTest db18 "linkFlags3" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)])
]
, testGroup "Lifting dependencies out of conditionals" [
runTest $ commonDependencyLogMessage "common dependency log message"
, runTest $ twoLevelDeepCommonDependencyLogMessage "two level deep common dependency log message"
, runTest $ testBackjumpingWithCommonDependency "backjumping with common dependency"
]
, testGroup "Manual flags" [
runTest $ mkTest dbManualFlags "Use default value for manual flag" ["pkg"] $
solverSuccess [("pkg", 1), ("true-dep", 1)]
......@@ -911,6 +916,61 @@ db18 = [
, Right $ exAv "G" 1 []
]
-- | When both values for flagA introduce package B, the solver should be able
-- to choose B before choosing a value for flagA. It should try to choose a
-- version for B that is in the union of the version ranges required by +flagA
-- and -flagA.
commonDependencyLogMessage :: String -> SolverTest
commonDependencyLogMessage name =
mkTest db name ["A"] $ solverFailure $ isInfixOf $
"trying: A-1.0.0 (user goal)\n"
++ "next goal: B (dependency of A +/-flagA)\n"
++ "rejecting: B-2.0.0 (conflict: A +/-flagA => B==1.0.0 || ==3.0.0)"
where
db :: ExampleDb
db = [
Right $ exAv "A" 1 [exFlagged "flagA"
[ExFix "B" 1]
[ExFix "B" 3]]
, Right $ exAv "B" 2 []
]
-- | Test lifting dependencies out of multiple levels of conditionals.
twoLevelDeepCommonDependencyLogMessage :: String -> SolverTest
twoLevelDeepCommonDependencyLogMessage name =
mkTest db name ["A"] $ solverFailure $ isInfixOf $
"unknown package: B (dependency of A +/-flagA +/-flagB)"
where
db :: ExampleDb
db = [
Right $ exAv "A" 1 [exFlagged "flagA"
[exFlagged "flagB"
[ExAny "B"]
[ExAny "B"]]
[exFlagged "flagB"
[ExAny "B"]
[ExAny "B"]]]
]
-- | Test handling nested conditionals that are controlled by the same flag.
-- The solver should treat flagA as introducing 'unknown' with value true, not
-- both true and false. That means that when +flagA causes a conflict, the
-- solver should try flipping flagA to false to resolve the conflict, rather
-- than backjumping past flagA.
testBackjumpingWithCommonDependency :: String -> SolverTest
testBackjumpingWithCommonDependency name =
mkTest db name ["A"] $ solverSuccess [("A", 1), ("B", 1)]
where
db :: ExampleDb
db = [
Right $ exAv "A" 1 [exFlagged "flagA"
[exFlagged "flagA"
[ExAny "unknown"]
[ExAny "unknown"]]
[ExAny "B"]]
, Right $ exAv "B" 1 []
]
-- | Tricky test case with independent goals (issue #2842)
--
-- Suppose we are installing D, E, and F as independent goals:
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment