cabal-install-1.24.0.0: Distribution/Client/PlanIndex.hs
-- | These graph traversal functions mirror the ones in Cabal, but work with
-- the more complete (and fine-grained) set of dependencies provided by
-- PackageFixedDeps rather than only the library dependencies provided by
-- PackageInstalled.
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
module Distribution.Client.PlanIndex (
-- * FakeMap and related operations
FakeMap
, fakeDepends
, fakeLookupUnitId
-- * Graph traversal functions
, brokenPackages
, dependencyCycles
, dependencyGraph
, dependencyInconsistencies
) where
import Prelude hiding (lookup)
import qualified Data.Map as Map
import qualified Data.Graph as Graph
import Data.Array ((!))
import Data.Map (Map)
import Data.Maybe (isNothing)
import Data.Either (rights)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid(..))
#endif
import Distribution.Package
( PackageName(..), PackageIdentifier(..), UnitId(..)
, Package(..), packageName, packageVersion
)
import Distribution.Version
( Version )
import Distribution.Client.ComponentDeps (ComponentDeps)
import qualified Distribution.Client.ComponentDeps as CD
import Distribution.Client.Types
( PackageFixedDeps(..) )
import Distribution.Simple.PackageIndex
( PackageIndex, allPackages, insert, lookupUnitId )
import Distribution.Package
( HasUnitId(..), PackageId )
-- Note [FakeMap]
-----------------
-- We'd like to use the PackageIndex defined in this module for cabal-install's
-- InstallPlan. However, at the moment, this data structure is indexed by
-- UnitId, which we don't know until after we've compiled a package
-- (whereas InstallPlan needs to store not-compiled packages in the index.)
-- Eventually, an UnitId will be calculatable prior to actually building
-- the package, but at the moment, the "fake installed package ID map" is a
-- workaround to solve this problem while reusing PackageIndex. The basic idea
-- is that, since we don't know what an UnitId is beforehand, we just fake
-- up one based on the package ID (it only needs to be unique for the particular
-- install plan), and fill it out with the actual generated UnitId after
-- the package is successfully compiled.
--
-- However, there is a problem: in the index there may be references using the
-- old package ID, which are now dangling if we update the UnitId. We
-- could map over the entire index to update these pointers as well (a costly
-- operation), but instead, we've chosen to parametrize a variety of important
-- functions by a FakeMap, which records what a fake installed package ID was
-- actually resolved to post-compilation. If we do a lookup, we first check and
-- see if it's a fake ID in the FakeMap.
--
-- It's a bit grungy, but we expect this to only be temporary anyway. (Another
-- possible workaround would have been to *not* update the installed package ID,
-- but I decided this would be hard to understand.)
-- | Map from fake package keys to real ones. See Note [FakeMap]
type FakeMap = Map UnitId UnitId
-- | Variant of `depends` which accepts a `FakeMap`
--
-- Analogous to `fakeInstalledDepends`. See Note [FakeMap].
fakeDepends :: PackageFixedDeps pkg => FakeMap -> pkg -> ComponentDeps [UnitId]
fakeDepends fakeMap = fmap (map resolveFakeId) . depends
where
resolveFakeId :: UnitId -> UnitId
resolveFakeId ipid = Map.findWithDefault ipid ipid fakeMap
--- | Variant of 'lookupUnitId' which accepts a 'FakeMap'. See Note
--- [FakeMap].
fakeLookupUnitId :: FakeMap -> PackageIndex a -> UnitId
-> Maybe a
fakeLookupUnitId fakeMap index pkg =
lookupUnitId index (Map.findWithDefault pkg pkg fakeMap)
-- | All packages that have dependencies that are not in the index.
--
-- Returns such packages along with the dependencies that they're missing.
--
brokenPackages :: (PackageFixedDeps pkg)
=> FakeMap
-> PackageIndex pkg
-> [(pkg, [UnitId])]
brokenPackages fakeMap index =
[ (pkg, missing)
| pkg <- allPackages index
, let missing =
[ pkg' | pkg' <- CD.flatDeps (depends pkg)
, isNothing (fakeLookupUnitId fakeMap index pkg') ]
, not (null missing) ]
-- | Compute all roots of the install plan, and verify that the transitive
-- plans from those roots are all consistent.
--
-- NOTE: This does not check for dependency cycles. Moreover, dependency cycles
-- may be absent from the subplans even if the larger plan contains a dependency
-- cycle. Such cycles may or may not be an issue; either way, we don't check
-- for them here.
dependencyInconsistencies :: forall pkg. (PackageFixedDeps pkg, HasUnitId pkg)
=> FakeMap
-> Bool
-> PackageIndex pkg
-> [(PackageName, [(PackageIdentifier, Version)])]
dependencyInconsistencies fakeMap indepGoals index =
concatMap (dependencyInconsistencies' fakeMap) subplans
where
subplans :: [PackageIndex pkg]
subplans = rights $
map (dependencyClosure fakeMap index)
(rootSets fakeMap indepGoals index)
-- | Compute the root sets of a plan
--
-- A root set is a set of packages whose dependency closure must be consistent.
-- This is the set of all top-level library roots (taken together normally, or
-- as singletons sets if we are considering them as independent goals), along
-- with all setup dependencies of all packages.
rootSets :: (PackageFixedDeps pkg, HasUnitId pkg)
=> FakeMap -> Bool -> PackageIndex pkg -> [[UnitId]]
rootSets fakeMap indepGoals index =
if indepGoals then map (:[]) libRoots else [libRoots]
++ setupRoots index
where
libRoots = libraryRoots fakeMap index
-- | Compute the library roots of a plan
--
-- The library roots are the set of packages with no reverse dependencies
-- (no reverse library dependencies but also no reverse setup dependencies).
libraryRoots :: (PackageFixedDeps pkg, HasUnitId pkg)
=> FakeMap -> PackageIndex pkg -> [UnitId]
libraryRoots fakeMap index =
map toPkgId roots
where
(graph, toPkgId, _) = dependencyGraph fakeMap index
indegree = Graph.indegree graph
roots = filter isRoot (Graph.vertices graph)
isRoot v = indegree ! v == 0
-- | The setup dependencies of each package in the plan
setupRoots :: PackageFixedDeps pkg => PackageIndex pkg -> [[UnitId]]
setupRoots = filter (not . null)
. map (CD.setupDeps . depends)
. allPackages
-- | Given a package index where we assume we want to use all the packages
-- (use 'dependencyClosure' if you need to get such a index subset) find out
-- if the dependencies within it use consistent versions of each package.
-- Return all cases where multiple packages depend on different versions of
-- some other package.
--
-- Each element in the result is a package name along with the packages that
-- depend on it and the versions they require. These are guaranteed to be
-- distinct.
--
dependencyInconsistencies' :: forall pkg.
(PackageFixedDeps pkg, HasUnitId pkg)
=> FakeMap
-> PackageIndex pkg
-> [(PackageName, [(PackageIdentifier, Version)])]
dependencyInconsistencies' fakeMap index =
[ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids])
| (name, ipid_map) <- Map.toList inverseIndex
, let uses = Map.elems ipid_map
, reallyIsInconsistent (map fst uses)
]
where
-- For each package name (of a dependency, somewhere)
-- and each installed ID of that that package
-- the associated package instance
-- and a list of reverse dependencies (as source IDs)
inverseIndex :: Map PackageName (Map UnitId (pkg, [PackageId]))
inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b')))
[ (packageName dep, Map.fromList [(ipid,(dep,[packageId pkg]))])
| -- For each package @pkg@
pkg <- allPackages index
-- Find out which @ipid@ @pkg@ depends on
, ipid <- CD.nonSetupDeps (fakeDepends fakeMap pkg)
-- And look up those @ipid@ (i.e., @ipid@ is the ID of @dep@)
, Just dep <- [fakeLookupUnitId fakeMap index ipid]
]
-- If, in a single install plan, we depend on more than one version of a
-- package, then this is ONLY okay in the (rather special) case that we
-- depend on precisely two versions of that package, and one of them
-- depends on the other. This is necessary for example for the base where
-- we have base-3 depending on base-4.
reallyIsInconsistent :: [pkg] -> Bool
reallyIsInconsistent [] = False
reallyIsInconsistent [_p] = False
reallyIsInconsistent [p1, p2] =
let pid1 = installedUnitId p1
pid2 = installedUnitId p2
in Map.findWithDefault pid1 pid1 fakeMap `notElem` CD.nonSetupDeps (fakeDepends fakeMap p2)
&& Map.findWithDefault pid2 pid2 fakeMap `notElem` CD.nonSetupDeps (fakeDepends fakeMap p1)
reallyIsInconsistent _ = True
-- | Find if there are any cycles in the dependency graph. If there are no
-- cycles the result is @[]@.
--
-- This actually computes the strongly connected components. So it gives us a
-- list of groups of packages where within each group they all depend on each
-- other, directly or indirectly.
--
dependencyCycles :: (PackageFixedDeps pkg, HasUnitId pkg)
=> FakeMap
-> PackageIndex pkg
-> [[pkg]]
dependencyCycles fakeMap index =
[ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]
where
adjacencyList = [ (pkg, installedUnitId pkg,
CD.flatDeps (fakeDepends fakeMap pkg))
| pkg <- allPackages index ]
-- | Tries to take the transitive closure of the package dependencies.
--
-- If the transitive closure is complete then it returns that subset of the
-- index. Otherwise it returns the broken packages as in 'brokenPackages'.
--
-- * Note that if the result is @Right []@ it is because at least one of
-- the original given 'PackageIdentifier's do not occur in the index.
dependencyClosure :: (PackageFixedDeps pkg, HasUnitId pkg)
=> FakeMap
-> PackageIndex pkg
-> [UnitId]
-> Either [(pkg, [UnitId])]
(PackageIndex pkg)
dependencyClosure fakeMap index pkgids0 = case closure mempty [] pkgids0 of
(completed, []) -> Right completed
(completed, _) -> Left (brokenPackages fakeMap completed)
where
closure completed failed [] = (completed, failed)
closure completed failed (pkgid:pkgids) =
case fakeLookupUnitId fakeMap index pkgid of
Nothing -> closure completed (pkgid:failed) pkgids
Just pkg ->
case fakeLookupUnitId fakeMap completed
(installedUnitId pkg) of
Just _ -> closure completed failed pkgids
Nothing -> closure completed' failed pkgids'
where completed' = insert pkg completed
pkgids' = CD.nonSetupDeps (depends pkg) ++ pkgids
-- | Builds a graph of the package dependencies.
--
-- Dependencies on other packages that are not in the index are discarded.
-- You can check if there are any such dependencies with 'brokenPackages'.
--
dependencyGraph :: (PackageFixedDeps pkg, HasUnitId pkg)
=> FakeMap
-> PackageIndex pkg
-> (Graph.Graph,
Graph.Vertex -> UnitId,
UnitId -> Maybe Graph.Vertex)
dependencyGraph fakeMap index = (graph, vertexToPkg, idToVertex)
where
(graph, vertexToPkg', idToVertex) = Graph.graphFromEdges edges
vertexToPkg v = case vertexToPkg' v of
((), pkgid, _targets) -> pkgid
pkgs = allPackages index
edges = map edgesFrom pkgs
resolve pid = Map.findWithDefault pid pid fakeMap
edgesFrom pkg = ( ()
, resolve (installedUnitId pkg)
, CD.flatDeps (fakeDepends fakeMap pkg)
)