module Distribution.Simple.PackageIndex (
InstalledPackageIndex,
PackageIndex,
FakeMap,
fromList,
merge,
insert,
deleteInstalledPackageId,
deleteSourcePackageId,
deletePackageName,
lookupInstalledPackageId,
lookupSourcePackageId,
lookupPackageId,
lookupPackageName,
lookupDependency,
searchByName,
SearchResult(..),
searchByNameSubstring,
allPackages,
allPackagesByName,
allPackagesBySourcePackageId,
brokenPackages,
dependencyClosure,
reverseDependencyClosure,
topologicalOrder,
reverseTopologicalOrder,
dependencyInconsistencies,
dependencyCycles,
dependencyGraph,
moduleNameIndex,
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)
, 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)
type FakeMap = Map InstalledPackageId InstalledPackageId
data PackageIndex a = PackageIndex
!(Map InstalledPackageId a)
!(Map PackageName (Map Version [a]))
deriving (Generic, Show, Read)
instance Binary a => Binary (PackageIndex a)
type InstalledPackageIndex = PackageIndex InstalledPackageInfo
instance PackageInstalled a => Monoid (PackageIndex a) where
mempty = PackageIndex Map.empty Map.empty
mappend = merge
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
]
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
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
]
]
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
mergeBuckets xs ys = ys ++ (xs \\ ys)
(\\) = deleteFirstsBy (equating installedPackageId)
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
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
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)
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)
allPackages :: PackageIndex a -> [a]
allPackages (PackageIndex pids _) = Map.elems pids
allPackagesByName :: PackageIndex a -> [(PackageName, [a])]
allPackagesByName (PackageIndex _ pnames) =
[ (pkgname, concat (Map.elems pvers))
| (pkgname, pvers) <- Map.toList pnames ]
allPackagesBySourcePackageId :: PackageInstalled a => PackageIndex a -> [(PackageId, [a])]
allPackagesBySourcePackageId (PackageIndex _ pnames) =
[ (packageId ipkg, ipkgs)
| pvers <- Map.elems pnames
, ipkgs@(ipkg:_) <- Map.elems pvers ]
lookupInstalledPackageId :: PackageInstalled a => PackageIndex a -> InstalledPackageId
-> Maybe a
lookupInstalledPackageId (PackageIndex pids _) pid = Map.lookup pid pids
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
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"
lookupPackageName :: PackageInstalled a => PackageIndex a -> PackageName
-> [(Version, [a])]
lookupPackageName (PackageIndex _ pnames) name =
case Map.lookup name pnames of
Nothing -> []
Just pvers -> Map.toList pvers
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 ]
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]
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
dependencyCycles :: PackageInstalled a => PackageIndex a -> [[a]]
dependencyCycles = dependencyCycles' Map.empty
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 ]
brokenPackages :: PackageInstalled a => PackageIndex a -> [(a, [InstalledPackageId])]
brokenPackages = brokenPackages' Map.empty
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) ]
fakeLookupInstalledPackageId :: PackageInstalled a => FakeMap -> PackageIndex a -> InstalledPackageId -> Maybe a
fakeLookupInstalledPackageId fakeMap index pkg = lookupInstalledPackageId index (Map.findWithDefault pkg pkg fakeMap)
dependencyClosure :: PackageInstalled a => PackageIndex a
-> [InstalledPackageId]
-> Either (PackageIndex a)
[(a, [InstalledPackageId])]
dependencyClosure = dependencyClosure' Map.empty
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
reverseDependencyClosure :: PackageInstalled a => PackageIndex a
-> [InstalledPackageId]
-> [a]
reverseDependencyClosure = reverseDependencyClosure' Map.empty
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
dependencyGraph :: PackageInstalled a => PackageIndex a
-> (Graph.Graph,
Graph.Vertex -> a,
InstalledPackageId -> Maybe Graph.Vertex)
dependencyGraph = dependencyGraph' Map.empty
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)
dependencyInconsistencies :: PackageInstalled a => PackageIndex a
-> [(PackageName, [(PackageId, Version)])]
dependencyInconsistencies = dependencyInconsistencies' Map.empty
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
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
fakeInstalledDepends :: PackageInstalled a => FakeMap -> a -> [InstalledPackageId]
fakeInstalledDepends fakeMap = map (\pid -> Map.findWithDefault pid pid fakeMap) . installedDepends
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])