module Distribution.Simple.PackageIndex (
InstalledPackageIndex,
PackageIndex,
fromList,
merge,
insert,
deleteUnitId,
deleteSourcePackageId,
deletePackageName,
lookupUnitId,
lookupComponentId,
lookupSourcePackageId,
lookupPackageId,
lookupPackageName,
lookupDependency,
lookupInternalDependency,
searchByName,
SearchResult(..),
searchByNameSubstring,
allPackages,
allPackagesByName,
allPackagesBySourcePackageId,
allPackagesBySourcePackageIdAndLibName,
brokenPackages,
dependencyClosure,
reverseDependencyClosure,
topologicalOrder,
reverseTopologicalOrder,
dependencyInconsistencies,
dependencyCycles,
dependencyGraph,
moduleNameIndex,
deleteInstalledPackageId,
lookupInstalledPackageId,
) where
import Prelude ()
import Distribution.Compat.Prelude hiding (lookup)
import qualified Data.Map.Strict as Map
import Distribution.Package
import Distribution.Backpack
import Distribution.ModuleName
import qualified Distribution.InstalledPackageInfo as IPI
import Distribution.Version
import Distribution.Simple.Utils
import Distribution.Types.UnqualComponentName
import Control.Exception (assert)
import Data.Array ((!))
import qualified Data.Array as Array
import qualified Data.Graph as Graph
import Data.List as List ( groupBy, deleteBy, deleteFirstsBy )
import qualified Data.Tree as Tree
import Control.Monad
import Distribution.Compat.Stack
data PackageIndex a = PackageIndex {
unitIdIndex :: !(Map UnitId a),
packageIdIndex :: !(Map (PackageName, Maybe UnqualComponentName) (Map Version [a]))
} deriving (Eq, Generic, Show, Read)
instance Binary a => Binary (PackageIndex a)
type InstalledPackageIndex = PackageIndex IPI.InstalledPackageInfo
instance Monoid (PackageIndex IPI.InstalledPackageInfo) where
mempty = PackageIndex Map.empty Map.empty
mappend = (<>)
mconcat [] = mempty
mconcat xs = foldr1 mappend xs
instance Semigroup (PackageIndex IPI.InstalledPackageInfo) where
(<>) = merge
invariant :: WithCallStack (InstalledPackageIndex -> Bool)
invariant (PackageIndex pids pnames) =
pids' == pnames'
where
pids' = map installedUnitId (Map.elems pids)
pnames' = sort
[ assert pinstOk (installedUnitId pinst)
| ((pname, plib), pvers) <- Map.toList pnames
, let pversOk = not (Map.null pvers)
, (pver, pinsts) <- assert pversOk $ Map.toList pvers
, let pinsts' = sortBy (comparing installedUnitId) pinsts
pinstsOk = all (\g -> length g == 1)
(groupBy (equating installedUnitId) pinsts')
, pinst <- assert pinstsOk $ pinsts'
, let pinstOk = packageName pinst == pname
&& packageVersion pinst == pver
&& IPI.sourceLibName pinst == plib
]
mkPackageIndex :: WithCallStack (Map UnitId IPI.InstalledPackageInfo
-> Map (PackageName, Maybe UnqualComponentName)
(Map Version [IPI.InstalledPackageInfo])
-> InstalledPackageIndex)
mkPackageIndex pids pnames = assert (invariant index) index
where index = PackageIndex pids pnames
fromList :: [IPI.InstalledPackageInfo] -> InstalledPackageIndex
fromList pkgs = mkPackageIndex pids pnames
where
pids = Map.fromList [ (installedUnitId pkg, pkg) | pkg <- pkgs ]
pnames =
Map.fromList
[ (liftM2 (,) packageName IPI.sourceLibName (head pkgsN), pvers)
| pkgsN <- groupBy (equating (liftM2 (,) packageName IPI.sourceLibName))
. sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion))
$ pkgs
, let pvers =
Map.fromList
[ (packageVersion (head pkgsNV),
nubBy (equating installedUnitId) (reverse pkgsNV))
| pkgsNV <- groupBy (equating packageVersion) pkgsN
]
]
merge :: InstalledPackageIndex -> InstalledPackageIndex
-> InstalledPackageIndex
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 installedUnitId)
insert :: IPI.InstalledPackageInfo -> InstalledPackageIndex -> InstalledPackageIndex
insert pkg (PackageIndex pids pnames) =
mkPackageIndex pids' pnames'
where
pids' = Map.insert (installedUnitId pkg) pkg pids
pnames' = insertPackageName pnames
insertPackageName =
Map.insertWith (\_ -> insertPackageVersion)
(packageName pkg, IPI.sourceLibName pkg)
(Map.singleton (packageVersion pkg) [pkg])
insertPackageVersion =
Map.insertWith (\_ -> insertPackageInstance)
(packageVersion pkg) [pkg]
insertPackageInstance pkgs =
pkg : deleteBy (equating installedUnitId) pkg pkgs
deleteUnitId :: UnitId -> InstalledPackageIndex
-> InstalledPackageIndex
deleteUnitId 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, IPI.sourceLibName spkgid)
deletePkgVersion spkgid =
(\m -> if Map.null m then Nothing else Just m)
. Map.update deletePkgInstance (packageVersion spkgid)
deletePkgInstance =
(\xs -> if null xs then Nothing else Just xs)
. List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined
deleteInstalledPackageId :: UnitId -> InstalledPackageIndex
-> InstalledPackageIndex
deleteInstalledPackageId = deleteUnitId
deleteSourcePackageId :: PackageId -> InstalledPackageIndex
-> InstalledPackageIndex
deleteSourcePackageId pkgid original@(PackageIndex pids pnames) =
case Map.lookup (packageName pkgid, Nothing) pnames of
Nothing -> original
Just pvers -> case Map.lookup (packageVersion pkgid) pvers of
Nothing -> original
Just pkgs -> mkPackageIndex
(foldl' (flip (Map.delete . installedUnitId)) pids pkgs)
(deletePkgName pnames)
where
deletePkgName =
Map.update deletePkgVersion (packageName pkgid, Nothing)
deletePkgVersion =
(\m -> if Map.null m then Nothing else Just m)
. Map.delete (packageVersion pkgid)
deletePackageName :: PackageName -> InstalledPackageIndex
-> InstalledPackageIndex
deletePackageName name original@(PackageIndex pids pnames) =
case Map.lookup (name, Nothing) pnames of
Nothing -> original
Just pvers -> mkPackageIndex
(foldl' (flip (Map.delete . installedUnitId)) pids
(concat (Map.elems pvers)))
(Map.delete (name, Nothing) pnames)
allPackages :: PackageIndex a -> [a]
allPackages = Map.elems . unitIdIndex
allPackagesByName :: PackageIndex a -> [(PackageName, [a])]
allPackagesByName index =
[ (pkgname, concat (Map.elems pvers))
| ((pkgname, Nothing), pvers) <- Map.toList (packageIdIndex index) ]
allPackagesBySourcePackageId :: HasUnitId a => PackageIndex a
-> [(PackageId, [a])]
allPackagesBySourcePackageId index =
[ (packageId ipkg, ipkgs)
| ((_, Nothing), pvers) <- Map.toList (packageIdIndex index)
, ipkgs@(ipkg:_) <- Map.elems pvers ]
allPackagesBySourcePackageIdAndLibName :: HasUnitId a => PackageIndex a
-> [((PackageId, Maybe UnqualComponentName), [a])]
allPackagesBySourcePackageIdAndLibName index =
[ ((packageId ipkg, ln), ipkgs)
| ((_, ln), pvers) <- Map.toList (packageIdIndex index)
, ipkgs@(ipkg:_) <- Map.elems pvers ]
lookupUnitId :: PackageIndex a -> UnitId
-> Maybe a
lookupUnitId index uid = Map.lookup uid (unitIdIndex index)
lookupComponentId :: PackageIndex a -> ComponentId
-> Maybe a
lookupComponentId index cid =
Map.lookup (newSimpleUnitId cid) (unitIdIndex index)
lookupInstalledPackageId :: PackageIndex a -> UnitId
-> Maybe a
lookupInstalledPackageId = lookupUnitId
lookupSourcePackageId :: PackageIndex a -> PackageId -> [a]
lookupSourcePackageId index pkgid =
case Map.lookup (packageName pkgid, Nothing) (packageIdIndex index) of
Nothing -> []
Just pvers -> case Map.lookup (packageVersion pkgid) pvers of
Nothing -> []
Just pkgs -> pkgs
lookupPackageId :: 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 :: PackageIndex a -> PackageName
-> [(Version, [a])]
lookupPackageName index name =
case Map.lookup (name, Nothing) (packageIdIndex index) of
Nothing -> []
Just pvers -> Map.toList pvers
lookupDependency :: InstalledPackageIndex -> Dependency
-> [(Version, [IPI.InstalledPackageInfo])]
lookupDependency index dep =
lookupInternalDependency index dep Nothing
lookupInternalDependency :: InstalledPackageIndex -> Dependency
-> Maybe UnqualComponentName
-> [(Version, [IPI.InstalledPackageInfo])]
lookupInternalDependency index (Dependency name versionRange) libn =
case Map.lookup (name, libn) (packageIdIndex index) of
Nothing -> []
Just pvers -> [ (ver, pkgs')
| (ver, pkgs) <- Map.toList pvers
, ver `withinRange` versionRange
, let pkgs' = filter eligible pkgs
, not (null pkgs')
]
where
eligible pkg = IPI.indefinite pkg || null (IPI.instantiatedWith pkg)
searchByName :: PackageIndex a -> String -> SearchResult [a]
searchByName index name =
case [ pkgs | pkgs@((pname, Nothing),_) <- Map.toList (packageIdIndex index)
, lowercase (unPackageName pname) == lname ] of
[] -> None
[(_,pvers)] -> Unambiguous (concat (Map.elems pvers))
pkgss -> case find ((mkPackageName name ==) . fst . 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 :: PackageIndex a -> String -> [a]
searchByNameSubstring index searchterm =
[ pkg
| ((pname, Nothing), pvers) <- Map.toList (packageIdIndex index)
, lsearchterm `isInfixOf` lowercase (unPackageName pname)
, pkgs <- Map.elems pvers
, pkg <- pkgs ]
where lsearchterm = lowercase searchterm
dependencyCycles :: PackageInstalled a => PackageIndex a -> [[a]]
dependencyCycles index =
[ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]
where
adjacencyList = [ (pkg, installedUnitId pkg, installedDepends pkg)
| pkg <- allPackages index ]
brokenPackages :: PackageInstalled a => PackageIndex a
-> [(a, [UnitId])]
brokenPackages index =
[ (pkg, missing)
| pkg <- allPackages index
, let missing = [ pkg' | pkg' <- installedDepends pkg
, isNothing (lookupUnitId index pkg') ]
, not (null missing) ]
dependencyClosure :: InstalledPackageIndex
-> [UnitId]
-> Either (InstalledPackageIndex)
[(IPI.InstalledPackageInfo, [UnitId])]
dependencyClosure 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 lookupUnitId index pkgid of
Nothing -> closure completed (pkgid:failed) pkgids
Just pkg -> case lookupUnitId completed (installedUnitId 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
-> [UnitId]
-> [a]
reverseDependencyClosure index =
map vertexToPkg
. concatMap Tree.flatten
. Graph.dfs reverseDepGraph
. map (fromMaybe noSuchPkgId . pkgIdToVertex)
where
(depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph 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,
UnitId -> Maybe Graph.Vertex)
dependencyGraph 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 installedUnitId pkgs) [0..]
vertex_map = Map.fromList vertices
id_to_vertex pid = Map.lookup pid vertex_map
vertex_to_pkg vertex = pkgTable ! vertex
pkgTable = Array.listArray bounds pkgs
topBound = length pkgs 1
bounds = (0, topBound)
type DepUniqueKey = (PackageName, Maybe UnqualComponentName, Map ModuleName OpenModule)
dependencyInconsistencies :: InstalledPackageIndex
-> [(DepUniqueKey,
[(UnitId,
[IPI.InstalledPackageInfo])])]
dependencyInconsistencies index = do
(dep_key, insts_map) <- Map.toList inverseIndex
let insts = Map.toList insts_map
guard (length insts >= 2)
return (dep_key, insts)
where
inverseIndex :: Map DepUniqueKey (Map UnitId [IPI.InstalledPackageInfo])
inverseIndex = Map.fromListWith (Map.unionWith (++)) $ do
pkg <- allPackages index
dep_ipid <- installedDepends pkg
Just dep <- [lookupUnitId index dep_ipid]
let dep_key = (packageName dep, IPI.sourceLibName dep,
Map.fromList (IPI.instantiatedWith dep))
return (dep_key, Map.singleton dep_ipid [pkg])
moduleNameIndex :: InstalledPackageIndex -> Map ModuleName [IPI.InstalledPackageInfo]
moduleNameIndex index =
Map.fromListWith (++) $ do
pkg <- allPackages index
IPI.ExposedModule m reexport <- IPI.exposedModules pkg
case reexport of
Nothing -> return (m, [pkg])
Just (OpenModuleVar _) -> []
Just (OpenModule _ m') | m == m' -> []
| otherwise -> return (m', [pkg])