Commit 383b5088 authored by Duncan Coutts's avatar Duncan Coutts

Add InstalledPackageIndex type and use it in place of [InstalledPackageInfo]

The new index module is adapted from the similar module in cabal-install but
with renamed functions and extended to work with full InstalledPackageInfo
rather than just PackageIdentifier. So the getInstalledPackages functions now
return an InstalledPackageIndex.
parent 82f63b8a
......@@ -65,6 +65,7 @@ Library
Distribution.Simple.Hugs,
Distribution.Simple.Install,
Distribution.Simple.InstallDirs,
Distribution.Simple.InstalledPackageIndex,
Distribution.Simple.JHC,
Distribution.Simple.LocalBuildInfo,
Distribution.Simple.NHC,
......
......@@ -59,10 +59,10 @@ 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 Distribution.PackageDescription
( PackageDescription(..), GenericPackageDescription(..)
, Library(..), hasLibs, Executable(..), BuildInfo(..)
......@@ -117,7 +117,9 @@ import Data.Char
import Data.List
( intersperse, nub, partition, isPrefixOf )
import Data.Maybe
( isNothing )
( fromMaybe, isNothing )
import Data.Monoid
( Monoid(mempty) )
import System.Directory
( doesFileExist, getModificationTime, createDirectoryIfMissing )
import System.Exit
......@@ -218,14 +220,17 @@ configure (pkg_descr0, pbi) cfg
flavor = compilerFlavor comp
-- FIXME: currently only GHC has hc-pkg
mipkgs <- getInstalledPackages (lessVerbose verbosity) comp
packageDb programsConfig'
maybePackageIndex <- getInstalledPackages (lessVerbose verbosity) comp
packageDb programsConfig'
let packageIndex = fromMaybe mempty maybePackageIndex
(pkg_descr, flags) <- case pkg_descr0 of
Left ppd ->
case finalizePackageDescription
(configConfigurationsFlags cfg)
(fmap (map InstalledPackageInfo.package) mipkgs)
(fmap (map InstalledPackageInfo.package
. InstalledPackageIndex.allPackages)
maybePackageIndex)
System.Info.os
System.Info.arch
(map toLower (show flavor),version)
......@@ -244,12 +249,9 @@ configure (pkg_descr0, pbi) cfg
checkPackageProblems verbosity (updatePackageDescription pbi pkg_descr)
let ipkgs = maybe (map setDepByVersion (buildDepends pkg_descr))
(map InstalledPackageInfo.package) mipkgs
dep_pkgs <- case flavor of
GHC -> mapM (configDependency verbosity ipkgs) (buildDepends pkg_descr)
JHC -> mapM (configDependency verbosity ipkgs) (buildDepends pkg_descr)
GHC -> mapM (configDependency verbosity packageIndex) (buildDepends pkg_descr)
JHC -> mapM (configDependency verbosity packageIndex) (buildDepends pkg_descr)
_ -> return $ map setDepByVersion (buildDepends pkg_descr)
......@@ -363,8 +365,8 @@ 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 -> [PackageIdentifier] -> Dependency -> IO PackageIdentifier
configDependency verbosity ps dep@(Dependency pkgname vrange) =
configDependency :: Verbosity -> InstalledPackageIndex -> Dependency -> IO PackageIdentifier
configDependency verbosity index dep@(Dependency pkgname vrange) =
case satisfyDependency ps dep of
Nothing -> die $ "cannot satisfy dependency "
++ pkgname ++ showVersionRange vrange ++ "\n"
......@@ -374,9 +376,11 @@ configDependency verbosity ps dep@(Dependency pkgname vrange) =
++ showVersionRange vrange
++ ": using " ++ showPackageId pkg
return pkg
where ps = map InstalledPackageInfo.package
(InstalledPackageIndex.allPackages index)
getInstalledPackages :: Verbosity -> Compiler -> PackageDB -> ProgramConfiguration
-> IO (Maybe [InstalledPackageInfo])
-> IO (Maybe InstalledPackageIndex)
getInstalledPackages verbosity comp packageDb progconf = do
info verbosity "Reading installed packages..."
case compilerFlavor comp of
......
......@@ -58,6 +58,8 @@ import Distribution.PackageDescription
import Distribution.InstalledPackageInfo
( InstalledPackageInfo
, parseInstalledPackageInfo )
import Distribution.Simple.InstalledPackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.InstalledPackageIndex as InstalledPackageIndex
import Distribution.ParseUtils ( ParseResult(..) )
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..) )
......@@ -84,6 +86,7 @@ import Control.Monad ( unless, when )
import Data.Char
import Data.List ( nub )
import Data.Maybe ( catMaybes )
import Data.Monoid ( Monoid(mconcat) )
import System.Directory ( removeFile, renameFile,
getDirectoryContents, doesFileExist,
getTemporaryDirectory )
......@@ -250,13 +253,14 @@ oldLanguageExtensions =
fglasgowExts = "-fglasgow-exts"
getInstalledPackages :: Verbosity -> PackageDB -> ProgramConfiguration
-> IO [InstalledPackageInfo]
-> IO InstalledPackageIndex
getInstalledPackages verbosity packagedb conf = do
let packagedbs = case packagedb of
GlobalPackageDB -> [GlobalPackageDB]
_ -> [GlobalPackageDB, packagedb]
pkgss <- getInstalledPackages' verbosity packagedbs conf
return [ pkg | (_, pkgs) <- pkgss, pkg <- pkgs ]
return $ mconcat [ InstalledPackageIndex.fromList pkgs
| (_, pkgs) <- pkgss ]
-- | Get the packages from specific PackageDBs, not cumulative.
--
......
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.InstalledPackageIndex
-- Copyright : (c) David Himmelstrup 2005,
-- Bjorn Bringert 2007,
-- Duncan Coutts 2008
-- License : BSD-like
--
-- Maintainer : Duncan Coutts <duncan@haskell.org>
-- Stability : provisional
-- Portability : portable
--
-- The index of 'InstalledPackageInfo'.
-----------------------------------------------------------------------------
module Distribution.Simple.InstalledPackageIndex (
-- * Local installed index data type
InstalledPackageIndex,
-- * Creating the index
fromList,
-- * Merging indexes
merge,
-- * Queries
-- ** Precise lookups
lookupPackageId,
lookupDependency,
-- ** Case-insensitive searches
searchByName,
SearchResult(..),
searchByNameSubstring,
-- ** Bulk queries
allPackages,
allPackagesByName,
) where
import Prelude hiding (lookup)
import Control.Exception (assert)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.List (nubBy, group, sort, groupBy, sortBy, find)
import Data.Monoid (Monoid(..))
import Distribution.Package (PackageIdentifier(..))
import Distribution.InstalledPackageInfo
(InstalledPackageInfo, InstalledPackageInfo_(..))
import Distribution.Version (Dependency(Dependency), withinRange)
import Distribution.Simple.Utils (lowercase, equating, comparing, isInfixOf)
-- | 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
-- | This index maps lower case package names to all the
-- 'InstalledPackageInfo' records matching that package name
-- case-insensitively. It includes all versions.
--
-- This allows us to do case sensitive or insensitive lookups, and to find
-- 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])
deriving (Show, Read)
instance Monoid InstalledPackageIndex where
mempty = InstalledPackageIndex (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)
where goodBucket name pkgs =
lowercase name == name
&& not (null pkgs)
&& all ((lowercase name==) . lowercase . pkgName . package) pkgs
-- && all (\pkg -> pkgInfoId pkg
-- == (package . packageDescription . pkgDesc) pkg) pkgs
&& distinct (map package pkgs)
distinct = all ((==1). length) . group . sort
internalError :: String -> a
internalError name = error ("InstalledPackageIndex." ++ 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)
-- | 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 =
assert (invariant index) $
case Map.lookup (lowercase name) m of
Nothing -> []
Just pkgs -> pkgs
-- | Build an index out of a bunch of 'InstalledPackageInfo's.
--
-- If there are duplicates, earlier ones mask later one.
--
fromList :: [InstalledPackageInfo] -> InstalledPackageIndex
fromList pkgs =
let index = (InstalledPackageIndex . Map.map stripDups . Map.fromListWith (++))
[ let key = (lowercase . pkgName . package) pkg
in (key, [pkg])
| pkg <- pkgs ]
in assert (invariant index) index
-- | Merge two indexes.
--
-- 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) =
assert (invariant i1 && invariant i2) $
let index = InstalledPackageIndex (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)
-- | 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))
-- | Does a case-insensitive search by package name.
--
-- If there is only one package that compares case-insentiviely to this name
-- then the search is unambiguous and we get back all versions of that package.
-- If several match case-insentiviely but one matches exactly then it is also
-- unambiguous.
--
-- If however several match case-insentiviely 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 :: InstalledPackageIndex -> String -> SearchResult [InstalledPackageInfo]
searchByName index name =
case groupBy (equating (pkgName . package))
. sortBy (comparing (pkgName . package))
$ lookup index name of
[] -> None
[pkgs] -> Unambiguous pkgs
pkgss -> case find ((name==) . pkgName . package . head) pkgss of
Just pkgs -> Unambiguous pkgs
Nothing -> Ambiguous pkgss
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 :: InstalledPackageIndex -> String -> [InstalledPackageInfo]
searchByNameSubstring (InstalledPackageIndex m) searchterm =
[ pkg
| (name, pkgs) <- Map.toList m
, searchterm' `isInfixOf` name
, pkg <- pkgs ]
where searchterm' = lowercase searchterm
-- | Does a lookup by package id (name & version).
--
-- 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 index pkgid =
case [ pkg | pkg <- lookup index (pkgName pkgid)
, package pkg == pkgid ] of
[] -> Nothing
[pkg] -> Just pkg
_ -> internalError "lookupPackageIdentifier"
-- | Does a case-sensitive search by 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 :: InstalledPackageIndex -> Dependency -> [InstalledPackageInfo]
lookupDependency index (Dependency name versionRange) =
[ pkg | pkg@InstalledPackageInfo { package = pkgid } <- lookup index name
, pkgName pkgid == name
, pkgVersion pkgid `withinRange` versionRange ]
......@@ -50,10 +50,11 @@ import Distribution.PackageDescription
Executable(..), withExe, Library(..),
libModules, hcOptions )
import Distribution.InstalledPackageInfo
( InstalledPackageInfo,
emptyInstalledPackageInfo )
( emptyInstalledPackageInfo )
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
( InstalledPackageInfo_(package) )
import Distribution.Simple.InstalledPackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.InstalledPackageIndex as InstalledPackageIndex
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..) )
import Distribution.Simple.BuildPaths
......@@ -108,11 +109,12 @@ jhcLanguageExtensions =
]
getInstalledPackages :: Verbosity -> PackageDB -> ProgramConfiguration
-> IO [InstalledPackageInfo]
-> IO InstalledPackageIndex
getInstalledPackages verbosity _packagedb conf = do
str <- rawSystemProgramStdoutConf verbosity jhcProgram conf ["--list-libraries"]
case pCheck (readP_to_S (many (skipSpaces >> parsePackageId)) str) of
[ps] -> return [ emptyInstalledPackageInfo {
[ps] -> return $ InstalledPackageIndex.fromList
[ emptyInstalledPackageInfo {
InstalledPackageInfo.package = p
}
| p <- ps ]
......
......@@ -23,7 +23,6 @@ import Distribution.Simple.Configure
configDependency )
import Distribution.PackageDescription
( PackageDescription(..), GenericPackageDescription(..), BuildType(..) )
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
import Distribution.PackageDescription.Parse ( readPackageDescription )
import Distribution.Simple.BuildPaths ( distPref, exeExtension )
import Distribution.Simple.Program ( ProgramConfiguration,
......@@ -37,6 +36,7 @@ import Distribution.Verbosity
import System.FilePath ((</>), (<.>))
import Control.Monad ( when, unless )
import Data.Maybe ( fromMaybe )
import Data.Monoid ( Monoid(mempty) )
-- read the .cabal file
-- - attempt to find the version of Cabal required
......@@ -156,8 +156,8 @@ opts = [
configCabalFlag :: Verbosity -> VersionRange -> Compiler -> ProgramConfiguration -> IO [String]
configCabalFlag _ AnyVersion _ _ = return []
configCabalFlag verbosity range comp conf = do
ipkgs <- getInstalledPackages verbosity comp UserPackageDB conf
>>= return . maybe [] (map InstalledPackageInfo.package)
packageIndex <- fromMaybe mempty
`fmap` getInstalledPackages verbosity comp UserPackageDB conf
-- user packages are *allowed* here, no portability problem
cabal_pkgid <- configDependency verbosity ipkgs (Dependency "Cabal" range)
cabal_pkgid <- configDependency verbosity packageIndex (Dependency "Cabal" range)
return ["-package", showPackageId cabal_pkgid]
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