From 6b77ea23129f8c91d3f1a3dd5d7103b2bbe811b9 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Sat, 28 Mar 2015 09:50:04 +0000
Subject: [PATCH] Fine-grained dependencies in solver output
In this commit we modify the _output_ of the modular solver (CP, the modular's
solver internal version of ConfiguredPackage) to have fine-grained dependency.
This doesn't yet modify the rest of cabal-install, so once we translate from CP
to ConfiguredPackage we still lose the distinctions between different kinds of
dependencies; this will be the topic of the next commit.
In the modular solver (and elsewhere) we use Data.Graph to represent the
dependency graph (and the reverse dependency graph). However, now that we have
more fine-grained dependencies, we really want an _edge-labeled_ graph, which
unfortunately it not available in the `containers` package. Therefore I've
written a very simple wrapper around Data.Graph that supports edge labels; we
don't need many fancy graph algorithms, and can still use Data.Graph on these
edged graphs when we want (by calling them on the underlying unlabeled graph),
so adding a dependency on `fgl` does not seem worth it.
---
.../Client/Dependency/Modular/Assignment.hs | 25 ++--
.../Client/Dependency/Modular/Builder.hs | 13 +-
.../Client/Dependency/Modular/Configured.hs | 3 +-
.../Modular/ConfiguredConversion.hs | 4 +-
.../Client/Dependency/Modular/Dependency.hs | 2 +-
.../Dependency/Modular/IndexConversion.hs | 11 +-
.../Client/Dependency/Modular/Package.hs | 2 +
.../Distribution/Client/Utils/LabeledGraph.hs | 114 ++++++++++++++++++
cabal-install/cabal-install.cabal | 1 +
9 files changed, 153 insertions(+), 22 deletions(-)
create mode 100644 cabal-install/Distribution/Client/Utils/LabeledGraph.hs
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs b/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs
index 91db3c1279..e5a5080a37 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs
@@ -6,11 +6,13 @@ import Data.Array as A
import Data.List as L
import Data.Map as M
import Data.Maybe
-import Data.Graph
import Prelude hiding (pi)
import Distribution.PackageDescription (FlagAssignment) -- from Cabal
import Distribution.Client.Types (OptionalStanza)
+import Distribution.Client.Utils.LabeledGraph
+import Distribution.Client.ComponentDeps (ComponentDeps, Component)
+import qualified Distribution.Client.ComponentDeps as CD
import Distribution.Client.Dependency.Modular.Configured
import Distribution.Client.Dependency.Modular.Dependency
@@ -77,13 +79,13 @@ toCPs :: Assignment -> RevDepMap -> [CP QPN]
toCPs (A pa fa sa) rdm =
let
-- get hold of the graph
- g :: Graph
- vm :: Vertex -> ((), QPN, [QPN])
+ g :: Graph Component
+ vm :: Vertex -> ((), QPN, [(Component, QPN)])
cvm :: QPN -> Maybe Vertex
-- Note that the RevDepMap contains duplicate dependencies. Therefore the nub.
(g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs))
(M.toList rdm))
- tg :: Graph
+ tg :: Graph Component
tg = transposeG g
-- Topsort the dependency graph, yielding a list of pkgs in the right order.
-- The graph will still contain all the installed packages, and it might
@@ -106,17 +108,20 @@ toCPs (A pa fa sa) rdm =
M.toList $
sa
-- Dependencies per package.
- depp :: QPN -> [PI QPN]
+ depp :: QPN -> [(Component, PI QPN)]
depp qpn = let v :: Vertex
v = fromJust (cvm qpn)
- dvs :: [Vertex]
+ dvs :: [(Component, Vertex)]
dvs = tg A.! v
- in L.map (\ dv -> case vm dv of (_, x, _) -> PI x (pa M.! x)) dvs
+ in L.map (\ (comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs
+ -- Translated to PackageDeps
+ depp' :: QPN -> ComponentDeps [PI QPN]
+ depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp
in
L.map (\ pi@(PI qpn _) -> CP pi
(M.findWithDefault [] qpn fapp)
(M.findWithDefault [] qpn sapp)
- (depp qpn))
+ (depp' qpn))
ps
-- | Finalize an assignment and a reverse dependency map.
@@ -126,8 +131,8 @@ finalize :: Index -> Assignment -> RevDepMap -> IO ()
finalize idx (A pa fa _) rdm =
let
-- get hold of the graph
- g :: Graph
- vm :: Vertex -> ((), QPN, [QPN])
+ g :: Graph Component
+ vm :: Vertex -> ((), QPN, [(Component, QPN)])
(g, vm) = graphFromEdges' (L.map (\ (x, xs) -> ((), x, xs)) (M.toList rdm))
-- topsort the dependency graph, yielding a list of pkgs in the right order
f :: [PI QPN]
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
index 3c6e4b082e..84cc3d4a0b 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
module Distribution.Client.Dependency.Modular.Builder (buildTree) where
-- Building the search tree.
@@ -51,11 +52,11 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
-- This is important, because in general, if a goal is inserted twice,
-- the later addition will have better dependency information.
go g o (ng@(OpenGoal (Stanza _ _ ) _gr) : ngs) = go g (cons' ng () o) ngs
- go g o (ng@(OpenGoal (Simple (Dep qpn _) _) _gr) : ngs)
- | qpn == qpn' = go g o ngs
+ go g o (ng@(OpenGoal (Simple (Dep qpn _) c) _gr) : ngs)
+ | qpn == qpn' = go g o ngs
-- we ignore self-dependencies at this point; TODO: more care may be needed
- | qpn `M.member` g = go (M.adjust (qpn':) qpn g) o ngs
- | otherwise = go (M.insert qpn [qpn'] g) (cons' ng () o) ngs
+ | qpn `M.member` g = go (M.adjust ((c, qpn'):) qpn g) o ngs
+ | otherwise = go (M.insert qpn [(c, qpn')] g) (cons' ng () o) ngs
-- code above is correct; insert/adjust have different arg order
cons' = cons . forgetCompOpenGoal
@@ -67,7 +68,7 @@ scopedExtendOpen :: QPN -> I -> QGoalReasonChain -> FlaggedDeps Component PN ->
scopedExtendOpen qpn@(Q pp _pn) i gr fdeps fdefs s = extendOpen qpn gs s
where
-- Qualify all package names
- qfdeps = L.map (fmap (Q pp)) fdeps -- qualify all the package names
+ qfdeps = L.map (fmap (Q pp)) fdeps
-- 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
@@ -136,7 +137,7 @@ build = ana go
go bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
SChoiceF qsn gr trivial (P.fromList
- [(False, bs { next = Goals }),
+ [(False, bs { next = Goals }),
(True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })])
where
trivial = L.null t
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs b/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs
index d6f2bc28db..0d7f230154 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs
@@ -2,9 +2,10 @@ module Distribution.Client.Dependency.Modular.Configured where
import Distribution.PackageDescription (FlagAssignment) -- from Cabal
import Distribution.Client.Types (OptionalStanza)
+import Distribution.Client.ComponentDeps (ComponentDeps)
import Distribution.Client.Dependency.Modular.Package
-- | A configured package is a package instance together with
-- a flag assignment and complete dependencies.
-data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] [PI qpn]
+data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] (ComponentDeps [PI qpn])
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
index 405c69bcdc..6121db82d6 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
@@ -13,6 +13,8 @@ import Distribution.System
import Distribution.Client.Dependency.Modular.Configured
import Distribution.Client.Dependency.Modular.Package
+import qualified Distribution.Client.ComponentDeps as CD
+
mkPlan :: Platform -> CompilerInfo -> Bool ->
SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage ->
[CP QPN] -> Either [PlanProblem] InstallPlan
@@ -33,7 +35,7 @@ convCP iidx sidx (CP qpi fa es ds) =
ds'
where
ds' :: [ConfiguredId]
- ds' = map convConfId ds
+ ds' = CD.flatDeps $ fmap (map convConfId) ds
convPI :: PI QPN -> Either InstalledPackageId PackageId
convPI (PI _ (I _ (Inst pi))) = Left pi
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
index 95d59f5ed0..6f39d85e5c 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
@@ -219,7 +219,7 @@ mapCompFlaggedDep g (Simple pn a ) = Simple pn (g a)
-- | A map containing reverse dependencies between qualified
-- package names.
-type RevDepMap = Map QPN [QPN]
+type RevDepMap = Map QPN [(Component, QPN)]
{-------------------------------------------------------------------------------
Goals
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
index 681a6d3014..47d4538c0a 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
@@ -1,4 +1,10 @@
-module Distribution.Client.Dependency.Modular.IndexConversion where
+module Distribution.Client.Dependency.Modular.IndexConversion (
+ convPIs
+ -- * TODO: The following don't actually seem to be used anywhere?
+ , convIPI
+ , convSPI
+ , convPI
+ ) where
import Data.List as L
import Data.Map as M
@@ -7,6 +13,7 @@ import Prelude hiding (pi)
import qualified Distribution.Client.PackageIndex as CI
import Distribution.Client.Types
+import Distribution.Client.ComponentDeps (Component(..))
import Distribution.Compiler
import Distribution.InstalledPackageInfo as IPI
import Distribution.Package -- from Cabal
@@ -21,8 +28,6 @@ import Distribution.Client.Dependency.Modular.Package
import Distribution.Client.Dependency.Modular.Tree
import Distribution.Client.Dependency.Modular.Version
-import Distribution.Client.ComponentDeps (Component(..))
-
-- | Convert both the installed package index and the source package
-- index into one uniform solver index.
--
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Package.hs b/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
index 4cd9fe8bf0..22ba01e7e8 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
@@ -67,6 +67,8 @@ instI (I _ (Inst _)) = True
instI _ = False
-- | Package path.
+--
+-- Stored in reverse order
data PP = Independent Int PP | Setup PN PP | None
deriving (Eq, Ord, Show)
diff --git a/cabal-install/Distribution/Client/Utils/LabeledGraph.hs b/cabal-install/Distribution/Client/Utils/LabeledGraph.hs
new file mode 100644
index 0000000000..567f15609a
--- /dev/null
+++ b/cabal-install/Distribution/Client/Utils/LabeledGraph.hs
@@ -0,0 +1,114 @@
+-- | Wrapper around Data.Graph with support for edge labels
+{-# LANGUAGE ScopedTypeVariables #-}
+module Distribution.Client.Utils.LabeledGraph (
+ -- * Graphs
+ Graph
+ , Vertex
+ -- ** Building graphs
+ , graphFromEdges
+ , graphFromEdges'
+ , buildG
+ , transposeG
+ -- ** Graph properties
+ , vertices
+ , edges
+ -- ** Operations on the underlying unlabeled graph
+ , forgetLabels
+ , topSort
+ ) where
+
+import Data.Array
+import Data.Graph (Vertex, Bounds)
+import Data.List (sortBy)
+import Data.Maybe (mapMaybe)
+import qualified Data.Graph as G
+
+{-------------------------------------------------------------------------------
+ Types
+-------------------------------------------------------------------------------}
+
+type Graph e = Array Vertex [(e, Vertex)]
+type Edge e = (Vertex, e, Vertex)
+
+{-------------------------------------------------------------------------------
+ Building graphs
+-------------------------------------------------------------------------------}
+
+-- | Construct an edge-labeled graph
+--
+-- This is a simple adaptation of the definition in Data.Graph
+graphFromEdges :: forall key node edge. Ord key
+ => [ (node, key, [(edge, key)]) ]
+ -> ( Graph edge
+ , Vertex -> (node, key, [(edge, key)])
+ , key -> Maybe Vertex
+ )
+graphFromEdges edges0 =
+ (graph, \v -> vertex_map ! v, key_vertex)
+ where
+ max_v = length edges0 - 1
+ bounds0 = (0, max_v) :: (Vertex, Vertex)
+ sorted_edges = sortBy lt edges0
+ edges1 = zipWith (,) [0..] sorted_edges
+
+ graph = array bounds0 [(v, (mapMaybe mk_edge ks)) | (v, (_, _, ks)) <- edges1]
+ key_map = array bounds0 [(v, k ) | (v, (_, k, _ )) <- edges1]
+ vertex_map = array bounds0 edges1
+
+ (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2
+
+ mk_edge :: (edge, key) -> Maybe (edge, Vertex)
+ mk_edge (edge, key) = do v <- key_vertex key ; return (edge, v)
+
+ -- returns Nothing for non-interesting vertices
+ key_vertex :: key -> Maybe Vertex
+ key_vertex k = findVertex 0 max_v
+ where
+ findVertex a b
+ | a > b = Nothing
+ | otherwise = case compare k (key_map ! mid) of
+ LT -> findVertex a (mid-1)
+ EQ -> Just mid
+ GT -> findVertex (mid+1) b
+ where
+ mid = a + (b - a) `div` 2
+
+graphFromEdges' :: Ord key
+ => [ (node, key, [(edge, key)]) ]
+ -> ( Graph edge
+ , Vertex -> (node, key, [(edge, key)])
+ )
+graphFromEdges' x = (a,b)
+ where
+ (a,b,_) = graphFromEdges x
+
+transposeG :: Graph e -> Graph e
+transposeG g = buildG (bounds g) (reverseE g)
+
+buildG :: Bounds -> [Edge e] -> Graph e
+buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0)
+ where
+ reassoc (v, e, w) = (v, (e, w))
+
+reverseE :: Graph e -> [Edge e]
+reverseE g = [ (w, e, v) | (v, e, w) <- edges g ]
+
+{-------------------------------------------------------------------------------
+ Graph properties
+-------------------------------------------------------------------------------}
+
+vertices :: Graph e -> [Vertex]
+vertices = indices
+
+edges :: Graph e -> [Edge e]
+edges g = [ (v, e, w) | v <- vertices g, (e, w) <- g!v ]
+
+{-------------------------------------------------------------------------------
+ Operations on the underlying unlabelled graph
+-------------------------------------------------------------------------------}
+
+forgetLabels :: Graph e -> G.Graph
+forgetLabels = fmap (map snd)
+
+topSort :: Graph e -> [Vertex]
+topSort = G.topSort . forgetLabels
diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
index 8e54000c37..b2c834dd93 100644
--- a/cabal-install/cabal-install.cabal
+++ b/cabal-install/cabal-install.cabal
@@ -116,6 +116,7 @@ executable cabal
Distribution.Client.Update
Distribution.Client.Upload
Distribution.Client.Utils
+ Distribution.Client.Utils.LabeledGraph
Distribution.Client.World
Distribution.Client.Win32SelfUpgrade
Distribution.Client.Compat.Environment
--
GitLab