{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.PackageIndex -- Copyright : (c) David Himmelstrup 2005, -- Bjorn Bringert 2007, -- Duncan Coutts 2008-2009 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- An index of packages. -- module Distribution.Simple.PackageIndex ( -- * Package index data type InstalledPackageIndex, PackageIndex, FakeMap, -- * Creating an index fromList, -- * Updates merge, insert, deleteInstalledPackageId, deleteSourcePackageId, deletePackageName, -- deleteDependency, -- * Queries -- ** Precise lookups lookupInstalledPackageId, lookupSourcePackageId, lookupPackageId, lookupPackageName, lookupDependency, -- ** Case-insensitive searches searchByName, SearchResult(..), searchByNameSubstring, -- ** Bulk queries allPackages, allPackagesByName, allPackagesBySourcePackageId, -- ** Special queries brokenPackages, dependencyClosure, reverseDependencyClosure, topologicalOrder, reverseTopologicalOrder, dependencyInconsistencies, dependencyCycles, dependencyGraph, moduleNameIndex, -- ** Variants of special queries supporting fake map fakeLookupInstalledPackageId, brokenPackages', dependencyClosure', reverseDependencyClosure', dependencyInconsistencies', dependencyCycles', dependencyGraph', ) where import Control.Exception (assert) import Data.Array ((!)) import qualified Data.Array as Array import Distribution.Compat.Binary (Binary) import qualified Data.Graph as Graph import Data.List as List ( null, foldl', sort , groupBy, sortBy, find, isInfixOf, nubBy, deleteBy, deleteFirstsBy ) import Data.Monoid (Monoid(..)) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (isNothing, fromMaybe) import qualified Data.Tree as Tree import GHC.Generics (Generic) import Prelude hiding (lookup) import Distribution.Package ( PackageName(..), PackageId , Package(..), packageName, packageVersion , Dependency(Dependency)--, --PackageFixedDeps(..) , InstalledPackageId(..), PackageInstalled(..) ) import Distribution.ModuleName ( ModuleName ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Version ( Version, withinRange ) import Distribution.Simple.Utils (lowercase, comparing, equating) -- 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 InstalledPackageId, 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 InstalledPackageId will be calculatable prior to actually -- building the package (making it something of a misnomer), 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 InstalledPackageId 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 InstalledPackageId 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 InstalledPackageId. 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 installed package IDs to real ones. See Note [FakeMap] type FakeMap = Map InstalledPackageId InstalledPackageId -- | The collection of information about packages from one or more 'PackageDB's. -- These packages generally should have an instance of 'PackageInstalled' -- -- Packages are uniquely identified in by their 'InstalledPackageId', they can -- also be efficiently looked up by package name or by name and version. -- data PackageIndex a = PackageIndex -- The primary index. Each InstalledPackageInfo record is uniquely identified -- by its InstalledPackageId. -- !(Map InstalledPackageId a) -- This auxiliary index maps package names (case-sensitively) to all the -- versions and instances of that package. This allows us to find all -- versions satisfying a dependency. -- -- It is a three-level index. The first level is the package name, -- the second is the package version and the final level is instances -- of the same package version. These are unique by InstalledPackageId -- and are kept in preference order. -- -- FIXME: Clarify what "preference order" means. Check that this invariant is -- preserved. See #1463 for discussion. !(Map PackageName (Map Version [a])) deriving (Generic, Show, Read) instance Binary a => Binary (PackageIndex a) -- | The default package index which contains 'InstalledPackageInfo'. Normally -- use this. type InstalledPackageIndex = PackageIndex InstalledPackageInfo instance PackageInstalled a => Monoid (PackageIndex a) where mempty = PackageIndex Map.empty Map.empty mappend = merge --save one mappend with empty in the common case: mconcat [] = mempty mconcat xs = foldr1 mappend xs invariant :: PackageInstalled a => PackageIndex a -> Bool invariant (PackageIndex pids pnames) = map installedPackageId (Map.elems pids) == sort [ assert pinstOk (installedPackageId pinst) | (pname, pvers) <- Map.toList pnames , let pversOk = not (Map.null pvers) , (pver, pinsts) <- assert pversOk $ Map.toList pvers , let pinsts' = sortBy (comparing installedPackageId) pinsts pinstsOk = all (\g -> length g == 1) (groupBy (equating installedPackageId) pinsts') , pinst <- assert pinstsOk $ pinsts' , let pinstOk = packageName pinst == pname && packageVersion pinst == pver ] -- -- * Internal helpers -- mkPackageIndex :: PackageInstalled a => Map InstalledPackageId a -> Map PackageName (Map Version [a]) -> PackageIndex a mkPackageIndex pids pnames = assert (invariant index) index where index = PackageIndex pids pnames -- -- * Construction -- -- | Build an index out of a bunch of packages. -- -- If there are duplicates by 'InstalledPackageId' then later ones mask earlier -- ones. -- fromList :: PackageInstalled a => [a] -> PackageIndex a fromList pkgs = mkPackageIndex pids pnames where pids = Map.fromList [ (installedPackageId pkg, pkg) | pkg <- pkgs ] pnames = Map.fromList [ (packageName (head pkgsN), pvers) | pkgsN <- groupBy (equating packageName) . sortBy (comparing packageId) $ pkgs , let pvers = Map.fromList [ (packageVersion (head pkgsNV), nubBy (equating installedPackageId) (reverse pkgsNV)) | pkgsNV <- groupBy (equating packageVersion) pkgsN ] ] -- -- * Updates -- -- | Merge two indexes. -- -- Packages from the second mask packages from the first if they have the exact -- same 'InstalledPackageId'. -- -- For packages with the same source 'PackageId', packages from the second are -- \"preferred\" over those from the first. Being preferred means they are top -- result when we do a lookup by source 'PackageId'. This is the mechanism we -- use to prefer user packages over global packages. -- merge :: PackageInstalled a => PackageIndex a -> PackageIndex a -> PackageIndex a merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) = mkPackageIndex (Map.unionWith (\_ y -> y) pids1 pids2) (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) where -- Packages in the second list mask those in the first, however preferred -- packages go first in the list. mergeBuckets xs ys = ys ++ (xs \\ ys) (\\) = deleteFirstsBy (equating installedPackageId) -- | Inserts a single package into the index. -- -- This is equivalent to (but slightly quicker than) using 'mappend' or -- 'merge' with a singleton index. -- insert :: PackageInstalled a => a -> PackageIndex a -> PackageIndex a insert pkg (PackageIndex pids pnames) = mkPackageIndex pids' pnames' where pids' = Map.insert (installedPackageId pkg) pkg pids pnames' = insertPackageName pnames insertPackageName = Map.insertWith' (\_ -> insertPackageVersion) (packageName pkg) (Map.singleton (packageVersion pkg) [pkg]) insertPackageVersion = Map.insertWith' (\_ -> insertPackageInstance) (packageVersion pkg) [pkg] insertPackageInstance pkgs = pkg : deleteBy (equating installedPackageId) pkg pkgs -- | Removes a single installed package from the index. -- deleteInstalledPackageId :: PackageInstalled a => InstalledPackageId -> PackageIndex a -> PackageIndex a deleteInstalledPackageId ipkgid original@(PackageIndex pids pnames) = case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of (Nothing, _) -> original (Just spkgid, pids') -> mkPackageIndex pids' (deletePkgName spkgid pnames) where deletePkgName spkgid = Map.update (deletePkgVersion spkgid) (packageName spkgid) deletePkgVersion spkgid = (\m -> if Map.null m then Nothing else Just m) . Map.update deletePkgInstance (packageVersion spkgid) deletePkgInstance = (\xs -> if List.null xs then Nothing else Just xs) . List.deleteBy (\_ pkg -> installedPackageId pkg == ipkgid) undefined -- | Removes all packages with this source 'PackageId' from the index. -- deleteSourcePackageId :: PackageInstalled a => PackageId -> PackageIndex a -> PackageIndex a deleteSourcePackageId pkgid original@(PackageIndex pids pnames) = case Map.lookup (packageName pkgid) pnames of Nothing -> original Just pvers -> case Map.lookup (packageVersion pkgid) pvers of Nothing -> original Just pkgs -> mkPackageIndex (foldl' (flip (Map.delete . installedPackageId)) pids pkgs) (deletePkgName pnames) where deletePkgName = Map.update deletePkgVersion (packageName pkgid) deletePkgVersion = (\m -> if Map.null m then Nothing else Just m) . Map.delete (packageVersion pkgid) -- | Removes all packages with this (case-sensitive) name from the index. -- deletePackageName :: PackageInstalled a => PackageName -> PackageIndex a -> PackageIndex a deletePackageName name original@(PackageIndex pids pnames) = case Map.lookup name pnames of Nothing -> original Just pvers -> mkPackageIndex (foldl' (flip (Map.delete . installedPackageId)) pids (concat (Map.elems pvers))) (Map.delete name pnames) {- -- | Removes all packages satisfying this dependency from the index. -- deleteDependency :: Dependency -> PackageIndex -> PackageIndex deleteDependency (Dependency name verstionRange) = delete' name (\pkg -> packageVersion pkg `withinRange` verstionRange) -} -- -- * Bulk queries -- -- | Get all the packages from the index. -- allPackages :: PackageIndex a -> [a] allPackages (PackageIndex pids _) = Map.elems pids -- | Get all the packages from the index. -- -- They are grouped by package name (case-sensitively). -- allPackagesByName :: PackageIndex a -> [(PackageName, [a])] allPackagesByName (PackageIndex _ pnames) = [ (pkgname, concat (Map.elems pvers)) | (pkgname, pvers) <- Map.toList pnames ] -- | Get all the packages from the index. -- -- They are grouped by source package id (package name and version). -- allPackagesBySourcePackageId :: PackageInstalled a => PackageIndex a -> [(PackageId, [a])] allPackagesBySourcePackageId (PackageIndex _ pnames) = [ (packageId ipkg, ipkgs) | pvers <- Map.elems pnames , ipkgs@(ipkg:_) <- Map.elems pvers ] -- -- * Lookups -- -- | Does a lookup by source package id (name & version). -- -- Since multiple package DBs mask each other by 'InstalledPackageId', -- then we get back at most one package. -- lookupInstalledPackageId :: PackageInstalled a => PackageIndex a -> InstalledPackageId -> Maybe a lookupInstalledPackageId (PackageIndex pids _) pid = Map.lookup pid pids -- | Does a lookup by source package id (name & version). -- -- There can be multiple installed packages with the same source 'PackageId' -- but different 'InstalledPackageId'. They are returned in order of -- preference, with the most preferred first. -- lookupSourcePackageId :: PackageInstalled a => PackageIndex a -> PackageId -> [a] lookupSourcePackageId (PackageIndex _ pnames) pkgid = case Map.lookup (packageName pkgid) pnames of Nothing -> [] Just pvers -> case Map.lookup (packageVersion pkgid) pvers of Nothing -> [] Just pkgs -> pkgs -- in preference order -- | Convenient alias of 'lookupSourcePackageId', but assuming only -- one package per package ID. lookupPackageId :: PackageInstalled a => PackageIndex a -> PackageId -> Maybe a lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of [] -> Nothing [pkg] -> Just pkg _ -> error "Distribution.Simple.PackageIndex: multiple matches found" -- | Does a lookup by source package name. -- lookupPackageName :: PackageInstalled a => PackageIndex a -> PackageName -> [(Version, [a])] lookupPackageName (PackageIndex _ pnames) name = case Map.lookup name pnames of Nothing -> [] Just pvers -> Map.toList pvers -- | Does a lookup by source package name and a range of versions. -- -- We get back any number of versions of the specified package name, all -- satisfying the version range constraint. -- lookupDependency :: PackageInstalled a => PackageIndex a -> Dependency -> [(Version, [a])] lookupDependency (PackageIndex _ pnames) (Dependency name versionRange) = case Map.lookup name pnames of Nothing -> [] Just pvers -> [ entry | entry@(ver, _) <- Map.toList pvers , ver `withinRange` versionRange ] -- -- * Case insensitive name lookups -- -- | Does a case-insensitive search by package name. -- -- If there is only one package that compares case-insensitively to this name -- then the search is unambiguous and we get back all versions of that package. -- If several match case-insensitively but one matches exactly then it is also -- unambiguous. -- -- If however several match case-insensitively and none match exactly then we -- have an ambiguous result, and we get back all the versions of all the -- packages. The list of ambiguous results is split by exact package name. So -- it is a non-empty list of non-empty lists. -- searchByName :: PackageInstalled a => PackageIndex a -> String -> SearchResult [a] searchByName (PackageIndex _ pnames) name = case [ pkgs | pkgs@(PackageName name',_) <- Map.toList pnames , lowercase name' == lname ] of [] -> None [(_,pvers)] -> Unambiguous (concat (Map.elems pvers)) pkgss -> case find ((PackageName name==) . fst) pkgss of Just (_,pvers) -> Unambiguous (concat (Map.elems pvers)) Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) where lname = lowercase name data SearchResult a = None | Unambiguous a | Ambiguous [a] -- | Does a case-insensitive substring search by package name. -- -- That is, all packages that contain the given string in their name. -- searchByNameSubstring :: PackageInstalled a => PackageIndex a -> String -> [a] searchByNameSubstring (PackageIndex _ pnames) searchterm = [ pkg | (PackageName name, pvers) <- Map.toList pnames , lsearchterm `isInfixOf` lowercase name , pkgs <- Map.elems pvers , pkg <- pkgs ] where lsearchterm = lowercase searchterm -- -- * Special queries -- -- None of the stuff below depends on the internal representation of the index. -- -- | 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 :: PackageInstalled a => PackageIndex a -> [[a]] dependencyCycles = dependencyCycles' Map.empty -- | Variant of 'dependencyCycles' which accepts a 'FakeMap'. See Note [FakeMap]. dependencyCycles' :: PackageInstalled a => FakeMap -> PackageIndex a -> [[a]] dependencyCycles' fakeMap index = [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] where adjacencyList = [ (pkg, installedPackageId pkg, fakeInstalledDepends fakeMap pkg) | pkg <- allPackages index ] -- | All packages that have immediate dependencies that are not in the index. -- -- Returns such packages along with the dependencies that they're missing. -- brokenPackages :: PackageInstalled a => PackageIndex a -> [(a, [InstalledPackageId])] brokenPackages = brokenPackages' Map.empty -- | Variant of 'brokenPackages' which accepts a 'FakeMap'. See Note [FakeMap]. brokenPackages' :: PackageInstalled a => FakeMap -> PackageIndex a -> [(a, [InstalledPackageId])] brokenPackages' fakeMap index = [ (pkg, missing) | pkg <- allPackages index , let missing = [ pkg' | pkg' <- installedDepends pkg , isNothing (fakeLookupInstalledPackageId fakeMap index pkg') ] , not (null missing) ] -- | Variant of 'lookupInstalledPackageId' which accepts a 'FakeMap'. See Note [FakeMap]. fakeLookupInstalledPackageId :: PackageInstalled a => FakeMap -> PackageIndex a -> InstalledPackageId -> Maybe a fakeLookupInstalledPackageId fakeMap index pkg = lookupInstalledPackageId index (Map.findWithDefault pkg pkg fakeMap) -- | 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 'PackageId's do not occur in the index. -- dependencyClosure :: PackageInstalled a => PackageIndex a -> [InstalledPackageId] -> Either (PackageIndex a) [(a, [InstalledPackageId])] dependencyClosure = dependencyClosure' Map.empty -- | Variant of 'dependencyClosure' which accepts a 'FakeMap'. See Note [FakeMap]. dependencyClosure' :: PackageInstalled a => FakeMap -> PackageIndex a -> [InstalledPackageId] -> Either (PackageIndex a) [(a, [InstalledPackageId])] dependencyClosure' fakeMap index pkgids0 = case closure mempty [] pkgids0 of (completed, []) -> Left completed (completed, _) -> Right (brokenPackages completed) where closure completed failed [] = (completed, failed) closure completed failed (pkgid:pkgids) = case fakeLookupInstalledPackageId fakeMap index pkgid of Nothing -> closure completed (pkgid:failed) pkgids Just pkg -> case fakeLookupInstalledPackageId fakeMap completed (installedPackageId pkg) of Just _ -> closure completed failed pkgids Nothing -> closure completed' failed pkgids' where completed' = insert pkg completed pkgids' = installedDepends pkg ++ pkgids -- | Takes the transitive closure of the packages reverse dependencies. -- -- * The given 'PackageId's must be in the index. -- reverseDependencyClosure :: PackageInstalled a => PackageIndex a -> [InstalledPackageId] -> [a] reverseDependencyClosure = reverseDependencyClosure' Map.empty -- | Variant of 'reverseDependencyClosure' which accepts a 'FakeMap'. See Note [FakeMap]. reverseDependencyClosure' :: PackageInstalled a => FakeMap -> PackageIndex a -> [InstalledPackageId] -> [a] reverseDependencyClosure' fakeMap index = map vertexToPkg . concatMap Tree.flatten . Graph.dfs reverseDepGraph . map (fromMaybe noSuchPkgId . pkgIdToVertex) where (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph' fakeMap index reverseDepGraph = Graph.transposeG depGraph noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" topologicalOrder :: PackageInstalled a => PackageIndex a -> [a] topologicalOrder index = map toPkgId . Graph.topSort $ graph where (graph, toPkgId, _) = dependencyGraph index reverseTopologicalOrder :: PackageInstalled a => PackageIndex a -> [a] reverseTopologicalOrder index = map toPkgId . Graph.topSort . Graph.transposeG $ graph where (graph, toPkgId, _) = dependencyGraph index -- | 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 :: PackageInstalled a => PackageIndex a -> (Graph.Graph, Graph.Vertex -> a, InstalledPackageId -> Maybe Graph.Vertex) dependencyGraph = dependencyGraph' Map.empty -- | Variant of 'dependencyGraph' which accepts a 'FakeMap'. See Note [FakeMap]. dependencyGraph' :: PackageInstalled a => FakeMap -> PackageIndex a -> (Graph.Graph, Graph.Vertex -> a, InstalledPackageId -> Maybe Graph.Vertex) dependencyGraph' fakeMap index = (graph, vertex_to_pkg, id_to_vertex) where graph = Array.listArray bounds [ [ v | Just v <- map id_to_vertex (installedDepends pkg) ] | pkg <- pkgs ] pkgs = sortBy (comparing packageId) (allPackages index) vertices = zip (map installedPackageId pkgs) [0..] vertex_map = Map.fromList vertices id_to_vertex pid = Map.lookup (Map.findWithDefault pid pid fakeMap) vertex_map vertex_to_pkg vertex = pkgTable ! vertex pkgTable = Array.listArray bounds pkgs topBound = length pkgs - 1 bounds = (0, topBound) -- | 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 :: PackageInstalled a => PackageIndex a -> [(PackageName, [(PackageId, Version)])] dependencyInconsistencies = dependencyInconsistencies' Map.empty -- | Variant of 'dependencyInconsistencies' which accepts a 'FakeMap'. See Note [FakeMap]. dependencyInconsistencies' :: PackageInstalled a => FakeMap -> PackageIndex a -> [(PackageName, [(PackageId, 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 PackageName, -- for each package with that name, -- the InstalledPackageInfo and the package Ids of packages -- that depend on it. inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) [ (packageName dep, Map.fromList [(ipid,(dep,[packageId pkg]))]) | pkg <- allPackages index , ipid <- fakeInstalledDepends fakeMap pkg , Just dep <- [fakeLookupInstalledPackageId fakeMap index ipid] ] reallyIsInconsistent :: PackageInstalled a => [a] -> Bool reallyIsInconsistent [] = False reallyIsInconsistent [_p] = False reallyIsInconsistent [p1, p2] = let pid1 = installedPackageId p1 pid2 = installedPackageId p2 in Map.findWithDefault pid1 pid1 fakeMap `notElem` fakeInstalledDepends fakeMap p2 && Map.findWithDefault pid2 pid2 fakeMap `notElem` fakeInstalledDepends fakeMap p1 reallyIsInconsistent _ = True -- | Variant of 'installedDepends' which accepts a 'FakeMap'. See Note [FakeMap]. fakeInstalledDepends :: PackageInstalled a => FakeMap -> a -> [InstalledPackageId] fakeInstalledDepends fakeMap = map (\pid -> Map.findWithDefault pid pid fakeMap) . installedDepends -- | A rough approximation of GHC's module finder, takes a 'InstalledPackageIndex' and -- turns it into a map from module names to their source packages. It's used to -- initialize the @build-deps@ field in @cabal init@. moduleNameIndex :: InstalledPackageIndex -> Map ModuleName [InstalledPackageInfo] moduleNameIndex index = Map.fromListWith (++) $ do pkg <- allPackages index IPI.ExposedModule m reexport _ <- IPI.exposedModules pkg case reexport of Nothing -> return (m, [pkg]) Just (IPI.OriginalModule _ m') | m == m' -> [] | otherwise -> return (m', [pkg]) -- The heuristic is this: we want to prefer the original package -- which originally exported a module. However, if a reexport -- also *renamed* the module (m /= m'), then we have to use the -- downstream package, since the upstream package has the wrong -- module name!