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.

Cabal.cabal

@@ -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,

Distribution/Simple/Configure.hs

@@ -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

Distribution/Simple/GHC.hs

@@ -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.
 --

Distribution/Simple/InstalledPackageIndex.hs

+-----------------------------------------------------------------------------
+-- |
+-- 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 ]

Distribution/Simple/JHC.hs

@@ -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 ]

Distribution/Simple/SetupWrapper.hs

@@ -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]