Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Add an --all option to GHC
Rebuilds all libraries installed with the current version of GHC
  • Loading branch information
ivan-m committed Jul 31, 2010
1 parent c327153 commit 38db99c
Show file tree
Hide file tree
Showing 2 changed files with 76 additions and 55 deletions.
119 changes: 67 additions & 52 deletions Distribution/Gentoo/GHC.hs
Expand Up @@ -15,6 +15,7 @@ module Distribution.Gentoo.GHC
, libFronts
, oldGhcPkgs
, brokenPkgs
, allInstalledPackages
) where

import Distribution.Gentoo.Util
Expand Down Expand Up @@ -107,6 +108,63 @@ printList f = mapM_ (putStrLn . (++) " * " . f)
tryMaybe :: (a -> Maybe b) -> a -> Either a b
tryMaybe f a = maybe (Left a) Right $ f a


type ConfMap = Map PackageIdentifier FilePath

-- Attempt to match the provided broken package to one of the
-- installed packages.
matchConf :: ConfMap -> PackageIdentifier -> Either PackageIdentifier FilePath
matchConf = tryMaybe . flip Map.lookup

-- Read in all Gentoo .conf files from the current GHC version and
-- create a Map
readConf :: IO ConfMap
readConf = ghcLibDir >>= confFiles >>= foldM addConf Map.empty

-- Add this .conf file to the Map
addConf :: ConfMap -> FilePath -> IO ConfMap
addConf cmp conf = do cnts <- readFile conf
case (reads cnts) of
[] -> return cmp
-- ebuilds that have CABAL_CORE_LIB_GHC_PV set
-- for this version of GHC will have a .conf
-- file containing just []
[([],_)] -> 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

checkPkgs :: String -> String -> ([PackageIdentifier], [FilePath])
-> IO [Package]
checkPkgs msg typ (pns,cnfs)
= do putStrLn $ "Searching for " ++ msg ++ "."
-- (pns, cnfs) <- brokenConfs
unless (null pns)
$ unknownPackages pns
(nI, pkgs) <- liftM partitionEithers $ mapM hasFile' cnfs
unless (null nI)
$ unknownFiles nI
let pkgs' = notGHC pkgs
pkgListPrint typ pkgs'
return pkgs
where
hasFile' f = do mp <- hasFile f
return $ maybe (Left f) Right mp

unknownPackages ps
= do putStrLn "\nThe following packages don't seem \
\to have been installed by your package manager:"
printList display ps

unknownFiles fs
= do putStrLn "\nThe following files are those corresponding \
\to packages installed by your package manager\n\
\which can't be matched up to the packages that own them."
printList id fs

-- -----------------------------------------------------------------------------

-- Finding packages installed with other versions of GHC
Expand Down Expand Up @@ -164,30 +222,8 @@ libFronts = map BS.pack

-- Finding broken packages in this install of GHC.
brokenPkgs :: IO [Package]
brokenPkgs = do putStrLn "Searching for Haskell libraries with broken dependencies."
(pns, cnfs) <- brokenConfs
unless (null pns)
$ unknownPackages pns
(nI, pkgs) <- liftM partitionEithers $ mapM hasFile' cnfs
unless (null nI)
$ unknownFiles nI
let pkgs' = notGHC pkgs
pkgListPrint "broken" pkgs'
return pkgs
where
hasFile' f = do mp <- hasFile f
return $ maybe (Left f) Right mp

unknownPackages ps
= do putStrLn "\nThe following packages don't seem \
\to have been installed by your package manager:"
printList display ps

unknownFiles fs
= do putStrLn "\nThe following files are those corresponding \
\to packages installed by your package manager\n\
\which can't be matched up to the packages that own them."
printList id fs
brokenPkgs = brokenConfs >>=
checkPkgs "Haskell libraries with broken dependencies" "broken"

-- .conf files from broken packages of this GHC version
brokenConfs :: IO ([PackageIdentifier], [FilePath])
Expand All @@ -200,35 +236,14 @@ brokenConfs = do brkn <- getBroken
return $ partitionEithers
$ map (matchConf cnfs) brkn

type ConfMap = Map PackageIdentifier FilePath

-- Attempt to match the provided broken package to one of the
-- installed packages.
matchConf :: ConfMap -> PackageIdentifier -> Either PackageIdentifier FilePath
matchConf = tryMaybe . flip Map.lookup

-- Read in all Gentoo .conf files from the current GHC version and
-- create a Map
readConf :: IO ConfMap
readConf = ghcLibDir >>= confFiles >>= foldM addConf Map.empty

-- Add this .conf file to the Map
addConf :: ConfMap -> FilePath -> IO ConfMap
addConf cmp conf = do cnts <- readFile conf
case (reads cnts) of
[] -> return cmp
-- ebuilds that have CABAL_CORE_LIB_GHC_PV set
-- for this version of GHC will have a .conf
-- file containing just []
[([],_)] -> 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

-- Return the closure of all packages affected by breakage
getBroken :: IO [PackageIdentifier]
getBroken = liftM (mapMaybe simpleParse . words)
$ ghcPkgRawOut ["check", "--simple-output"]

-- -----------------------------------------------------------------------------

allInstalledPackages :: IO [Package]
allInstalledPackages = do cm <- readConf
let confs = Map.elems cm
checkPkgs "installed Haskell libraries" "installed" ([], confs)
12 changes: 9 additions & 3 deletions Main.hs
Expand Up @@ -72,11 +72,13 @@ runAction rm (Build ts) = do systemInfo rm

data BuildTarget = GhcUpgrade
| DepCheck
| AllInstalled
deriving (Eq, Ord, Show, Read)

getPackages :: BuildTarget -> IO [Package]
getPackages GhcUpgrade = oldGhcPkgs
getPackages DepCheck = brokenPkgs
getPackages :: BuildTarget -> IO [Package]
getPackages GhcUpgrade = oldGhcPkgs
getPackages DepCheck = brokenPkgs
getPackages AllInstalled = allInstalledPackages

getPackages' :: BuildTarget -> IO (Set Package)
getPackages' = liftM Set.fromList . getPackages
Expand Down Expand Up @@ -124,6 +126,7 @@ data Flag = HelpFlag
| CustomPMFlag String
| Check
| Upgrade
| RebuildAll
| Pretend
| NoDeep
deriving (Eq, Ord, Show, Read)
Expand Down Expand Up @@ -165,6 +168,7 @@ flagToAction HelpFlag = Right Help
flagToAction VersionFlag = Right Version
flagToAction Check = Right . Build $ Set.singleton DepCheck
flagToAction Upgrade = Right . Build $ Set.singleton GhcUpgrade
flagToAction RebuildAll = Right . Build $ Set.singleton AllInstalled
flagToAction f = Left f

flagToPM :: Flag -> Either Flag PkgManager
Expand All @@ -178,6 +182,8 @@ options =
"Check dependencies of Haskell packages."
, Option ['u'] ["upgrade"] (NoArg Upgrade)
"Rebuild Haskell packages after a GHC upgrade."
, Option [] ["all"] (NoArg RebuildAll)
"Rebuild all Haskell libraries built with current GHC."
, Option ['P'] ["package-manager"] (ReqArg PM "PM")
$ "Use package manager PM, where PM can be one of:\n"
++ pmList ++ defPM
Expand Down

0 comments on commit 38db99c

Please sign in to comment.