Commit f996c255 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

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.
parent f1d73cac
......@@ -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 = "",
......
......@@ -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
......
......@@ -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
......
......@@ -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]
......
......@@ -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]
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