Skip to content

Commit

Permalink
Rather than using brokenPackages from Cabal, just parse "ghc-pkg chec…
Browse files Browse the repository at this point in the history
…k --simple-output"

The rationale for this is that brokenPackages doesn't work for
packages that have include directories missing (e.g. dev-haskell/gtk,
but x11-libs/gtk+ gets upgraded).  "ghc-pkg check" already takes this
into account, so rather than trying to duplicate this functionality
just parse what it spits out.
  • Loading branch information
ivan-m committed Jul 29, 2010
1 parent 0f06128 commit d11a073
Showing 1 changed file with 20 additions and 27 deletions.
47 changes: 20 additions & 27 deletions Distribution/Gentoo/GHC.hs
Expand Up @@ -21,24 +21,16 @@ import Distribution.Gentoo.Util
import Distribution.Gentoo.Packages

-- Cabal imports
import Distribution.Simple.PackageIndex( PackageIndex
, brokenPackages
, reverseDependencyClosure)
import Distribution.Simple.GHC(getInstalledPackages, configure)
import Distribution.Simple.Program( ProgramConfiguration
, defaultProgramConfiguration)
import Distribution.Simple.Compiler(PackageDB(GlobalPackageDB))
import Distribution.Simple.Utils(rawSystemStdout)
import Distribution.Simple.Utils(rawSystemStdInOut)
import Distribution.Verbosity(silent)
import Distribution.Package(PackageIdentifier, packageId)
import Distribution.InstalledPackageInfo( InstalledPackageInfo_
, installedPackageId)
import Distribution.Text(display)
import Distribution.InstalledPackageInfo(InstalledPackageInfo_)
import Distribution.Text(display, simpleParse)

-- Other imports
import Data.Char(isDigit)
import Data.Either(partitionEithers)
import Data.Maybe(fromJust)
import Data.Maybe(fromJust, mapMaybe)
import qualified Data.Map as Map
import Data.Map(Map)
import qualified Data.ByteString.Char8 as BS
Expand All @@ -54,7 +46,11 @@ import Control.Monad(foldM, liftM, unless)

-- Get only the first line of output
rawSysStdOutLine :: FilePath -> [String] -> IO String
rawSysStdOutLine app = liftM (head . lines) . rawSystemStdout silent app
rawSysStdOutLine app = liftM (head . lines) . rawCommand app

rawCommand :: FilePath -> [String] -> IO String
rawCommand cmd args = do (out,_,_) <- rawSystemStdInOut silent cmd args Nothing False
return out

-- Get the first line of output from calling GHC with the given
-- arguments.
Expand All @@ -74,6 +70,14 @@ ghcVersion = liftM (dropWhile (not . isDigit)) $ ghcRawOut ["--version"]
ghcLibDir :: IO FilePath
ghcLibDir = canonicalizePath =<< ghcRawOut ["--print-libdir"]

ghcPkgRawOut :: [String] -> IO String
ghcPkgRawOut args = ghcPkgLoc >>= flip rawCommand args

-- Cheat with using fromJust since we know that ghc-pkg must be in $PATH
-- somewhere, probably /usr/bin.
ghcPkgLoc :: IO FilePath
ghcPkgLoc = liftM fromJust $ findExecutable "ghc-pkg"

-- Return the Gentoo .conf files found in this GHC libdir
confFiles :: FilePath -> IO [FilePath]
confFiles dir = do let gDir = dir </> "gentoo"
Expand Down Expand Up @@ -187,7 +191,7 @@ brokenPkgs = do putStrLn "Searching for Haskell libraries with broken dependenci

-- .conf files from broken packages of this GHC version
brokenConfs :: IO ([PackageIdentifier], [FilePath])
brokenConfs = do brkn <- getBroken
brokenConfs = do brkn <- getBroken -- getBroken
-- Check if we actually have to go look up files and
-- do IO.
if null brkn
Expand Down Expand Up @@ -219,23 +223,12 @@ addConf cmp conf = do cnts <- readFile conf
[([],_)] -> return cmp
rd -> do let nm = cfNm rd
return $ Map.insert nm conf cmp

where
-- It's not InstalledPackageInfo, as it can't read the modules
cfNm :: [([InstalledPackageInfo_ String], String)] -> PackageIdentifier
cfNm = packageId . head . fst . head

-- Obtain GHC info about installed libs, etc.
configureGHC :: IO ProgramConfiguration
configureGHC = liftM snd
$ configure silent Nothing Nothing defaultProgramConfiguration

-- Return all packages registered with GHC
pkgIndex :: IO PackageIndex
pkgIndex = configureGHC >>= getInstalledPackages silent [GlobalPackageDB]

-- Return the closure of all packages affected by breakage
getBroken :: IO [PackageIdentifier]
getBroken = do ind <- pkgIndex
let broken = map (installedPackageId . fst) $ brokenPackages ind
return $ map packageId $ reverseDependencyClosure ind broken
getBroken = liftM (mapMaybe simpleParse . words)
$ ghcPkgRawOut ["check", "--simple-output"]

0 comments on commit d11a073

Please sign in to comment.