Commit e1ca9dcf authored by kristenk's avatar kristenk
Browse files

Remove the package instance from D.Solver.Modular.Var (closes #4142).

This change has several effects:

- The solver no longer includes the package version in messages that relate to
  a package's flags, stanzas, or dependencies.  However, the solver always
  chooses the package version before choosing any flags, stanzas, or
  dependencies for the package, so it should be easy to find the version
  by looking earlier in the log.
- In conflict counting, the solver treats flags with the same name in different
  versions of a package as the same flag.  This change in the conflict counting
  heuristic can improve the solver's efficiency when the same flag causes the
  same conflicts in different versions of a package.  The same applies to
  enabling tests or benchmarks.
- Each flag or stanza can only appear once in a conflict set.  This has no
  effect on behavior, but it simplifies the message containing the final
  conflict set.

Here is an example of the change in a log message.  It only prints
hackage-server's version once, when it first chooses the package.  The conflict
set also has one fewer variable, but that is probably due to the change in
conflict counting.

 Resolving dependencies...
 cabal: Could not resolve dependencies:
 trying: hackage-server-0.5.0 (user goal)
-trying: hackage-server-0.5.0:+build-hackage-build
-trying: unix-2.7.2.1/installed-2.7... (dependency of hackage-server-0.5.0
+trying: hackage-server:+build-hackage-build
+trying: unix-2.7.2.1/installed-2.7... (dependency of hackage-server
 +build-hackage-build)
-next goal: aeson (dependency of hackage-server-0.5.0 +build-hackage-build)
+next goal: aeson (dependency of hackage-server +build-hackage-build)
 rejecting: aeson-1.2.2.0, aeson-1.2.1.0, aeson-1.2.0.0, aeson-1.1.2.0,
 aeson-1.1.1.0, aeson-1.1.0.0, aeson-1.0.2.1, aeson-1.0.2.0, aeson-1.0.1.0,
 aeson-1.0.0.0, aeson-0.11.3.0, aeson-0.11.2.1, aeson-0.11.2.0, aeson-0.11.1.4,
 aeson-0.11.1.3, aeson-0.11.1.2, aeson-0.11.1.1, aeson-0.11.1.0,
 aeson-0.11.0.0, aeson-0.9.0.1, aeson-0.9.0.0, aeson-0.8.1.1, aeson-0.8.1.0,
 aeson-0.8.0.2, aeson-0.7.0.6, aeson-0.7.0.4, aeson-0.6.2.1, aeson-0.6.2.0
 (conflict: hackage-server +build-hackage-build => aeson==0.6.1.*)
 rejecting: aeson-0.6.1.0 (conflict: unix => time==1.6.0.1/installed-1.6...,
 aeson => time<1.5)
 rejecting: aeson-0.6.0.2, aeson-0.6.0.1, aeson-0.6.0.0, aeson-0.5.0.0,
 aeson-0.4.0.1, aeson-0.4.0.0, aeson-0.3.2.14, aeson-0.3.2.13, aeson-0.3.2.12,
 aeson-0.3.2.11, aeson-0.3.2.10, aeson-0.3.2.9, aeson-0.3.2.8, aeson-0.3.2.7,
 aeson-0.3.2.6, aeson-0.3.2.5, aeson-0.3.2.4, aeson-0.3.2.3, aeson-0.3.2.2,
 aeson-0.3.2.1, aeson-0.3.2.0, aeson-0.3.1.1, aeson-0.3.1.0, aeson-0.3.0.0,
 aeson-0.2.0.0, aeson-0.1.0.0, aeson-0.10.0.0, aeson-0.8.0.1, aeson-0.8.0.0,
 aeson-0.7.0.5, aeson-0.7.0.3, aeson-0.7.0.2, aeson-0.7.0.1, aeson-0.7.0.0
 (conflict: hackage-server +build-hackage-build => aeson==0.6.1.*)
 After searching the rest of the dependency tree exhaustively, these were the
-goals I've had most trouble fulfilling: aeson, hackage-server,
-hackage-server-0.5.0:build-hackage-build,
-hackage-server-0.4:build-hackage-mirror, template-haskell
+goals I've had most trouble fulfilling: aeson,
+hackage-server:build-hackage-build, hackage-server, template-haskell

I ran hackage-benchmark to compare this commit with master (two commits
earlier).  I used --min-run-time-percentage-difference-to-rerun=10 to only rerun
packages if the run times differed by more than 10% in the first trial, and
defaults for the rest of the options (10 trials, p-value of 0.05, 90 second
timeout). The index state was "2017-09-24T03:35:06Z".

1 is master, and 2 is this commit:

package            result1       result2             mean1       mean2     stddev1     stddev2     speedup
CC-delcont-ref     Solution      Solution           1.467s      1.505s      0.019s      0.100s      0.975
ascii-cows         Solution      Solution           1.827s      1.758s      0.159s      0.012s      1.040
opaleye-classy     NoInstallPlan NoInstallPlan      4.588s      4.070s      0.043s      0.032s      1.127
range-space        NoInstallPlan NoInstallPlan      2.642s      2.299s      0.016s      0.016s      1.149
rts                PkgNotFound   PkgNotFound        1.323s      1.327s      0.032s      0.033s      0.997
servant-auth-docs  Solution      Solution           1.968s      1.998s      0.017s      0.074s      0.985
thorn              BackjumpLimit NoInstallPlan      4.793s      3.141s      0.050s      0.034s      1.526
unordered-intmap   Solution      Solution           1.502s      1.511s      0.081s      0.047s      0.994

I looked at the solver logs for the three packages with the largest changes in
run time, opaleye-classy, range-space, and thorn.  Each one showed that the
solver started preferring a flag in an older version of a package after it had
caused conflicts in a newer version of the package.
parent efa85a39
......@@ -65,13 +65,13 @@ toCPs (A pa fa sa) rdm =
-- complete flag assignment by package.
fapp :: Map QPN FlagAssignment
fapp = M.fromListWith (++) $
L.map (\ ((FN (PI qpn _) fn), b) -> (qpn, [(fn, b)])) $
L.map (\ ((FN qpn fn), b) -> (qpn, [(fn, b)])) $
M.toList $
fa
-- Stanzas per package.
sapp :: Map QPN [OptionalStanza]
sapp = M.fromListWith (++) $
L.map (\ ((SN (PI qpn _) sn), b) -> (qpn, if b then [sn] else [])) $
L.map (\ ((SN qpn sn), b) -> (qpn, if b then [sn] else [])) $
M.toList $
sa
-- Dependencies per package.
......
......@@ -21,7 +21,7 @@ module Distribution.Solver.Modular.Builder (
import Data.List as L
import Data.Map as M
import Prelude hiding (pi, sequence, mapM)
import Prelude hiding (sequence, mapM)
import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Flag
......@@ -63,13 +63,13 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
where
go :: RevDepMap -> [OpenGoal] -> [PotentialGoal] -> BuildState
go g o [] = s { rdeps = g, open = o }
go g o ((PotentialGoal (Flagged fn@(FN pi _) fInfo t f) ) : ngs) =
go g (FlagGoal fn fInfo t f (flagGR pi) : o) ngs
go g o ((PotentialGoal (Flagged fn@(FN qpn _) fInfo t f) ) : ngs) =
go g (FlagGoal fn fInfo t f (flagGR qpn) : o) ngs
-- Note: for 'Flagged' goals, we always insert, so later additions win.
-- This is important, because in general, if a goal is inserted twice,
-- the later addition will have better dependency information.
go g o ((PotentialGoal (Stanza sn@(SN pi _) t) ) : ngs) =
go g (StanzaGoal sn t (flagGR pi) : o) ngs
go g o ((PotentialGoal (Stanza sn@(SN qpn _) t) ) : ngs) =
go g (StanzaGoal sn t (flagGR qpn) : o) ngs
go g o ((PotentialGoal (Simple (LDep dr (Dep _ qpn _)) c)) : ngs)
| qpn == qpn' = go g o ngs
-- we ignore self-dependencies at this point; TODO: more care may be needed
......@@ -85,19 +85,19 @@ 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 :: PI qpn -> GoalReason qpn
flagGR pi = DependencyGoal (DependencyReason pi [] [])
flagGR :: qpn -> GoalReason qpn
flagGR qpn = DependencyGoal (DependencyReason qpn [] [])
-- | Given the current scope, qualify all the package names in the given set of
-- dependencies and then extend the set of open goals accordingly.
scopedExtendOpen :: QPN -> I -> FlaggedDeps PN -> FlagInfo ->
scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo ->
BuildState -> BuildState
scopedExtendOpen qpn i fdeps fdefs s = extendOpen qpn gs s
scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s
where
-- Qualify all package names
qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps
-- Introduce all package flags
qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs
qfdefs = L.map (\ (fn, b) -> Flagged (FN qpn fn) b [] []) $ M.toList fdefs
-- Combine new package and flag goals
gs = L.map PotentialGoal (qfdefs ++ qfdeps)
-- NOTE:
......@@ -107,9 +107,9 @@ scopedExtendOpen qpn i fdeps fdefs s = extendOpen qpn gs s
-- | Datatype that encodes what to build next
data BuildType =
Goals -- ^ build a goal choice node
| OneGoal OpenGoal -- ^ build a node for this goal
| Instance QPN I PInfo -- ^ build a tree for a concrete instance
Goals -- ^ build a goal choice node
| OneGoal OpenGoal -- ^ build a node for this goal
| Instance QPN PInfo -- ^ build a tree for a concrete instance
build :: Linker BuildState -> Tree () QGoalReason
build = ana go
......@@ -142,13 +142,13 @@ addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _
case M.lookup pn idx of
Nothing -> PChoiceF qpn rdm gr (W.fromList [])
Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) ->
([], POption i Nothing, bs { next = Instance qpn i info }))
([], POption i Nothing, bs { next = Instance qpn info }))
(M.toList pis)))
-- TODO: data structure conversion is rather ugly here
-- For a flag, we create only two subtrees, and we create them in the order
-- that is indicated by the flag default.
addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN (PI qpn _) _) (FInfo b m w) t f gr) }) =
addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr) }) =
FChoiceF qfn rdm gr weak m b (W.fromList
[([if b then 0 else 1], True, (extendOpen qpn (L.map PotentialGoal t) bs) { next = Goals }),
([if b then 1 else 0], False, (extendOpen qpn (L.map PotentialGoal f) bs) { next = Goals })])
......@@ -161,7 +161,7 @@ addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN (PI qpn _) _)
-- the stanza by replacing the False branch with failure) or preferences
-- (try enabling the stanza if possible by moving the True branch first).
addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN (PI qpn _) _) t gr) }) =
addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr) }) =
SChoiceF qsn rdm gr trivial (W.fromList
[([0], False, bs { next = Goals }),
([1], True, (extendOpen qpn (L.map PotentialGoal t) bs) { next = Goals })])
......@@ -172,8 +172,8 @@ addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN (PI qpn _)
-- and furthermore we update the set of goals.
--
-- TODO: We could inline this above.
addChildren bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) }) =
addChildren ((scopedExtendOpen qpn i fdeps fdefs bs)
addChildren bs@(BS { next = Instance qpn (PInfo fdeps fdefs _) }) =
addChildren ((scopedExtendOpen qpn fdeps fdefs bs)
{ next = Goals })
{-------------------------------------------------------------------------------
......
......@@ -11,7 +11,6 @@ import qualified Distribution.Compat.Graph as G
import Distribution.Simple.Utils (ordNub)
import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.Tree
import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Types.ComponentDeps (Component)
......@@ -25,9 +24,9 @@ detectCyclesPhase = cata go
go :: TreeF d c (Tree d c) -> Tree d c
go (PChoiceF qpn rdm gr cs) =
PChoice qpn rdm gr $ fmap (checkChild qpn) cs
go (FChoiceF qfn@(FN (PI qpn _) _) rdm gr w m d cs) =
go (FChoiceF qfn@(FN qpn _) rdm gr w m d cs) =
FChoice qfn rdm gr w m d $ fmap (checkChild qpn) cs
go (SChoiceF qsn@(SN (PI qpn _) _) rdm gr w cs) =
go (SChoiceF qsn@(SN qpn _) rdm gr w cs) =
SChoice qsn rdm gr w $ fmap (checkChild qpn) cs
go x = inn x
......
......@@ -128,32 +128,30 @@ data Dep qpn = Dep IsExe qpn CI -- ^ dependency on a package (possibly fo
-- 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 (PI qpn) [(Flag, FlagValue)] [Stanza]
data DependencyReason qpn = DependencyReason qpn [(Flag, FlagValue)] [Stanza]
deriving (Functor, Eq, Show)
-- | Print a dependency. The first parameter determines how to print the package
-- instance of the dependent package.
showDep :: (PI QPN -> String) -> LDep QPN -> String
showDep showPI' (LDep dr (Dep (IsExe is_exe) qpn (Fixed i) )) =
let DependencyReason (PI qpn' _) _ _ = dr
in (if qpn /= qpn' then showDependencyReason showPI' dr ++ " => " else "") ++
-- | Print a dependency.
showDep :: LDep QPN -> String
showDep (LDep dr (Dep (IsExe is_exe) qpn (Fixed i) )) =
let DependencyReason qpn' _ _ = dr
in (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++
showQPN qpn ++
(if is_exe then " (exe) " else "") ++ "==" ++ showI i
showDep showPI' (LDep dr (Dep (IsExe is_exe) qpn (Constrained vr))) =
showDependencyReason showPI' dr ++ " => " ++ showQPN qpn ++
showDep (LDep dr (Dep (IsExe is_exe) qpn (Constrained vr))) =
showDependencyReason dr ++ " => " ++ showQPN qpn ++
(if is_exe then " (exe) " else "") ++ showVR vr
showDep _ (LDep _ (Ext ext)) = "requires " ++ display ext
showDep _ (LDep _ (Lang lang)) = "requires " ++ display lang
showDep _ (LDep _ (Pkg pn vr)) = "requires pkg-config package "
showDep (LDep _ (Ext ext)) = "requires " ++ display ext
showDep (LDep _ (Lang lang)) = "requires " ++ display lang
showDep (LDep _ (Pkg pn vr)) = "requires pkg-config package "
++ display pn ++ display vr
++ ", not found in the pkg-config database"
-- | Print the reason that a dependency was introduced. The first parameter
-- determines how to print the package instance.
showDependencyReason :: (PI QPN -> String) -> DependencyReason QPN -> String
showDependencyReason showPI' (DependencyReason pi flags stanzas) =
-- | Print the reason that a dependency was introduced.
showDependencyReason :: DependencyReason QPN -> String
showDependencyReason (DependencyReason qpn flags stanzas) =
intercalate " " $
showPI' pi
showQPN qpn
: map (uncurry showFlagValue) flags ++ map (\s -> showSBool s True) stanzas
-- | Options for goal qualification (used in 'qualifyDeps')
......@@ -297,14 +295,14 @@ goalReasonToCS (DependencyGoal dr) = dependencyReasonToCS dr
-- | 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 pi@(PI qpn _) flags stanzas) =
dependencyReasonToCS (DependencyReason qpn flags stanzas) =
CS.fromList $ P qpn : flagVars ++ map stanzaToVar 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 pi fn) | (fn, fv) <- flags, fv /= FlagBoth]
flagVars = [F (FN qpn fn) | (fn, fv) <- flags, fv /= FlagBoth]
stanzaToVar :: Stanza -> Var QPN
stanzaToVar = S . SN pi
stanzaToVar = S . SN qpn
......@@ -24,13 +24,12 @@ import Prelude hiding (pi)
import qualified Distribution.PackageDescription as P -- from Cabal
import Distribution.Solver.Modular.Package
import Distribution.Solver.Types.Flag
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackagePath
-- | Flag name. Consists of a package instance and the flag identifier itself.
data FN qpn = FN (PI qpn) Flag
data FN qpn = FN qpn Flag
deriving (Eq, Ord, Show, Functor)
-- | Flag identifier. Just a string.
......@@ -58,7 +57,7 @@ type FlagInfo = Map Flag FInfo
type QFN = FN QPN
-- | Stanza name. Paired with a package name, much like a flag.
data SN qpn = SN (PI qpn) Stanza
data SN qpn = SN qpn Stanza
deriving (Eq, Ord, Show, Functor)
-- | Qualified stanza name.
......@@ -84,10 +83,10 @@ data FlagValue = FlagTrue | FlagFalse | FlagBoth
deriving (Eq, Show)
showQFNBool :: QFN -> Bool -> String
showQFNBool qfn@(FN pi _f) b = showPI pi ++ ":" ++ showFBool qfn b
showQFNBool qfn@(FN qpn _f) b = showQPN qpn ++ ":" ++ showFBool qfn b
showQSNBool :: QSN -> Bool -> String
showQSNBool (SN pi f) b = showPI pi ++ ":" ++ showSBool f b
showQSNBool (SN qpn s) b = showQPN qpn ++ ":" ++ showSBool s b
showFBool :: FN qpn -> Bool -> String
showFBool (FN _ f) v = P.showFlagValue (f, v)
......@@ -103,7 +102,7 @@ showSBool s True = "*" ++ showStanza s
showSBool s False = "!" ++ showStanza s
showQFN :: QFN -> String
showQFN (FN pi f) = showPI pi ++ ":" ++ unFlag f
showQFN (FN qpn f) = showQPN qpn ++ ":" ++ unFlag f
showQSN :: QSN -> String
showQSN (SN pi s) = showPI pi ++ ":" ++ showStanza s
showQSN (SN qpn s) = showQPN qpn ++ ":" ++ showStanza s
......@@ -7,7 +7,6 @@ import Data.Map as M
import Data.Maybe
import Data.Monoid as Mon
import Data.Set as S
import Prelude hiding (pi)
import Distribution.Compiler
import Distribution.InstalledPackageInfo as IPI
......@@ -84,7 +83,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 (PI pn i) [] []) comp idx) (IPI.depends ipi) of
case mapM (convIPId (DependencyReason pn [] []) comp idx) (IPI.depends ipi) of
Nothing -> (pn, i, PInfo [] M.empty (Just Broken))
Just fds -> (pn, i, PInfo fds M.empty Nothing)
where
......@@ -146,7 +145,7 @@ convSPI' os arch cinfo strfl solveExes = L.map (convSP os arch cinfo strfl solve
convSP :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo)
convSP os arch cinfo strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
let i = I pv InRepo
in (pn, i, convGPD os arch cinfo strfl solveExes (PI pn i) gpd)
in (pn, i, convGPD os arch cinfo strfl solveExes pn gpd)
-- We do not use 'flattenPackageDescription' or 'finalizePD'
-- from 'Distribution.PackageDescription.Configuration' here, because we
......@@ -154,8 +153,8 @@ convSP os arch cinfo strfl solveExes (SourcePackage (PackageIdentifier pn pv) gp
-- | Convert a generic package description to a solver-specific 'PInfo'.
convGPD :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables ->
PI PN -> GenericPackageDescription -> PInfo
convGPD os arch cinfo strfl solveExes pi
PN -> GenericPackageDescription -> PInfo
convGPD os arch cinfo strfl solveExes pn
(GenericPackageDescription pkg flags mlib sub_libs flibs exes tests benchs) =
let
fds = flagInfo strfl flags
......@@ -172,26 +171,26 @@ convGPD os arch cinfo strfl solveExes pi
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 pi fds comp getInfo ipns solveExes .
convCondTree dr pkg os arch cinfo pn fds comp getInfo ipns solveExes .
PDC.addBuildableCondition getInfo
initDR = DependencyReason pi [] []
initDR = DependencyReason pn [] []
flagged_deps
= concatMap (\ds -> conv ComponentLib libBuildInfo initDR ds) (maybeToList mlib)
++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm) libBuildInfo initDR ds) sub_libs
++ concatMap (\(nm, ds) -> conv (ComponentFLib nm) foreignLibBuildInfo initDR ds) flibs
++ concatMap (\(nm, ds) -> conv (ComponentExe nm) buildInfo initDR ds) exes
++ prefix (Stanza (SN pi TestStanzas))
++ prefix (Stanza (SN pn TestStanzas))
(L.map (\(nm, ds) -> conv (ComponentTest nm) testBuildInfo (addStanza TestStanzas initDR) ds)
tests)
++ prefix (Stanza (SN pi BenchStanzas))
++ prefix (Stanza (SN pn BenchStanzas))
(L.map (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo (addStanza BenchStanzas initDR) ds)
benchs)
++ maybe [] (convSetupBuildInfo pi) (setupBuildInfo pkg)
++ maybe [] (convSetupBuildInfo pn) (setupBuildInfo pkg)
addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn
addStanza s (DependencyReason pi' fs ss) = DependencyReason pi' fs (s : ss)
addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (s : ss)
in
PInfo flagged_deps fds Nothing
......@@ -226,19 +225,19 @@ filterIPNs ipns (Dependency pn _) fd
-- | 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 -> PI PN -> FlagInfo ->
convCondTree :: 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 pi fds comp getInfo ipns solveExes@(SolveExecutables solveExes') (CondNode info ds branches) =
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
++ 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 pi fds comp getInfo ipns solveExes) branches
++ concatMap (convBranch 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
......@@ -266,7 +265,7 @@ convCondTree dr pkg os arch cinfo pi fds comp getInfo ipns solveExes@(SolveExecu
-- 1. Some pre dependency-solving known information ('OS', 'Arch',
-- 'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables,
--
-- 2. The package instance @'PI' 'PN'@ which this condition tree
-- 2. The package name @'PN'@ which this condition tree
-- came from, so that we can correctly associate @flag()@
-- variables with the correct package name qualifier,
--
......@@ -284,17 +283,17 @@ convCondTree dr pkg os arch cinfo pi fds comp getInfo ipns solveExes@(SolveExecu
-- 6. The set of package names which should be considered internal
-- dependencies, and thus not handled as dependencies.
convBranch :: DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo ->
PI PN -> FlagInfo ->
PN -> FlagInfo ->
Component ->
(a -> BuildInfo) ->
IPNs ->
SolveExecutables ->
CondBranch ConfVar [Dependency] a ->
FlaggedDeps PN
convBranch dr pkg os arch cinfo pi fds comp getInfo ipns solveExes (CondBranch c' t' mf') =
convBranch dr pkg os arch cinfo pn fds comp getInfo ipns solveExes (CondBranch c' t' mf') =
go c'
(\dr' -> convCondTree dr' pkg os arch cinfo pi fds comp getInfo ipns solveExes t')
(\dr' -> maybe [] (convCondTree dr' pkg os arch cinfo pi fds comp getInfo ipns solveExes) mf')
(\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
where
go :: Condition ConfVar
......@@ -316,7 +315,7 @@ convBranch dr pkg os arch cinfo pi fds comp getInfo ipns solveExes (CondBranch c
let addFlagVal v = addFlag fn v dr'
in extractCommon (t (addFlagVal FlagBoth))
(f (addFlagVal FlagBoth))
++ [ Flagged (FN pi fn) (fds ! fn) (t (addFlagVal FlagTrue))
++ [ Flagged (FN pn fn) (fds ! fn) (t (addFlagVal FlagTrue))
(f (addFlagVal FlagFalse)) ]
go (Var (OS os')) t f
| os == os' = t
......@@ -336,8 +335,8 @@ convBranch dr pkg os arch cinfo pi fds comp getInfo ipns solveExes (CondBranch c
matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv
addFlag :: FlagName -> FlagValue -> DependencyReason pn -> DependencyReason pn
addFlag fn v (DependencyReason pi' flags stanzas) =
DependencyReason pi' ((fn, v) : flags) stanzas
addFlag fn v (DependencyReason pn' flags stanzas) =
DependencyReason pn' ((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
......@@ -363,8 +362,8 @@ convBranch dr pkg os arch cinfo pi fds comp getInfo ipns solveExes (CondBranch c
-- avoided by removing the dependency from either side of the
-- conditional.
mergeDRs :: DependencyReason pn -> DependencyReason pn -> DependencyReason pn
mergeDRs (DependencyReason pi' fs1 ss1) (DependencyReason _ fs2 ss2) =
DependencyReason pi' (nub $ fs1 ++ fs2) (nub $ ss1 ++ ss2)
mergeDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) =
DependencyReason pn' (nub $ fs1 ++ fs2) (nub $ ss1 ++ ss2)
-- | Convert a Cabal dependency on a library to a solver-specific dependency.
convLibDep :: DependencyReason PN -> Dependency -> LDep PN
......@@ -376,6 +375,6 @@ convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN
convExeDep dr (ExeDependency pn _ vr) = LDep dr $ Dep (IsExe True) pn (Constrained vr)
-- | Convert setup dependencies
convSetupBuildInfo :: PI PN -> SetupBuildInfo -> FlaggedDeps PN
convSetupBuildInfo pi nfo =
L.map (\d -> D.Simple (convLibDep (DependencyReason pi [] []) d) ComponentSetup) (PD.setupDepends nfo)
convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN
convSetupBuildInfo pn nfo =
L.map (\d -> D.Simple (convLibDep (DependencyReason pn [] []) d) ComponentSetup) (PD.setupDepends nfo)
......@@ -350,23 +350,23 @@ verifyLinkGroup lg =
flags = M.keys finfo
stanzas = [TestStanzas, BenchStanzas]
forM_ flags $ \fn -> do
let flag = FN (PI (lgPackage lg) i) fn
let flag = FN (lgPackage lg) fn
verifyFlag' flag lg
forM_ stanzas $ \sn -> do
let stanza = SN (PI (lgPackage lg) i) sn
let stanza = SN (lgPackage lg) sn
verifyStanza' stanza lg
verifyFlag :: QFN -> UpdateState ()
verifyFlag (FN (PI qpn@(Q _pp pn) i) fn) = do
verifyFlag (FN qpn@(Q _pp pn) fn) = do
vs <- get
-- We can only pick a flag after picking an instance; link group must exist
verifyFlag' (FN (PI pn i) fn) (vsLinks vs ! qpn)
verifyFlag' (FN pn fn) (vsLinks vs ! qpn)
verifyStanza :: QSN -> UpdateState ()
verifyStanza (SN (PI qpn@(Q _pp pn) i) sn) = do
verifyStanza (SN qpn@(Q _pp pn) sn) = do
vs <- get
-- We can only pick a stanza after picking an instance; link group must exist
verifyStanza' (SN (PI pn i) sn) (vsLinks vs ! qpn)
verifyStanza' (SN pn sn) (vsLinks vs ! qpn)
-- | Verify that all packages in the link group agree on flag assignments
--
......@@ -374,9 +374,9 @@ verifyStanza (SN (PI qpn@(Q _pp pn) i) sn) = do
-- that have already been made for link group members, and check that they are
-- equal.
verifyFlag' :: FN PN -> LinkGroup -> UpdateState ()
verifyFlag' (FN (PI pn i) fn) lg = do
verifyFlag' (FN pn fn) lg = do
vs <- get
let flags = map (\pp' -> FN (PI (Q pp' pn) i) fn) (S.toList (lgMembers lg))
let flags = map (\pp' -> FN (Q pp' pn) fn) (S.toList (lgMembers lg))
vals = map (`M.lookup` vsFlags vs) flags
if allEqual (catMaybes vals) -- We ignore not-yet assigned flags
then return ()
......@@ -392,9 +392,9 @@ verifyFlag' (FN (PI pn i) fn) lg = do
--
-- This function closely mirrors 'verifyFlag''.
verifyStanza' :: SN PN -> LinkGroup -> UpdateState ()
verifyStanza' (SN (PI pn i) sn) lg = do
verifyStanza' (SN pn sn) lg = do
vs <- get
let stanzas = map (\pp' -> SN (PI (Q pp' pn) i) sn) (S.toList (lgMembers lg))
let stanzas = map (\pp' -> SN (Q pp' pn) sn) (S.toList (lgMembers lg))
vals = map (`M.lookup` vsStanzas vs) stanzas
if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas
then return ()
......
......@@ -101,7 +101,7 @@ showMessages p sl = go [] 0
-> Progress Message a b
-> Progress String a b
goPReject v l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))
| qpn == qpn' && fr `compareFR` fr' = goPReject v l qpn (i : is) c fr ms
| qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms
goPReject v l qpn is c fr ms =
(atLevel (P qpn : v) l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go v l ms)
......@@ -113,31 +113,6 @@ showMessages p sl = go [] 0
| p v = Step x xs
| otherwise = xs
-- Compares 'FailReasons' for equality, with one exception. It ignores the
-- package instance (I) in the 'DependencyReason' of an 'LDep' in a
-- 'Conflicting' failure. It ignores the package instance so that the solver
-- can combine messages when consecutive choices for one package all lead to
-- the same conflict. Implementing #4142 would allow us to remove this
-- function and use "==".
compareFR :: FailReason -> FailReason -> Bool
compareFR (Conflicting ds1) (Conflicting ds2) =
compareListsOn compareDeps ds1 ds2
where
compareDeps :: LDep QPN -> LDep QPN -> Bool
compareDeps (LDep dr1 d1) (LDep dr2 d2) =
compareDRs dr1 dr2 && d1 == d2
compareDRs :: DependencyReason QPN -> DependencyReason QPN -> Bool
compareDRs (DependencyReason (PI qpn1 _) fs1 ss1) (DependencyReason (PI qpn2 _) fs2 ss2) =
qpn1 == qpn2 && fs1 == fs2 && ss1 == ss2
compareListsOn :: (a -> a -> Bool) -> [a] -> [a] -> Bool
compareListsOn _ [] [] = True
compareListsOn _ [] _ = False
compareListsOn _ _ [] = False
compareListsOn f (x : xs) (y : ys) = f x y && compareListsOn f xs ys
compareFR fr1 fr2 = fr1 == fr2
showQPNPOpt :: QPN -> POption -> String
showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) =
case linkedTo of
......@@ -146,13 +121,11 @@ showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) =
showGR :: QGoalReason -> String
showGR UserGoal = " (user goal)"
showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason showPI dr ++ ")"
showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")"
showFR :: ConflictSet -> FailReason -> String
showFR _ InconsistentInitialConstraints = " (inconsistent initial constraints)"
showFR _ (Conflicting ds) =
let showDep' = showDep $ \(PI qpn _) -> showQPN qpn
in " (conflict: " ++ L.intercalate ", " (L.map showDep' ds) ++ ")"
showFR _ (Conflicting ds) = " (conflict: " ++ L.intercalate ", " (L.map showDep ds) ++ ")"
showFR _ CannotInstall = " (only already installed instances can be used)"
showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)"
showFR _ Shadowed = " (shadowed by another installed package with same version)"
......
......@@ -128,7 +128,7 @@ preferPackagePreferences pcs =
preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c
preferPackageStanzaPreferences pcs = trav go
where
go (SChoiceF qsn@(SN (PI (Q pp pn) _) s) rdm gr _tr ts)
go (SChoiceF qsn@(SN (Q pp pn) s) rdm gr _tr ts)
| primaryPP pp && enableStanzaPref pn s =
-- move True case first to try enabling the stanza
let ts' = W.mapWeightsWithKey (\k w -> weight k : w) ts
......@@ -230,14 +230,14 @@ enforcePackageConstraints pcs = trav go
id
(M.findWithDefault [] pn pcs)
in PChoiceF qpn rdm gr (W.mapWithKey g ts)
go (FChoiceF qfn@(FN (PI qpn@(Q _ pn) _) f) rdm gr tr m d ts) =
go (FChoiceF qfn@(FN qpn@(Q _ pn) f) rdm gr tr m d ts) =
let c = varToConflictSet (F qfn)
-- compose the transformation functions for each of the relevant constraint
g = \ b -> foldl (\ h pc -> h . processPackageConstraintF qpn f c b pc)
id
(M.findWithDefault [] pn pcs)
in FChoiceF qfn rdm gr tr m d (W.mapWithKey g ts)
go (SChoiceF qsn@(SN (PI qpn@(Q _ pn) _) f) rdm gr tr ts) =
go (SChoiceF qsn@(SN qpn@(Q _ pn) f) rdm gr tr ts) =
let c = varToConflictSet (S qsn)
-- compose the transformation functions for each of the relevant constraint
g = \ b -> foldl (\ h pc -> h . processPackageConstraintS qpn f c b pc)
......@@ -269,7 +269,7 @@ enforcePackageConstraints pcs = trav go
enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> Tree d c -> Tree d c
enforceManualFlags pcs = trav go
where
go (FChoiceF qfn@(FN (PI (Q _ pn) _) fn) rdm gr tr Manual d ts) =
go (FChoiceF qfn@(FN (Q _ pn) fn) rdm gr tr Manual d ts) =
FChoiceF qfn rdm gr tr Manual d $
let -- A list of all values specified by constraints on 'fn'.
-- We ignore the constraint scope in order to handle issue #4299.
......@@ -346,8 +346,8 @@ sortGoals variableOrder = trav go