From 4053927d4ddb9b6cf26bd68db9067b308258eb51 Mon Sep 17 00:00:00 2001
From: Duncan Coutts <duncan@community.haskell.org>
Date: Fri, 29 Aug 2014 14:50:51 +0100
Subject: [PATCH] Remove the solver's scope and encapsulation mechanism
It turns out not to be the right solution for general private
dependencies and is just complicated. However we keep qualified
goals, just much simpler. Now dependencies simply inherit the
qualification of their parent goal. This gets us closer to the
intended behaviour for the --independent-goals feature, and for
the simpler case of private dependencies for setup scripts.
When not using --independent-goals, the solver behaves exactly as
before (tested by comparing solver logs for a hard hackage goal).
When using --independent-goals, now every dep of each independent
goal is qualified, so the dependencies are solved completely
independently (which is actually too much still).
---
.../Client/Dependency/Modular/Builder.hs | 47 +++++++------------
.../Client/Dependency/Modular/Index.hs | 7 +--
.../Dependency/Modular/IndexConversion.hs | 9 ++--
.../Client/Dependency/Modular/Package.hs | 16 ++-----
.../Client/Dependency/Modular/Preference.hs | 16 +++----
.../Client/Dependency/Modular/Validate.hs | 22 ++++-----
6 files changed, 45 insertions(+), 72 deletions(-)
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
index 38fbf71858..50cb570548 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
@@ -1,4 +1,4 @@
-module Distribution.Client.Dependency.Modular.Builder where
+module Distribution.Client.Dependency.Modular.Builder (buildTree) where
-- Building the search tree.
--
@@ -30,7 +30,6 @@ import Distribution.Client.Dependency.Modular.Tree
-- | The state needed during the build phase of the search tree.
data BuildState = BS {
index :: Index, -- ^ information about packages and their dependencies
- scope :: Scope, -- ^ information about encapsulations
rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies
open :: PSQ OpenGoal (), -- ^ set of still open goals (flag and package goals)
next :: BuildType -- ^ kind of node to generate next
@@ -57,23 +56,14 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
| otherwise = go (M.insert qpn [qpn'] g) (cons ng () o) ngs
-- code above is correct; insert/adjust have different arg order
--- | Update the current scope by taking into account the encapsulations that
--- are defined for the current package.
-establishScope :: QPN -> Encaps -> BuildState -> BuildState
-establishScope (Q pp pn) ecs s =
- s { scope = L.foldl (\ m e -> M.insert e pp' m) (scope s) ecs }
- where
- pp' = pn : pp -- new path
-
-- | 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 -> QGoalReasonChain -> FlaggedDeps PN -> FlagInfo ->
BuildState -> BuildState
-scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s
+scopedExtendOpen qpn@(Q pp _pn) i gr fdeps fdefs s = extendOpen qpn gs s
where
- sc = scope s
-- Qualify all package names
- qfdeps = L.map (fmap (qualify sc)) fdeps -- qualify all the package names
+ qfdeps = L.map (fmap (Q pp)) fdeps -- qualify all the package names
-- Introduce all package flags
qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs
-- Combine new package and flag goals
@@ -101,10 +91,10 @@ data BuildType =
| Instance QPN I PInfo QGoalReasonChain -- ^ build a tree for a concrete instance
deriving Show
-build :: BuildState -> Tree (QGoalReasonChain, Scope)
+build :: BuildState -> Tree QGoalReasonChain
build = ana go
where
- go :: BuildState -> TreeF (QGoalReasonChain, Scope) BuildState
+ go :: BuildState -> TreeF QGoalReasonChain BuildState
-- If we have a choice between many goals, we just record the choice in
-- the tree. We select each open goal in turn, and before we descend, remove
@@ -119,10 +109,10 @@ build = ana go
--
-- For a package, we look up the instances available in the global info,
-- and then handle each instance in turn.
- go bs@(BS { index = idx, scope = sc, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _)) gr) }) =
+ go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _)) gr) }) =
case M.lookup pn idx of
Nothing -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn)
- Just pis -> PChoiceF qpn (gr, sc) (P.fromList (L.map (\ (i, info) ->
+ Just pis -> PChoiceF qpn gr (P.fromList (L.map (\ (i, info) ->
(i, bs { next = Instance qpn i info gr }))
(M.toList pis)))
-- TODO: data structure conversion is rather ugly here
@@ -131,8 +121,8 @@ build = ana go
-- that is indicated by the flag default.
--
-- TODO: Should we include the flag default in the tree?
- go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =
- FChoiceF qfn (gr, sc) (w || trivial) m (P.fromList (reorder b
+ go bs@(BS { next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =
+ FChoiceF qfn gr (w || trivial) m (P.fromList (reorder b
[(True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True : gr)) t) bs) { next = Goals }),
(False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })]))
where
@@ -140,8 +130,8 @@ build = ana go
reorder False = reverse
trivial = L.null t && L.null f
- go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
- SChoiceF qsn (gr, sc) trivial (P.fromList
+ go bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
+ SChoiceF qsn gr trivial (P.fromList
[(False, bs { next = Goals }),
(True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })])
where
@@ -151,20 +141,17 @@ build = ana go
-- and furthermore we update the set of goals.
--
-- TODO: We could inline this above.
- go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs ecs _) gr }) =
- go ((establishScope qpn ecs
- (scopedExtendOpen qpn i (PDependency (PI qpn i) : gr) fdeps fdefs bs))
+ go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) gr }) =
+ go ((scopedExtendOpen qpn i (PDependency (PI qpn i) : gr) fdeps fdefs bs)
{ next = Goals })
-- | Interface to the tree builder. Just takes an index and a list of package names,
-- and computes the initial state and then the tree from there.
-buildTree :: Index -> Bool -> [PN] -> Tree (QGoalReasonChain, Scope)
+buildTree :: Index -> Bool -> [PN] -> Tree QGoalReasonChain
buildTree idx ind igs =
- build (BS idx sc
- (M.fromList (L.map (\ qpn -> (qpn, [])) qpns))
+ build (BS idx (M.fromList (L.map (\ qpn -> (qpn, [])) qpns))
(P.fromList (L.map (\ qpn -> (OpenGoal (Simple (Dep qpn (Constrained []))) [UserGoal], ())) qpns))
Goals)
where
- sc | ind = makeIndependent igs
- | otherwise = emptyScope
- qpns = L.map (qualify sc) igs
+ qpns | ind = makeIndependent igs
+ | otherwise = L.map (Q []) igs
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Index.hs b/cabal-install/Distribution/Client/Dependency/Modular/Index.hs
index d01cdb61fa..ac3450379a 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Index.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Index.hs
@@ -15,17 +15,14 @@ import Distribution.Client.Dependency.Modular.Tree
type Index = Map PN (Map I PInfo)
-- | Info associated with a package instance.
--- Currently, dependencies, flags, encapsulations and failure reasons.
+-- Currently, dependencies, flags and failure reasons.
-- Packages that have a failure reason recorded for them are disabled
-- globally, for reasons external to the solver. We currently use this
-- for shadowing which essentially is a GHC limitation, and for
-- installed packages that are broken.
-data PInfo = PInfo (FlaggedDeps PN) FlagInfo Encaps (Maybe FailReason)
+data PInfo = PInfo (FlaggedDeps PN) FlagInfo (Maybe FailReason)
deriving (Show)
--- | Encapsulations. A list of package names.
-type Encaps = [PN]
-
mkIndex :: [(PN, I, PInfo)] -> Index
mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs))
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
index cd31868fdf..53b5a46a4d 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
@@ -49,8 +49,8 @@ convIPI' sip idx =
where
-- shadowing is recorded in the package info
- shadow (pn, i, PInfo fdeps fds encs _) | sip = (pn, i, PInfo fdeps fds encs (Just Shadowed))
- shadow x = x
+ shadow (pn, i, PInfo fdeps fds _) | sip = (pn, i, PInfo fdeps fds (Just Shadowed))
+ shadow x = x
convIPI :: Bool -> SI.InstalledPackageIndex -> Index
convIPI sip = mkIndex . convIPI' sip
@@ -62,8 +62,8 @@ convIP idx ipi =
i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)
pn = pkgName (sourcePackageId ipi)
in case mapM (convIPId pn idx) (IPI.depends ipi) of
- Nothing -> (pn, i, PInfo [] M.empty [] (Just Broken))
- Just fds -> (pn, i, PInfo fds M.empty [] Nothing)
+ Nothing -> (pn, i, PInfo [] M.empty (Just Broken))
+ Just fds -> (pn, i, PInfo fds M.empty Nothing)
-- TODO: Installed packages should also store their encapsulations!
-- | Convert dependencies specified by an installed package id into
@@ -119,7 +119,6 @@ convGPD os arch comp strfl pi
prefix (Stanza (SN pi BenchStanzas))
(L.map (convCondTree os arch comp pi fds (const True) . snd) benchs))
fds
- [] -- TODO: add encaps
Nothing
prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> [FlaggedDeps qpn] -> FlaggedDeps qpn
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Package.hs b/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
index 5f81c6868c..a654f01231 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
@@ -4,7 +4,6 @@ module Distribution.Client.Dependency.Modular.Package
module Distribution.Package) where
import Data.List as L
-import Data.Map as M
import Distribution.Package -- from Cabal
import Distribution.Text -- from Cabal
@@ -91,21 +90,12 @@ type QPN = Q PN
showQPN :: QPN -> String
showQPN = showQ display
--- | The scope associates every package with a path. The convention is that packages
--- not in the data structure have an empty path associated with them.
-type Scope = Map PN PP
-
--- | An empty scope structure, for initialization.
-emptyScope :: Scope
-emptyScope = M.empty
-
-- | Create artificial parents for each of the package names, making
-- them all independent.
-makeIndependent :: [PN] -> Scope
-makeIndependent ps = L.foldl (\ sc (n, p) -> M.insert p [PackageName (show n)] sc) emptyScope (zip ([0..] :: [Int]) ps)
+makeIndependent :: [PN] -> [QPN]
+makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..]
+ , let pp = [PackageName (show i)] ]
-qualify :: Scope -> PN -> QPN
-qualify sc pn = Q (findWithDefault [] pn sc) pn
unQualify :: Q a -> a
unQualify (Q _ x) = x
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
index 005eeb1ecc..64b10ae9b7 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -166,12 +166,12 @@ preferLatest :: Tree a -> Tree a
preferLatest = preferLatestFor (const True)
-- | Require installed packages.
-requireInstalled :: (PN -> Bool) -> Tree (QGoalReasonChain, a) -> Tree (QGoalReasonChain, a)
+requireInstalled :: (PN -> Bool) -> Tree QGoalReasonChain -> Tree QGoalReasonChain
requireInstalled p = trav go
where
- go (PChoiceF v@(Q _ pn) i@(gr, _) cs)
- | p pn = PChoiceF v i (P.mapWithKey installed cs)
- | otherwise = PChoiceF v i cs
+ go (PChoiceF v@(Q _ pn) gr cs)
+ | p pn = PChoiceF v gr (P.mapWithKey installed cs)
+ | otherwise = PChoiceF v gr cs
where
installed (I _ (Inst _)) x = x
installed _ _ = Fail (toConflictSet (Goal (P v) gr)) CannotInstall
@@ -190,12 +190,12 @@ requireInstalled p = trav go
-- they are, perhaps this should just result in trying to reinstall those other
-- packages as well. However, doing this all neatly in one pass would require to
-- change the builder, or at least to change the goal set after building.
-avoidReinstalls :: (PN -> Bool) -> Tree (QGoalReasonChain, a) -> Tree (QGoalReasonChain, a)
+avoidReinstalls :: (PN -> Bool) -> Tree QGoalReasonChain -> Tree QGoalReasonChain
avoidReinstalls p = trav go
where
- go (PChoiceF qpn@(Q _ pn) i@(gr, _) cs)
- | p pn = PChoiceF qpn i disableReinstalls
- | otherwise = PChoiceF qpn i cs
+ go (PChoiceF qpn@(Q _ pn) gr cs)
+ | p pn = PChoiceF qpn gr disableReinstalls
+ | otherwise = PChoiceF qpn gr cs
where
disableReinstalls =
let installed = [ v | (I v (Inst _), _) <- toList cs ]
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
index 16c8cf5537..8b8d380e38 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
@@ -1,4 +1,4 @@
-module Distribution.Client.Dependency.Modular.Validate where
+module Distribution.Client.Dependency.Modular.Validate (validateTree) where
-- Validation of the tree.
--
@@ -80,13 +80,13 @@ data ValidateState = VS {
type Validate = Reader ValidateState
-validate :: Tree (QGoalReasonChain, Scope) -> Validate (Tree QGoalReasonChain)
+validate :: Tree QGoalReasonChain -> Validate (Tree QGoalReasonChain)
validate = cata go
where
- go :: TreeF (QGoalReasonChain, Scope) (Validate (Tree QGoalReasonChain)) -> Validate (Tree QGoalReasonChain)
+ go :: TreeF QGoalReasonChain (Validate (Tree QGoalReasonChain)) -> Validate (Tree QGoalReasonChain)
- go (PChoiceF qpn (gr, sc) ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts)
- go (FChoiceF qfn (gr, _sc) b m ts) =
+ go (PChoiceF qpn gr ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr) ts)
+ go (FChoiceF qfn gr b m ts) =
do
-- Flag choices may occur repeatedly (because they can introduce new constraints
-- in various places). However, subsequent choices must be consistent. We thereby
@@ -99,7 +99,7 @@ validate = cata go
Nothing -> return $ Fail (toConflictSet (Goal (F qfn) gr)) (MalformedFlagChoice qfn)
Nothing -> -- flag choice is new, follow both branches
FChoice qfn gr b m <$> sequence (P.mapWithKey (goF qfn gr) ts)
- go (SChoiceF qsn (gr, _sc) b ts) =
+ go (SChoiceF qsn gr b ts) =
do
-- Optional stanza choices are very similar to flag choices.
PA _ _ psa <- asks pa -- obtain current stanza-preassignment
@@ -117,13 +117,13 @@ validate = cata go
go (FailF c fr ) = pure (Fail c fr)
-- What to do for package nodes ...
- goP :: QPN -> QGoalReasonChain -> Scope -> I -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
- goP qpn@(Q _pp pn) gr sc i r = do
+ goP :: QPN -> QGoalReasonChain -> I -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
+ goP qpn@(Q pp pn) gr i r = do
PA ppa pfa psa <- asks pa -- obtain current preassignment
idx <- asks index -- obtain the index
svd <- asks saved -- obtain saved dependencies
- let (PInfo deps _ _ mfr) = idx ! pn ! i -- obtain dependencies and index-dictated exclusions introduced by the choice
- let qdeps = L.map (fmap (qualify sc)) deps -- qualify the deps in the current scope
+ let (PInfo deps _ mfr) = idx ! pn ! i -- obtain dependencies and index-dictated exclusions introduced by the choice
+ let qdeps = L.map (fmap (Q pp)) deps -- qualify the deps in the current scope
-- the new active constraints are given by the instance we have chosen,
-- plus the dependency information we have for that instance
let goal = Goal (P qpn) gr
@@ -228,5 +228,5 @@ extractNewDeps v gr b fa sa = go
Just False -> []
-- | Interface.
-validateTree :: Index -> Tree (QGoalReasonChain, Scope) -> Tree QGoalReasonChain
+validateTree :: Index -> Tree QGoalReasonChain -> Tree QGoalReasonChain
validateTree idx t = runReader (validate t) (VS idx M.empty (PA M.empty M.empty M.empty))
--
GitLab