Commit 6ddedf64 authored by Duncan Coutts's avatar Duncan Coutts

Generalise InstalledPackageIndex over all Package instances

New Package class of things that can be identified by a PackageIdentifier
so that covers at least PackageIdentifier, PackageDescription and
InstalledPackageInfo. Most PackageIndex operations work for any package type.
parent d8b2d8ae
......@@ -64,10 +64,10 @@ Library
Distribution.Simple.Hugs,
Distribution.Simple.Install,
Distribution.Simple.InstallDirs,
Distribution.Simple.InstalledPackageIndex,
Distribution.Simple.JHC,
Distribution.Simple.LocalBuildInfo,
Distribution.Simple.NHC,
Distribution.Simple.PackageIndex,
Distribution.Simple.PreProcess,
Distribution.Simple.PreProcess.Unlit,
Distribution.Simple.Program,
......
......@@ -59,10 +59,12 @@ import Distribution.Simple.Compiler
, unsupportedExtensions, PackageDB(..) )
import Distribution.Package
( PackageIdentifier(..), showPackageId )
import Distribution.InstalledPackageInfo
( InstalledPackageInfo )
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
( InstalledPackageInfo_(package) )
import qualified Distribution.Simple.InstalledPackageIndex as InstalledPackageIndex
import Distribution.Simple.InstalledPackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.PackageDescription as PD
( PackageDescription(..), GenericPackageDescription(..)
, Library(..), hasLibs, Executable(..), BuildInfo(..)
......@@ -229,7 +231,7 @@ configure (pkg_descr0, pbi) cfg
case finalizePackageDescription
(configConfigurationsFlags cfg)
(fmap (map InstalledPackageInfo.package
. InstalledPackageIndex.allPackages)
. PackageIndex.allPackages)
maybePackageIndex)
System.Info.os
System.Info.arch
......@@ -255,7 +257,7 @@ configure (pkg_descr0, pbi) cfg
_ -> return $ map setDepByVersion (buildDepends pkg_descr)
packageDependsIndex <-
case InstalledPackageIndex.dependencyClosure packageIndex dep_pkgs of
case PackageIndex.dependencyClosure packageIndex dep_pkgs of
Left packageDependsIndex -> return packageDependsIndex
Right broken ->
die $ "The following installed packages are broken because other"
......@@ -267,7 +269,7 @@ configure (pkg_descr0, pbi) cfg
++ intercalate ", " (map showPackageId deps)
| (pkg, deps) <- broken ]
case InstalledPackageIndex.dependencyInconsistencies
case PackageIndex.dependencyInconsistencies
packageDependsIndex (package pkg_descr) dep_pkgs of
[] -> return ()
inconsistencies ->
......@@ -390,7 +392,7 @@ hackageUrl :: String
hackageUrl = "http://hackage.haskell.org/cgi-bin/hackage-scripts/package/"
-- | Test for a package dependency and record the version we have installed.
configDependency :: Verbosity -> InstalledPackageIndex -> Dependency -> IO PackageIdentifier
configDependency :: Verbosity -> PackageIndex InstalledPackageInfo -> Dependency -> IO PackageIdentifier
configDependency verbosity index dep@(Dependency pkgname vrange) =
case satisfyDependency ps dep of
Nothing -> die $ "cannot satisfy dependency "
......@@ -402,10 +404,10 @@ configDependency verbosity index dep@(Dependency pkgname vrange) =
++ ": using " ++ showPackageId pkg
return pkg
where ps = map InstalledPackageInfo.package
(InstalledPackageIndex.allPackages index)
(PackageIndex.allPackages index)
getInstalledPackages :: Verbosity -> Compiler -> PackageDB -> ProgramConfiguration
-> IO (Maybe InstalledPackageIndex)
-> IO (Maybe (PackageIndex InstalledPackageInfo))
getInstalledPackages verbosity comp packageDb progconf = do
info verbosity "Reading installed packages..."
case compilerFlavor comp of
......
......@@ -58,8 +58,8 @@ import Distribution.PackageDescription
import Distribution.InstalledPackageInfo
( InstalledPackageInfo
, parseInstalledPackageInfo )
import Distribution.Simple.InstalledPackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.InstalledPackageIndex as InstalledPackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.ParseUtils ( ParseResult(..) )
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..) )
......@@ -253,13 +253,13 @@ oldLanguageExtensions =
fglasgowExts = "-fglasgow-exts"
getInstalledPackages :: Verbosity -> PackageDB -> ProgramConfiguration
-> IO InstalledPackageIndex
-> IO (PackageIndex InstalledPackageInfo)
getInstalledPackages verbosity packagedb conf = do
let packagedbs = case packagedb of
GlobalPackageDB -> [GlobalPackageDB]
_ -> [GlobalPackageDB, packagedb]
pkgss <- getInstalledPackages' verbosity packagedbs conf
return $ mconcat [ InstalledPackageIndex.fromList pkgs
return $ mconcat [ PackageIndex.fromList pkgs
| (_, pkgs) <- pkgss ]
-- | Get the packages from specific PackageDBs, not cumulative.
......
......@@ -70,7 +70,7 @@ import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplate,
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
import Distribution.Simple.BuildPaths ( distPref, haddockPref, haddockName,
hscolourPref, autogenModulesDir )
import qualified Distribution.Simple.InstalledPackageIndex as InstalledPackageIndex
import qualified Distribution.Simple.PackageIndex as PackageIndex
( lookupPackageId )
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
( InstalledPackageInfo_(..) )
......@@ -297,7 +297,7 @@ haddockPackageFlags lbi htmlTemplate = do
where
interfaceAndHtmlPath :: PackageIdentifier -> Maybe (FilePath, FilePath)
interfaceAndHtmlPath pkgId = do
pkg <- InstalledPackageIndex.lookupPackageId (installedPkgs lbi) pkgId
pkg <- PackageIndex.lookupPackageId (installedPkgs lbi) pkgId
interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)
html <- case htmlTemplate of
Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)
......
......@@ -50,11 +50,11 @@ import Distribution.PackageDescription as PD
Executable(..), withExe, Library(..),
libModules, hcOptions )
import Distribution.InstalledPackageInfo
( emptyInstalledPackageInfo )
( InstalledPackageInfo, emptyInstalledPackageInfo )
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
( InstalledPackageInfo_(package) )
import Distribution.Simple.InstalledPackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.InstalledPackageIndex as InstalledPackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..) )
import Distribution.Simple.BuildPaths
......@@ -109,11 +109,11 @@ jhcLanguageExtensions =
]
getInstalledPackages :: Verbosity -> PackageDB -> ProgramConfiguration
-> IO InstalledPackageIndex
-> IO (PackageIndex InstalledPackageInfo)
getInstalledPackages verbosity _packagedb conf = do
str <- rawSystemProgramStdoutConf verbosity jhcProgram conf ["--list-libraries"]
case pCheck (readP_to_S (many (skipSpaces >> parsePackageId)) str) of
[ps] -> return $ InstalledPackageIndex.fromList
[ps] -> return $ PackageIndex.fromList
[ emptyInstalledPackageInfo {
InstalledPackageInfo.package = p
}
......
......@@ -61,7 +61,8 @@ import Distribution.Simple.Program (ProgramConfiguration)
import Distribution.PackageDescription (PackageDescription(..))
import Distribution.Package (PackageIdentifier(..))
import Distribution.Simple.Compiler (Compiler(..), PackageDB)
import Distribution.Simple.InstalledPackageIndex (InstalledPackageIndex)
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
-- |Data cached after configuration step. See also
-- 'Distribution.Setup.ConfigFlags'.
......@@ -82,7 +83,7 @@ data LocalBuildInfo = LocalBuildInfo {
-- that must be satisfied in terms of version ranges. This
-- field fixes those dependencies to the specific versions
-- available on this machine for this compiler.
installedPkgs :: InstalledPackageIndex,
installedPkgs :: PackageIndex InstalledPackageInfo,
-- ^ All the info about all installed packages.
pkgDescrFile :: Maybe FilePath,
-- ^ the filename containing the .cabal file, if available
......
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.InstalledPackageIndex
-- Module : Distribution.Simple.PackageIndex
-- Copyright : (c) David Himmelstrup 2005,
-- Bjorn Bringert 2007,
-- Duncan Coutts 2008
......@@ -12,9 +12,12 @@
--
-- The index of 'InstalledPackageInfo'.
-----------------------------------------------------------------------------
module Distribution.Simple.InstalledPackageIndex (
-- * Local installed index data type
InstalledPackageIndex,
module Distribution.Simple.PackageIndex (
-- * Package classes
Package(..),
-- * Package index data type
PackageIndex,
-- * Creating the index
fromList,
......@@ -53,16 +56,37 @@ import Data.Maybe (isNothing)
import Distribution.Package (PackageIdentifier(..))
import Distribution.InstalledPackageInfo
( InstalledPackageInfo, InstalledPackageInfo_(..)
, emptyInstalledPackageInfo )
( InstalledPackageInfo, InstalledPackageInfo_, emptyInstalledPackageInfo )
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
( InstalledPackageInfo_(..) )
import Distribution.PackageDescription
( PackageDescription )
import qualified Distribution.PackageDescription as PackageDescription
( PackageDescription(..) )
import Distribution.Version (Version, Dependency(Dependency), withinRange)
import Distribution.Simple.Utils (lowercase, equating, comparing, isInfixOf)
-- | Class of things that can be identified by a 'PackageIdentifier'
--
-- Types in this class are all notions of a package. This allows us to have
-- different types for the different phases that packages go though, from
-- simple name\/id, package description, configured or installed packages.
--
class Package pkg where
packageId :: pkg -> PackageIdentifier
instance Package PackageIdentifier where
packageId = id
instance Package (InstalledPackageInfo_ str) where
packageId = InstalledPackageInfo.package
instance Package PackageDescription where
packageId = PackageDescription.package
-- | The collection of information about packages from one or more 'PackageDB's.
--
-- It can be searched effeciently by package name and version.
--
data InstalledPackageIndex = InstalledPackageIndex
data Package pkg => PackageIndex pkg = PackageIndex
-- This index maps lower case package names to all the
-- 'InstalledPackageInfo' records matching that package name
-- case-insensitively. It includes all versions.
......@@ -71,56 +95,56 @@ data InstalledPackageIndex = InstalledPackageIndex
-- all versions satisfying a dependency, all by varying how we filter. So
-- most queries will do a map lookup followed by a linear scan of the bucket.
--
(Map String [InstalledPackageInfo])
(Map String [pkg])
deriving (Show, Read)
instance Monoid InstalledPackageIndex where
mempty = InstalledPackageIndex (Map.empty)
instance Package pkg => Monoid (PackageIndex pkg) where
mempty = PackageIndex (Map.empty)
mappend = merge
--save one mappend with empty in the common case:
mconcat [] = mempty
mconcat xs = foldr1 mappend xs
invariant :: InstalledPackageIndex -> Bool
invariant (InstalledPackageIndex m) = all (uncurry goodBucket) (Map.toList m)
invariant :: Package pkg => PackageIndex pkg -> Bool
invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m)
where goodBucket name pkgs =
lowercase name == name
&& not (null pkgs)
&& all ((lowercase name==) . lowercase . pkgName . package) pkgs
&& all ((lowercase name==) . lowercase . pkgName . packageId) pkgs
-- && all (\pkg -> pkgInfoId pkg
-- == (package . packageDescription . pkgDesc) pkg) pkgs
&& distinct (map package pkgs)
-- == (packageId . packageDescription . pkgDesc) pkg) pkgs
&& distinct (map packageId pkgs)
distinct = all ((==1). length) . group . sort
internalError :: String -> a
internalError name = error ("InstalledPackageIndex." ++ name ++ ": internal error")
internalError name = error ("PackageIndex." ++ name ++ ": internal error")
-- | When building or merging we have to eliminate duplicates of the exact
-- same package name and version (case-sensitively) to preserve the invariant.
--
stripDups :: [InstalledPackageInfo] -> [InstalledPackageInfo]
stripDups = nubBy (equating package)
stripDups :: Package pkg => [pkg] -> [pkg]
stripDups = nubBy (equating packageId)
-- | Lookup a name in the index to get all packages that match that name
-- case-insensitively.
--
lookup :: InstalledPackageIndex -> String -> [InstalledPackageInfo]
lookup index@(InstalledPackageIndex m) name =
lookup :: Package pkg => PackageIndex pkg -> String -> [pkg]
lookup index@(PackageIndex m) name =
assert (invariant index) $
case Map.lookup (lowercase name) m of
Nothing -> []
Just pkgs -> pkgs
-- | Build an index out of a bunch of 'InstalledPackageInfo's.
-- | Build an index out of a bunch of 'Package's.
--
-- If there are duplicates, earlier ones mask later one.
--
fromList :: [InstalledPackageInfo] -> InstalledPackageIndex
fromList :: Package pkg => [pkg] -> PackageIndex pkg
fromList pkgs =
let index = (InstalledPackageIndex . Map.map stripDups . Map.fromListWith (++))
[ let key = (lowercase . pkgName . package) pkg
let index = (PackageIndex . Map.map stripDups . Map.fromListWith (++))
[ let key = (lowercase . pkgName . packageId) pkg
in (key, [pkg])
| pkg <- pkgs ]
in assert (invariant index) index
......@@ -130,28 +154,28 @@ fromList pkgs =
-- Packages from the first mask packages of the same exact name
-- (case-sensitively) from the second.
--
merge :: InstalledPackageIndex -> InstalledPackageIndex -> InstalledPackageIndex
merge i1@(InstalledPackageIndex m1) i2@(InstalledPackageIndex m2) =
merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg
merge i1@(PackageIndex m1) i2@(PackageIndex m2) =
assert (invariant i1 && invariant i2) $
let index = InstalledPackageIndex (Map.unionWith mergeBuckets m1 m2)
let index = PackageIndex (Map.unionWith mergeBuckets m1 m2)
in assert (invariant index) index
where mergeBuckets pkgs1 pkgs2 = stripDups (pkgs1 ++ pkgs2)
-- | Get all the packages from the index.
--
allPackages :: InstalledPackageIndex -> [InstalledPackageInfo]
allPackages (InstalledPackageIndex m) = concat (Map.elems m)
allPackages :: Package pkg => PackageIndex pkg -> [pkg]
allPackages (PackageIndex m) = concat (Map.elems m)
-- | Get all the packages from the index.
--
-- They are grouped by package name, case-sensitively.
--
allPackagesByName :: InstalledPackageIndex -> [[InstalledPackageInfo]]
allPackagesByName (InstalledPackageIndex m) = concatMap groupByName (Map.elems m)
where groupByName :: [InstalledPackageInfo] -> [[InstalledPackageInfo]]
groupByName = groupBy (equating (pkgName . package))
. sortBy (comparing (pkgName . package))
allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]]
allPackagesByName (PackageIndex m) = concatMap groupByName (Map.elems m)
where groupByName :: Package pkg => [pkg] -> [[pkg]]
groupByName = groupBy (equating (pkgName . packageId))
. sortBy (comparing (pkgName . packageId))
-- | Does a case-insensitive search by package name.
--
......@@ -165,14 +189,14 @@ allPackagesByName (InstalledPackageIndex m) = concatMap groupByName (Map.elems m
-- packages. The list of ambiguous results is split by exact package name. So
-- it is a non-empty list of non-empty lists.
--
searchByName :: InstalledPackageIndex -> String -> SearchResult [InstalledPackageInfo]
searchByName :: Package pkg => PackageIndex pkg -> String -> SearchResult [pkg]
searchByName index name =
case groupBy (equating (pkgName . package))
. sortBy (comparing (pkgName . package))
case groupBy (equating (pkgName . packageId))
. sortBy (comparing (pkgName . packageId))
$ lookup index name of
[] -> None
[pkgs] -> Unambiguous pkgs
pkgss -> case find ((name==) . pkgName . package . head) pkgss of
pkgss -> case find ((name==) . pkgName . packageId . head) pkgss of
Just pkgs -> Unambiguous pkgs
Nothing -> Ambiguous pkgss
......@@ -182,8 +206,8 @@ data SearchResult a = None | Unambiguous a | Ambiguous [a]
--
-- That is, all packages that contain the given string in their name.
--
searchByNameSubstring :: InstalledPackageIndex -> String -> [InstalledPackageInfo]
searchByNameSubstring (InstalledPackageIndex m) searchterm =
searchByNameSubstring :: Package pkg => PackageIndex pkg -> String -> [pkg]
searchByNameSubstring (PackageIndex m) searchterm =
[ pkg
| (name, pkgs) <- Map.toList m
, searchterm' `isInfixOf` name
......@@ -195,10 +219,10 @@ searchByNameSubstring (InstalledPackageIndex m) searchterm =
-- Since multiple package DBs mask each other case-sensitively by package name,
-- then we get back at most one package.
--
lookupPackageId :: InstalledPackageIndex -> PackageIdentifier -> Maybe InstalledPackageInfo
lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg
lookupPackageId index pkgid =
case [ pkg | pkg <- lookup index (pkgName pkgid)
, package pkg == pkgid ] of
, packageId pkg == pkgid ] of
[] -> Nothing
[pkg] -> Just pkg
_ -> internalError "lookupPackageIdentifier"
......@@ -208,9 +232,10 @@ lookupPackageId index pkgid =
-- We get back any number of versions of the specified package name, all
-- satisfying the version range constraint.
--
lookupDependency :: InstalledPackageIndex -> Dependency -> [InstalledPackageInfo]
lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg]
lookupDependency index (Dependency name versionRange) =
[ pkg | pkg@InstalledPackageInfo { package = pkgid } <- lookup index name
[ pkg | pkg <- lookup index name
, let pkgid = packageId pkg
, pkgName pkgid == name
, pkgVersion pkgid `withinRange` versionRange ]
......@@ -218,12 +243,12 @@ lookupDependency index (Dependency name versionRange) =
--
-- Returns such packages along with the depends that they're missing.
--
brokenPackages :: InstalledPackageIndex
brokenPackages :: PackageIndex InstalledPackageInfo
-> [(InstalledPackageInfo, [PackageIdentifier])]
brokenPackages index =
[ (pkg, missing)
| pkg <- allPackages index
, let missing = [ pkg' | pkg' <- depends pkg
, let missing = [ pkg' | pkg' <- InstalledPackageInfo.depends pkg
, isNothing (lookupPackageId index pkg') ]
, not (null missing) ]
......@@ -235,9 +260,9 @@ brokenPackages index =
-- * Note that if any of the result is @Right []@ it is because at least one of
-- the original given 'PackageIdentifier's do not occur in the index.
--
dependencyClosure :: InstalledPackageIndex
dependencyClosure :: PackageIndex InstalledPackageInfo
-> [PackageIdentifier]
-> Either InstalledPackageIndex
-> Either (PackageIndex InstalledPackageInfo)
[(InstalledPackageInfo, [PackageIdentifier])]
dependencyClosure index pkgids0 = case closure [] [] pkgids0 of
(completed, []) -> Left $ fromList completed
......@@ -252,10 +277,11 @@ dependencyClosure index pkgids0 = case closure [] [] pkgids0 of
closure completed failed (pkgid:pkgids) = case lookupPackageId index pkgid of
Nothing -> closure completed (pkgid:failed) pkgids
-- TODO: use more effecient test here:
Just pkg | package pkg `elem` map package completed
Just pkg | packageId pkg `elem` map packageId completed
-> closure completed failed pkgids
| otherwise
-> closure (pkg:completed) failed (depends pkg ++ pkgids)
-> closure (pkg:completed) failed pkgids'
where pkgids' = InstalledPackageInfo.depends pkg ++ pkgids
-- | 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
......@@ -267,7 +293,7 @@ dependencyClosure index pkgids0 = case closure [] [] pkgids0 of
-- depend on it and the versions they require. These are guaranteed to be
-- distinct.
--
dependencyInconsistencies :: InstalledPackageIndex
dependencyInconsistencies :: PackageIndex InstalledPackageInfo
-> PackageIdentifier -> [PackageIdentifier]
-> [(String, [(PackageIdentifier, Version)])]
dependencyInconsistencies index topPkg topDeps =
......@@ -277,13 +303,13 @@ dependencyInconsistencies index topPkg topDeps =
, not (null inconsistencies) ]
where pseudoTopPackage = emptyInstalledPackageInfo {
package = topPkg,
depends = topDeps
InstalledPackageInfo.package = topPkg,
InstalledPackageInfo.depends = topDeps
}
inverseIndex = Map.fromListWith (++)
[ (pkgName dep, [(package pkg, pkgVersion dep)])
[ (pkgName dep, [(InstalledPackageInfo.package pkg, pkgVersion dep)])
| pkg <- pseudoTopPackage : allPackages index
, dep <- depends pkg ]
, dep <- InstalledPackageInfo.depends pkg ]
duplicatesBy = (\groups -> if length groups == 1
then []
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment