Commit 6b77ea23 authored by Edsko de Vries's avatar Edsko de Vries
Browse files

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.
parent a5a823d4
......@@ -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]
......
{-# 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
......
......@@ -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])
......@@ -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
......
......@@ -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
......
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.
--
......
......@@ -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)
......
-- | 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
......@@ -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
......
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