Commit 989676ef authored by Mikhail Glushenkov's avatar Mikhail Glushenkov Committed by GitHub
Browse files

Merge pull request #4791 from grayjay/remove-PI-from-Var

Remove the package instance from D.Solver.Modular.Var (closes #4142).
parents 6f1a5873 e1ca9dcf
......@@ -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
......
......@@ -3,8 +3,8 @@
module Distribution.Solver.Modular.Dependency (
-- * Variables
Var(..)
, varPI
, showVar
, varPN
-- * Conflict sets
, ConflictSet
, ConflictMap
......@@ -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)
......@@ -59,6 +59,12 @@ data ValidateState = VS {
, vsFlags :: FAssignment
, vsStanzas :: SAssignment
, vsQualifyOptions :: QualifyOptions
-- Saved qualified dependencies. Every time 'validateLinking' makes a
-- package choice, it qualifies the package's dependencies and saves them in
-- this map. Then the qualified dependencies are available for subsequent
-- flag and stanza choices for the same package.
, vsSaved :: Map QPN (FlaggedDeps QPN)
}
type Validate = Reader ValidateState
......@@ -93,9 +99,10 @@ validateLinking index = (`runReader` initVS) . cata go
vs <- ask
let PInfo deps _ _ = vsIndex vs ! pn ! i
qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps
newSaved = M.insert qpn qdeps (vsSaved vs)
case execUpdateState (pickPOption qpn opt qdeps) vs of
Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
Right vs' -> local (const vs') r
Right vs' -> local (const vs' { vsSaved = newSaved }) r
-- Flag choices
goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
......@@ -120,6 +127,7 @@ validateLinking index = (`runReader` initVS) . cata go
, vsFlags = M.empty
, vsStanzas = M.empty
, vsQualifyOptions = defaultQualifyOptions index
, vsSaved = M.empty
}
{-------------------------------------------------------------------------------
......@@ -289,9 +297,8 @@ pickStanza qsn b = do
linkNewDeps :: Var QPN -> Bool -> UpdateState ()
linkNewDeps var b = do
vs <- get
let (qpn@(Q pp pn), Just i) = varPI var
PInfo deps _ _ = vsIndex vs ! pn ! i
qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps
let qpn@(Q pp pn) = varPN var
qdeps = vsSaved vs ! qpn
lg = vsLinks vs ! qpn
newDeps = findNewDeps vs qdeps
linkedTo = S.delete pp (lgMembers lg)
......@@ -343,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
--
......@@ -367,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 ()
......@@ -385,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 ++ ")"