getInstalledPackages now returns full InstalledPackageInfo

rather than just PackageIdentifier. This will enable us to do lots more in
future, for example detecting inconsistent package depends, doing our
own cpp pre-processing or module chasing.

Distribution/InstalledPackageInfo.hs

@@ -73,7 +73,7 @@ import Text.PrettyPrint
 -- The InstalledPackageInfo type
 
 data InstalledPackageInfo_ m
-   = InstalledPackageInfo_ {
+   = InstalledPackageInfo {
 	-- these parts are exactly the same as PackageDescription
 	package           :: PackageIdentifier,
         license           :: License,
@@ -111,7 +111,7 @@ type InstalledPackageInfo = InstalledPackageInfo_ String
 
 emptyInstalledPackageInfo :: InstalledPackageInfo_ m
 emptyInstalledPackageInfo
-   = InstalledPackageInfo_ {
+   = InstalledPackageInfo {
         package           = PackageIdentifier "" noVersion,
         license           = AllRightsReserved,
         copyright         = "",

Distribution/Simple/Configure.hs

@@ -59,6 +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 Distribution.PackageDescription
     ( PackageDescription(..), GenericPackageDescription(..)
     , Library(..), hasLibs, Executable(..), BuildInfo(..)
@@ -112,7 +116,7 @@ import Data.Char
 import Data.List
     ( intersperse, nub, partition, isPrefixOf )
 import Data.Maybe
-    ( fromMaybe, isNothing )
+    ( isNothing )
 import System.Directory
     ( doesFileExist, getModificationTime, createDirectoryIfMissing )
 import System.Exit
@@ -220,7 +224,7 @@ configure (pkg_descr0, pbi) cfg
             Left ppd -> 
                 case finalizePackageDescription 
                        (configConfigurationsFlags cfg)
-                       mipkgs
+                       (fmap (map InstalledPackageInfo.package) mipkgs)
                        System.Info.os
                        System.Info.arch
                        (map toLower (show flavor),version)
@@ -239,7 +243,8 @@ configure (pkg_descr0, pbi) cfg
 
         checkPackageProblems verbosity (updatePackageDescription pbi pkg_descr)
 
-        let ipkgs = fromMaybe (map setDepByVersion (buildDepends pkg_descr)) mipkgs 
+        let ipkgs = maybe (map setDepByVersion (buildDepends pkg_descr))
+                          (map InstalledPackageInfo.package) mipkgs
 
         dep_pkgs <- case flavor of
                       GHC | version >= Version [6,3] [] -> do
@@ -373,7 +378,7 @@ configDependency verbosity ps dep@(Dependency pkgname vrange) =
                        return pkg
 
 getInstalledPackages :: Verbosity -> Compiler -> PackageDB -> ProgramConfiguration
-                     -> IO (Maybe [PackageIdentifier])
+                     -> IO (Maybe [InstalledPackageInfo])
 getInstalledPackages verbosity comp packageDb progconf = do
   info verbosity "Reading installed packages..."
   case compilerFlavor comp of

Distribution/Simple/GHC.hs

@@ -55,12 +55,15 @@ import Distribution.PackageDescription
 				  withLib,
 				  Executable(..), withExe, Library(..),
 				  libModules, hcOptions )
+import Distribution.InstalledPackageInfo
+                                ( InstalledPackageInfo
+                                , parseInstalledPackageInfo )
+import Distribution.ParseUtils  ( ParseResult(..) )
 import Distribution.Simple.LocalBuildInfo
 				( LocalBuildInfo(..) )
 import Distribution.Simple.BuildPaths
 import Distribution.Simple.Utils
-import Distribution.Package  	( PackageIdentifier(..), showPackageId,
-                                  parsePackageId )
+import Distribution.Package  	( PackageIdentifier(..), showPackageId )
 import Distribution.Simple.Program ( rawSystemProgram, rawSystemProgramConf,
 				  rawSystemProgramStdoutConf,
                                   rawSystemProgramStdout,
@@ -76,12 +79,10 @@ import Distribution.Version	( Version(..), showVersion,
 import Distribution.System
 import Distribution.Verbosity
 import Language.Haskell.Extension (Extension(..))
-import Distribution.Compat.ReadP
-    ( readP_to_S, many, skipSpaces )
 
 import Control.Monad		( unless, when )
 import Data.Char
-import Data.List		( nub, isPrefixOf )
+import Data.List		( nub )
 import Data.Maybe               ( catMaybes )
 import System.Directory		( removeFile, renameFile,
 				  getDirectoryContents, doesFileExist,
@@ -249,48 +250,62 @@ oldLanguageExtensions =
       fglasgowExts = "-fglasgow-exts"
 
 getInstalledPackages :: Verbosity -> PackageDB -> ProgramConfiguration
-                     -> IO [PackageIdentifier]
+                     -> IO [InstalledPackageInfo]
 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 ]
 
-   str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf $
-              ["list"]
-	    ++ (if useSimpleOutput then ["--simple-output"] else [])
-	    ++ packageDbGhcPkgFlag packagedb
-   case parse (munge str) of
-     [ps] -> return ps
-     _    -> die "cannot parse ghc package list"
-  where
-    useSimpleOutput = ghcVersion >= Version [6,9] []
-      where Just ghcProg = lookupProgram ghcProgram conf
-            Just ghcVersion = programVersion ghcProg
-
-    packageDbGhcPkgFlag GlobalPackageDB          = ["--global"]
-    packageDbGhcPkgFlag UserPackageDB            = ["--global", "--user"]
-    packageDbGhcPkgFlag (SpecificPackageDB path) = ["--global",
-                                                    "--package-conf=" ++ path]
-    parse = pCheck . readP_to_S (many (skipSpaces >> parsePackageId))
-    pCheck rs = [ r | (r,s) <- rs, all isSpace s ]
-
-    munge | useSimpleOutput = id
-
-    -- All the remaining nonsense is to deal with having to parse the
-    -- human-readable output of ghc-pkg rather than the --simple-output.
-    -- This was necessary in ghc-6.8 and before because previously we
-    -- could not specify with --simple-output exactly which package dbs
-    -- to query so the global and user were mixed up together.
-
-          | otherwise = case packagedb of
-              GlobalPackageDB -> stripFluff . firstFile
-              _               -> stripFluff . allFiles
-
-    stripFluff = filter (`notElem` ",(){}")
-
-    allFiles str = unlines $ filter keep_line $ lines str
-        where keep_line s = ':' `notElem` s && not ("Creating" `isPrefixOf` s)
+-- | Get the packages from specific PackageDBs, not cumulative.
+--
+getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration
+                     -> IO [(PackageDB, [InstalledPackageInfo])]
+getInstalledPackages' verbosity packagedbs conf
+  | ghcVersion >= Version [6,9] [] =
+  sequence
+    [ do str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf
+                  ["describe", "*", packageDbGhcPkgFlag packagedb]
+         case parsePackages str of
+	   Left ok -> return (packagedb, ok)
+	   _       -> die "failed to parse output of 'ghc-pkg describe *'"
+    | packagedb <- packagedbs ]
 
-    firstFile str = unlines $ takeWhile (not . file_line) $
-                    drop 1 $ dropWhile (not . file_line) $ lines str
-        where file_line s = ':' `elem` s && not ("Creating" `isPrefixOf` s)
+  where
+    parsePackages str =
+      let parsed = map parseInstalledPackageInfo (splitPkgs str)
+       in case [ msg | ParseFailed msg <- parsed ] of
+            []   -> Left [ pkg | ParseOk _ pkg <- parsed ]
+            msgs -> Right msgs
+
+    Just ghcProg = lookupProgram ghcProgram conf
+    Just ghcVersion = programVersion ghcProg
+
+    splitPkgs :: String -> [String]
+    splitPkgs = map unlines . split [] . lines
+      where split  [] [] = []
+            split acc [] = [reverse acc]
+            split acc (l@('n':'a':'m':'e':':':_):ls)
+              | null acc     =               split (l:[])  ls
+              | otherwise    = reverse acc : split (l:[])  ls
+            split acc (l:ls) =               split (l:acc) ls
+
+    packageDbGhcPkgFlag GlobalPackageDB          = "--global"
+    packageDbGhcPkgFlag UserPackageDB            = "--user"
+    packageDbGhcPkgFlag (SpecificPackageDB path) = "--package-conf=" ++ path
+
+getInstalledPackages' verbosity packagedbs conf = do
+    str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf ["list"]
+    let pkgFiles = [ init line | line <- lines str, last line == ':' ]
+        dbFile packagedb = case (packagedb, pkgFiles) of
+          (GlobalPackageDB, global:_)      -> Just global
+          (UserPackageDB,  _global:user:_) -> Just user
+          (UserPackageDB,  _global:_)      -> Nothing
+          (SpecificPackageDB specific, _)  -> Just specific
+          _ -> error "cannot read ghc-pkg global package file"
+    sequence [ readFile file >>= \content -> return (db, read content)
+             | (db , Just file) <- zip packagedbs (map dbFile packagedbs) ]
 
 -- -----------------------------------------------------------------------------
 -- Building

Distribution/Simple/JHC.hs

@@ -49,6 +49,11 @@ import Distribution.PackageDescription
 				  withLib,
 				  Executable(..), withExe, Library(..),
 				  libModules, hcOptions )
+import Distribution.InstalledPackageInfo
+				( InstalledPackageInfo, 
+                                  emptyInstalledPackageInfo )
+import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
+				( InstalledPackageInfo_(package) )
 import Distribution.Simple.LocalBuildInfo
 				( LocalBuildInfo(..) )
 import Distribution.Simple.BuildPaths
@@ -103,11 +108,14 @@ jhcLanguageExtensions =
     ]
 
 getInstalledPackages :: Verbosity -> PackageDB -> ProgramConfiguration
-                    -> IO [PackageIdentifier]
+                    -> IO [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 ps
+     [ps] -> return [ emptyInstalledPackageInfo {
+                        InstalledPackageInfo.package = p
+                      }
+                    | p <- ps ]
      _    -> die "cannot parse package list"
   where
     pCheck :: [(a, [Char])] -> [a]

Distribution/Simple/SetupWrapper.hs

@@ -23,6 +23,7 @@ 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,
@@ -156,7 +157,7 @@ configCabalFlag :: Verbosity -> VersionRange -> Compiler -> ProgramConfiguration
 configCabalFlag _ AnyVersion _ _ = return []
 configCabalFlag verbosity range comp conf = do
   ipkgs <-  getInstalledPackages verbosity comp UserPackageDB conf
-            >>= return . fromMaybe []
+            >>= return . maybe [] (map InstalledPackageInfo.package)
 	-- user packages are *allowed* here, no portability problem
   cabal_pkgid <- configDependency verbosity ipkgs (Dependency "Cabal" range)
   return ["-package", showPackageId cabal_pkgid]