module Distribution.Simple.PackageIndex (
PackageIndex,
fromList,
merge,
insert,
deletePackageName,
deletePackageId,
deleteDependency,
lookupPackageName,
lookupPackageId,
lookupDependency,
searchByName,
SearchResult(..),
searchByNameSubstring,
allPackages,
allPackagesByName,
brokenPackages,
dependencyClosure,
reverseDependencyClosure,
dependencyInconsistencies,
dependencyCycles,
dependencyGraph,
) where
import Prelude hiding (lookup)
import Control.Exception (assert)
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Tree as Tree
import qualified Data.Graph as Graph
import qualified Data.Array as Array
import Data.Array ((!))
import Data.List (groupBy, sortBy, find)
import Data.Monoid (Monoid(..))
import Data.Maybe (isNothing, fromMaybe)
import Distribution.Package
( PackageIdentifier, Package(..), packageName, packageVersion
, Dependency(Dependency), PackageFixedDeps(..) )
import Distribution.Version
( Version, withinRange )
import Distribution.Simple.Utils (lowercase, equating, comparing, isInfixOf)
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606)
import Text.Read
import qualified Text.Read.Lex as L
#endif
data Package pkg => PackageIndex pkg = PackageIndex
(Map String [pkg])
#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 606)
deriving (Show, Read)
#else
instance (Package pkg, Show pkg) => Show (PackageIndex pkg) where
showsPrec d (PackageIndex m) =
showParen (d > 10) (showString "PackageIndex" . shows (Map.toList m))
instance (Package pkg, Read pkg) => Read (PackageIndex pkg) where
readPrec = parens $ prec 10 $ do
Ident "PackageIndex" <- lexP
xs <- readPrec
return (PackageIndex (Map.fromList xs))
where parens :: ReadPrec a -> ReadPrec a
parens p = optional
where
optional = p +++ mandatory
mandatory = paren optional
paren :: ReadPrec a -> ReadPrec a
paren p = do L.Punc "(" <- lexP
x <- reset p
L.Punc ")" <- lexP
return x
readListPrec = readListPrecDefault
#endif
instance Package pkg => Monoid (PackageIndex pkg) where
mempty = PackageIndex (Map.empty)
mappend = merge
mconcat [] = mempty
mconcat xs = foldr1 mappend xs
invariant :: Package pkg => PackageIndex pkg -> Bool
invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m)
where
goodBucket _ [] = False
goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0
where
check pkgid [] = lowercase (packageName pkgid) == name
check pkgid (pkg':pkgs) = lowercase (packageName pkgid) == name
&& pkgid < pkgid'
&& check pkgid' pkgs
where pkgid' = packageId pkg'
mkPackageIndex :: Package pkg => Map String [pkg] -> PackageIndex pkg
mkPackageIndex index = assert (invariant (PackageIndex index))
(PackageIndex index)
internalError :: String -> a
internalError name = error ("PackageIndex." ++ name ++ ": internal error")
lookup :: Package pkg => PackageIndex pkg -> String -> [pkg]
lookup (PackageIndex m) name =
case Map.lookup (lowercase name) m of
Nothing -> []
Just pkgs -> pkgs
fromList :: Package pkg => [pkg] -> PackageIndex pkg
fromList pkgs = mkPackageIndex
. Map.map fixBucket
. Map.fromListWith (++)
$ [ let key = (lowercase . packageName) pkg
in (key, [pkg])
| pkg <- pkgs ]
where
fixBucket =
map head
. groupBy (\a b -> EQ == comparing packageId a b)
. sortBy (comparing packageId)
merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg
merge i1@(PackageIndex m1) i2@(PackageIndex m2) =
assert (invariant i1 && invariant i2) $
mkPackageIndex (Map.unionWith mergeBuckets m1 m2)
mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg]
mergeBuckets [] ys = ys
mergeBuckets xs [] = xs
mergeBuckets xs@(x:xs') ys@(y:ys') =
case packageId x `compare` packageId y of
GT -> y : mergeBuckets xs ys'
EQ -> y : mergeBuckets xs' ys'
LT -> x : mergeBuckets xs' ys
insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg
insert pkg (PackageIndex index) = mkPackageIndex $
let key = (lowercase . packageName) pkg
in Map.insertWith (\_ -> insertNoDup) key [pkg] index
where
pkgid = packageId pkg
insertNoDup [] = [pkg]
insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of
LT -> pkg : pkgs
EQ -> pkg : pkgs'
GT -> pkg' : insertNoDup pkgs'
delete :: Package pkg => String -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg
delete name p (PackageIndex index) = mkPackageIndex $
let key = lowercase name
in Map.update filterBucket key index
where
filterBucket = deleteEmptyBucket
. filter (not . p)
deleteEmptyBucket [] = Nothing
deleteEmptyBucket remaining = Just remaining
deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg
deletePackageId pkgid =
delete (packageName pkgid) (\pkg -> packageId pkg == pkgid)
deletePackageName :: Package pkg => String -> PackageIndex pkg -> PackageIndex pkg
deletePackageName name =
delete name (\pkg -> packageName pkg == name)
deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg
deleteDependency (Dependency name verstionRange) =
delete name (\pkg -> packageVersion pkg `withinRange` verstionRange)
allPackages :: Package pkg => PackageIndex pkg -> [pkg]
allPackages (PackageIndex m) = concat (Map.elems m)
allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]]
allPackagesByName (PackageIndex m) =
concatMap (groupBy (equating packageName)) (Map.elems m)
searchByName :: Package pkg => PackageIndex pkg -> String -> SearchResult [pkg]
searchByName index name =
case groupBy (equating packageName) (lookup index name) of
[] -> None
[pkgs] -> Unambiguous pkgs
pkgss -> case find ((name==) . packageName . head) pkgss of
Just pkgs -> Unambiguous pkgs
Nothing -> Ambiguous pkgss
data SearchResult a = None | Unambiguous a | Ambiguous [a]
searchByNameSubstring :: Package pkg => PackageIndex pkg -> String -> [pkg]
searchByNameSubstring (PackageIndex m) searchterm =
[ pkg
| (name, pkgs) <- Map.toList m
, searchterm' `isInfixOf` name
, pkg <- pkgs ]
where searchterm' = lowercase searchterm
lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg
lookupPackageId index pkgid =
case [ pkg | pkg <- lookup index (packageName pkgid)
, packageId pkg == pkgid ] of
[] -> Nothing
[pkg] -> Just pkg
_ -> internalError "lookupPackageIdentifier"
lookupPackageName :: Package pkg => PackageIndex pkg -> String -> [pkg]
lookupPackageName index name =
[ pkg | pkg <- lookup index name
, packageName pkg == name ]
lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg]
lookupDependency index (Dependency name versionRange) =
[ pkg | pkg <- lookup index name
, packageName pkg == name
, packageVersion pkg `withinRange` versionRange ]
brokenPackages :: PackageFixedDeps pkg
=> PackageIndex pkg
-> [(pkg, [PackageIdentifier])]
brokenPackages index =
[ (pkg, missing)
| pkg <- allPackages index
, let missing = [ pkg' | pkg' <- depends pkg
, isNothing (lookupPackageId index pkg') ]
, not (null missing) ]
dependencyClosure :: PackageFixedDeps pkg
=> PackageIndex pkg
-> [PackageIdentifier]
-> Either (PackageIndex pkg)
[(pkg, [PackageIdentifier])]
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 lookupPackageId index pkgid of
Nothing -> closure completed (pkgid:failed) pkgids
Just pkg -> case lookupPackageId completed (packageId pkg) of
Just _ -> closure completed failed pkgids
Nothing -> closure completed' failed pkgids'
where completed' = insert pkg completed
pkgids' = depends pkg ++ pkgids
reverseDependencyClosure :: PackageFixedDeps pkg
=> PackageIndex pkg
-> [PackageIdentifier]
-> [PackageIdentifier]
reverseDependencyClosure index =
map vertexToPkgId
. concatMap Tree.flatten
. Graph.dfs reverseDepGraph
. map (fromMaybe noSuchPkgId . pkgIdToVertex)
where
(depGraph, vertexToPkgId, pkgIdToVertex) = dependencyGraph index
reverseDepGraph = Graph.transposeG depGraph
noSuchPkgId = error "reverseDependencyClosure: package is not in the graph"
dependencyInconsistencies :: PackageFixedDeps pkg
=> PackageIndex pkg
-> [(String, [(PackageIdentifier, Version)])]
dependencyInconsistencies index =
[ (name, inconsistencies)
| (name, uses) <- Map.toList inverseIndex
, let inconsistencies = duplicatesBy uses
, not (null inconsistencies) ]
where inverseIndex = Map.fromListWith (++)
[ (packageName dep, [(packageId pkg, packageVersion dep)])
| pkg <- allPackages index
, dep <- depends pkg ]
duplicatesBy = (\groups -> if length groups == 1
then []
else concat groups)
. groupBy (equating snd)
. sortBy (comparing snd)
dependencyCycles :: PackageFixedDeps pkg
=> PackageIndex pkg
-> [[pkg]]
dependencyCycles index =
[ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]
where
adjacencyList = [ (pkg, packageId pkg, depends pkg)
| pkg <- allPackages index ]
dependencyGraph :: PackageFixedDeps pkg
=> PackageIndex pkg
-> (Graph.Graph,
Graph.Vertex -> PackageIdentifier,
PackageIdentifier -> Maybe Graph.Vertex)
dependencyGraph index = (graph, vertexToPkgId, pkgIdToVertex)
where
graph = Array.listArray bounds
[ [ v | Just v <- map pkgIdToVertex (depends pkg) ]
| pkg <- pkgs ]
vertexToPkgId vertex = pkgIdTable ! vertex
pkgIdToVertex = binarySearch 0 topBound
pkgIdTable = Array.listArray bounds (map packageId pkgs)
pkgs = sortBy (comparing packageId) (allPackages index)
topBound = length pkgs 1
bounds = (0, topBound)
binarySearch a b key
| a > b = Nothing
| otherwise = case compare key (pkgIdTable ! mid) of
LT -> binarySearch a (mid1) key
EQ -> Just mid
GT -> binarySearch (mid+1) b key
where mid = (a + b) `div` 2