Commit 6fe3c5f7 authored by kristenk's avatar kristenk
Browse files

Solver: Deduplicate flags and stanzas in DependencyReason.

This commit changes DependencyReason's list fields to maps and sets. Duplicate
flags were possible when a flag appeared multiple times in nested conditionals
or a flag controlled a "Buildable: False" field. The duplicate flag could show
up in log messages:

Before:
[__5] trying: json-rpc-client:+demo
[__6] trying: process-1.6.1.0/installed-1.6... (dependency of json-rpc-client +demo +demo)

After:
[__5] trying: json-rpc-client:+demo
[__6] trying: process-1.6.1.0/installed-1.6... (dependency of json-rpc-client +demo)
parent b7255d3b
......@@ -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
......@@ -84,7 +84,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
......@@ -175,7 +175,7 @@ convGPD os arch cinfo strfl solveExes pn
convCondTree 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 +191,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
--
......@@ -366,7 +366,7 @@ convBranch dr pkg os arch cinfo pn fds comp getInfo ipns solveExes (CondBranch c
addFlag :: FlagName -> FlagValue -> DependencyReason pn -> DependencyReason pn
addFlag fn v (DependencyReason pn' flags stanzas) =
DependencyReason pn' ((fn, v) : flags) stanzas
DependencyReason pn' (M.insert fn v flags) stanzas
-- 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 +393,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 +406,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.
......
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