[commit: packages/Cabal] ghc-head: Add a function for reading the contents of a single package DB. (b90107d)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/Cabal

On branch  : ghc-head
Link       : http://git.haskell.org/?p=packages/Cabal.git;a=commit;h=b90107d4fe603de0f5895cf0fdf9cba0fa8a7a28

>---------------------------------------------------------------

commit b90107d4fe603de0f5895cf0fdf9cba0fa8a7a28
Author: Mikhail Glushenkov <mikhail.glushenkov at gmail.com>
Date:   Tue May 14 23:36:33 2013 +0200

    Add a function for reading the contents of a single package DB.
    
    'getInstalledPackages' requires to pass in a 'PackageDBStack'.


>---------------------------------------------------------------

b90107d4fe603de0f5895cf0fdf9cba0fa8a7a28
 Cabal/Distribution/Simple/Configure.hs |   15 +++++++++++-
 Cabal/Distribution/Simple/GHC.hs       |   41 +++++++++++++++++++++++---------
 2 files changed, 44 insertions(+), 12 deletions(-)

diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs
index 0a8ac5d..8ec8f20 100644
--- a/Cabal/Distribution/Simple/Configure.hs
+++ b/Cabal/Distribution/Simple/Configure.hs
@@ -57,7 +57,7 @@ module Distribution.Simple.Configure (configure,
                                       tryGetPersistBuildConfig,
                                       maybeGetPersistBuildConfig,
                                       localBuildInfoFile,
-                                      getInstalledPackages,
+                                      getInstalledPackages, getPackageDBContents,
                                       configCompiler, configCompilerAux,
                                       ccLdOptionsBuildInfo,
                                       checkForeignDeps,
@@ -690,6 +690,19 @@ getInstalledPackages verbosity comp packageDBs progconf = do
     flv -> die $ "don't know how to find the installed packages for "
               ++ display flv
 
+-- | Like 'getInstalledPackages', but for a single package DB.
+getPackageDBContents :: Verbosity -> Compiler
+                     -> PackageDB -> ProgramConfiguration
+                     -> IO PackageIndex
+getPackageDBContents verbosity comp packageDB progconf = do
+  info verbosity "Reading installed packages..."
+  case compilerFlavor comp of
+    GHC -> GHC.getPackageDBContents verbosity packageDB progconf
+
+    -- For other compilers, try to fall back on 'getInstalledPackages'.
+    _   -> getInstalledPackages verbosity comp [packageDB] progconf
+
+
 -- | The user interface specifies the package dbs to use with a combination of
 -- @--global@, @--user@ and @--package-db=global|user|clear|$file at .
 -- This function combines the global/user flag and interprets the package-db
diff --git a/Cabal/Distribution/Simple/GHC.hs b/Cabal/Distribution/Simple/GHC.hs
index 40daf56..939715b 100644
--- a/Cabal/Distribution/Simple/GHC.hs
+++ b/Cabal/Distribution/Simple/GHC.hs
@@ -62,7 +62,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
 
 module Distribution.Simple.GHC (
         getGhcInfo,
-        configure, getInstalledPackages,
+        configure, getInstalledPackages, getPackageDBContents,
         buildLib, buildExe,
         installLib, installExe,
         libAbiHash,
@@ -488,24 +488,24 @@ oldLanguageExtensions =
     ,(DeriveDataTypeable         , fglasgowExts)
     ,(ConstrainedClassMethods    , fglasgowExts)
     ]
-
+-- | Given a single package DB, return all installed packages.
+getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration
+                        -> IO PackageIndex
+getPackageDBContents verbosity packagedb conf = do
+  pkgss <- getInstalledPackages' verbosity [packagedb] conf
+  toPackageIndex verbosity pkgss conf
+
+-- | Given a package DB stack, return all installed packages.
 getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration
                      -> IO PackageIndex
 getInstalledPackages verbosity packagedbs conf = do
   checkPackageDbEnvVar
   checkPackageDbStack packagedbs
   pkgss <- getInstalledPackages' verbosity packagedbs conf
-  topDir <- ghcLibDir' verbosity ghcProg
-  let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)
-                | (_, pkgs) <- pkgss ]
-  return $! hackRtsPackage (mconcat indexes)
+  index <- toPackageIndex verbosity pkgss conf
+  return $! hackRtsPackage index
 
   where
-    -- On Windows, various fields have $topdir/foo rather than full
-    -- paths. We need to substitute the right value in so that when
-    -- we, for example, call gcc, we have proper paths to give it
-    Just ghcProg = lookupProgram ghcProgram conf
-
     hackRtsPackage index =
       case PackageIndex.lookupPackageName index (PackageName "rts") of
         [(_,[rts])]
@@ -513,6 +513,25 @@ getInstalledPackages verbosity packagedbs conf = do
         _  -> index -- No (or multiple) ghc rts package is registered!!
                     -- Feh, whatever, the ghc testsuite does some crazy stuff.
 
+-- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a
+-- @PackageIndex at . Helper function used by 'getPackageDBContents' and
+-- 'getInstalledPackages'.
+toPackageIndex :: Verbosity
+               -> [(PackageDB, [InstalledPackageInfo])]
+               -> ProgramConfiguration
+               -> IO PackageIndex
+toPackageIndex verbosity pkgss conf = do
+  -- On Windows, various fields have $topdir/foo rather than full
+  -- paths. We need to substitute the right value in so that when
+  -- we, for example, call gcc, we have proper paths to give it.
+  topDir <- ghcLibDir' verbosity ghcProg
+  let indices = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)
+                | (_, pkgs) <- pkgss ]
+  return $! (mconcat indices)
+
+  where
+    Just ghcProg = lookupProgram ghcProgram conf
+
 ghcLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath
 ghcLibDir verbosity lbi =
     (reverse . dropWhile isSpace . reverse) `fmap`