diff --git a/Distribution/Gentoo/GHC.hs b/Distribution/Gentoo/GHC.hs --- a/Distribution/Gentoo/GHC.hs +++ b/Distribution/Gentoo/GHC.hs @@ -39,6 +39,9 @@ , doesDirectoryExist , findExecutable) import Control.Monad(foldM, liftM) + +import Output + -- ----------------------------------------------------------------------------- -- Common helper utils, etc. @@ -129,49 +132,50 @@ cfNm :: [([InstalledPackageInfo_ String], String)] -> PackageIdentifier cfNm = packageId . head . fst . head -checkPkgs :: ([PackageIdentifier], [FilePath]) +checkPkgs :: Verbosity + -> ([PackageIdentifier], [FilePath]) -> IO ([Package],[PackageIdentifier],[FilePath]) -checkPkgs (pns,cnfs) - = do (nI, pkgs) <- liftM partitionEithers $ mapM hasFile' cnfs - return (pkgs, pns, nI) - where - hasFile' f = do mp <- hasFile f - return $ maybe (Left f) Right mp +checkPkgs v (pns,cnfs) + = do pkgs <- haveFiles cnfs + return (pkgs, pns, []) -- ----------------------------------------------------------------------------- -- Finding packages installed with other versions of GHC -oldGhcPkgs :: IO [Package] -oldGhcPkgs = do thisGhc <- ghcLibDir - let thisGhc' = BS.pack thisGhc - -- It would be nice to do this, but we can't assume - -- some crazy user hasn't deleted one of these dirs - -- libFronts' <- filterM doesDirectoryExist libFronts - pkgs <- liftM notGHC - $ concatMapM (checkLibDir thisGhc') libFronts - return pkgs +oldGhcPkgs :: Verbosity -> IO [Package] +oldGhcPkgs v = + do thisGhc <- ghcLibDir + vsay v $ "oldGhcPkgs ghc lib: " ++ show thisGhc + let thisGhc' = BS.pack thisGhc + -- It would be nice to do this, but we can't assume + -- some crazy user hasn't deleted one of these dirs + -- libFronts' <- filterM doesDirectoryExist libFronts + pkgs <- liftM notGHC + $ checkLibDirs v thisGhc' libFronts + return pkgs -- Find packages installed by other versions of GHC in this possible -- library directory. -checkLibDir :: BSFilePath -> BSFilePath -> IO [Package] -checkLibDir thisGhc libDir = pkgsHaveContent (hasDirMatching wanted) +checkLibDirs :: Verbosity -> BSFilePath -> [BSFilePath] -> IO [Package] +checkLibDirs v thisGhc libDirs = + do vsay v $ "checkLibDir ghc libs: " ++ show (thisGhc, libDirs) + pkgsHaveContent (hasDirMatching wanted) where wanted dir = isValid dir && (not . isInvalid) dir - isValid = isGhcLibDir libDir + isValid dir = any (\ldir -> isGhcLibDir ldir dir) libDirs -- Invalid if it's this GHC isInvalid fp = fp == thisGhc || BS.isPrefixOf (thisGhc `BS.snoc` pathSeparator) fp -- A valid GHC library directory starting at libdir has a name of --- either "ghc" or "ghc-bin", then a hyphen and then a version number. -isGhcLibDir :: BSFilePath -> BSFilePath -> Bool -isGhcLibDir libdir dir = go ghcDirName || go ghcBinDirName +-- "ghc", then a hyphen and then a version number. +isGhcLibDir :: BSFilePath -> BSFilePath -> Bool +isGhcLibDir libdir dir = go ghcDirName where -- This is hacky because FilePath doesn't work on Bytestrings... libdir' = BS.snoc libdir pathSeparator ghcDirName = BS.pack "ghc" - ghcBinDirName = BS.pack "ghc-bin" go dn = BS.isPrefixOf ghcDir dir -- Any possible version starts with a digit @@ -184,26 +188,29 @@ -- The possible places GHC could have installed lib directories libFronts :: [BSFilePath] libFronts = map BS.pack - $ do loc <- ["usr", "opt" "ghc"] - lib <- ["lib", "lib64"] - return $ "/" loc lib + $ do lib <- ["lib", "lib64"] + return $ "/" "usr" lib -- ----------------------------------------------------------------------------- -- Finding broken packages in this install of GHC. -brokenPkgs :: IO ([Package],[PackageIdentifier],[FilePath]) -brokenPkgs = brokenConfs >>= checkPkgs +brokenPkgs :: Verbosity -> IO ([Package],[PackageIdentifier],[FilePath]) +brokenPkgs v = brokenConfs v >>= checkPkgs v -- .conf files from broken packages of this GHC version -brokenConfs :: IO ([PackageIdentifier], [FilePath]) -brokenConfs = do brkn <- getBroken - -- Check if we actually have to go look up files and - -- do IO. - if null brkn - then return ([], []) - else do cnfs <- readConf - return $ partitionEithers - $ map (matchConf cnfs) brkn +brokenConfs :: Verbosity -> IO ([PackageIdentifier], [FilePath]) +brokenConfs v = + do vsay v "brokenConfs: getting broken output from 'ghc-pkg'" + brkn <- getBroken + -- Check if we actually have to go look up files and + -- do IO. + vsay v $ "brokenConfs: resolving package names to gentoo equivalents. " ++ show (length brkn) ++ " are broken" + if null brkn + then return ([], []) + else do vsay v "brokenConfs: reading '*.conf' files" + cnfs <- readConf + vsay v $ "brokenConfs: got " ++ show (Map.size cnfs) ++ " '*.conf' files" + return $ partitionEithers $ map (matchConf cnfs) brkn -- Return the closure of all packages affected by breakage getBroken :: IO [PackageIdentifier] diff --git a/Distribution/Gentoo/Packages.hs b/Distribution/Gentoo/Packages.hs --- a/Distribution/Gentoo/Packages.hs +++ b/Distribution/Gentoo/Packages.hs @@ -12,7 +12,7 @@ , Content , notGHC , printPkg - , hasFile + , haveFiles , pkgsHaveContent , hasContentMatching , hasDirMatching @@ -26,6 +26,7 @@ import Data.Maybe(mapMaybe, listToMaybe) import qualified Data.ByteString.Char8 as BS import Data.ByteString.Char8(ByteString) +import qualified Data.Set as S import System.Directory( doesDirectoryExist , doesFileExist) import System.FilePath(()) @@ -56,12 +57,9 @@ ghcPkg :: Package ghcPkg = Package "dev-lang" "ghc" Nothing -ghcBinPkg :: Package -ghcBinPkg = Package "dev-lang" "ghc-bin" Nothing - -- Return all packages that are not a version of GHC. notGHC :: [Package] -> [Package] -notGHC = filter (\p -> isNot ghcPkg p && isNot ghcBinPkg p) +notGHC = filter (\p -> isNot ghcPkg p) where isNot p1 = not . samePackageAs p1 @@ -179,13 +177,12 @@ -- ----------------------------------------------------------------------------- --- Find the package (if any) that contain this file. --- Assumes collision protection (i.e. at most one package per file). -hasFile :: FilePath -> IO (Maybe Package) -hasFile fp = liftM listToMaybe $ pkgsHaveContent p +-- Find all the packages that contain any of the given files. +haveFiles :: [FilePath] -> IO [Package] +haveFiles fps = pkgsHaveContent p where - fp' = BS.pack fp - p = hasObjMatching ((==) fp') + fps' = S.fromList $ map BS.pack fps + p = hasObjMatching (\fp -> S.member fp fps') -- Find which packages have Content information that matches the -- provided predicate; to be used with the searching predicates diff --git a/Distribution/Gentoo/PkgManager.hs b/Distribution/Gentoo/PkgManager.hs --- a/Distribution/Gentoo/PkgManager.hs +++ b/Distribution/Gentoo/PkgManager.hs @@ -144,4 +144,4 @@ cavePMFlag PretendBuild = Just "--no-execute" cavePMFlag UpdateDeep = Just "--complete" cavePMFlag UpdateAsNeeded = Just "--lazy" -cavePMFlag PMQuiet = Just "--quiet" +cavePMFlag PMQuiet = Nothing -- Just "--quiet" diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -91,7 +91,7 @@ getPackages v target = case target of GhcUpgrade -> do say v "Searching for packages installed with a different version of GHC." - pkgs <- oldGhcPkgs + pkgs <- oldGhcPkgs v pkgListPrint v "old" pkgs return pkgs @@ -100,8 +100,8 @@ pkgListPrint v "installed" pkgs return pkgs - DepCheck -> do say v "Searching for Haskell libraries with broken dependencies." - (pkgs, unknown_packages, unknown_files) <- brokenPkgs + DepCheck -> do say v "Searching for Haskell libraries with broken dependencies." + (pkgs, unknown_packages, unknown_files) <- brokenPkgs v printUnknownPackages unknown_packages printUnknownFiles unknown_files pkgListPrint v "broken" (notGHC pkgs) @@ -169,6 +169,7 @@ | Pretend | NoDeep | QuietFlag + | VerboseFlag | ListOnlyFlag deriving (Eq, Ord, Show, Read) @@ -199,7 +200,10 @@ -- We need to get Flags that represent this as well. , withCmd = PrintAndRun , rawPMArgs = nonoptions - , verbosity = bool Normal Quiet (hasFlag QuietFlag) + , verbosity = case () of + _ | hasFlag VerboseFlag -> Verbose + _ | hasFlag QuietFlag -> Quiet + _ -> Normal , listOnly = hasFlag ListOnlyFlag } @@ -240,6 +244,8 @@ "Version information." , Option ['q'] ["quiet"] (NoArg QuietFlag) "Print only fatal errors (to stderr)." + , Option ['v'] ["verbose"] (NoArg VerboseFlag) + "Be more elaborate (to stderr)." , Option ['h', '?'] ["help"] (NoArg HelpFlag) "Print this help message." ] diff --git a/Output.hs b/Output.hs --- a/Output.hs +++ b/Output.hs @@ -9,6 +9,7 @@ pkgListPrint , printList , say + , vsay , Verbosity(..) ) where @@ -17,13 +18,24 @@ import Distribution.Gentoo.Packages -- output mode (chattiness) -data Verbosity = Normal - | Quiet +data Verbosity = Quiet + | Normal + | Verbose deriving (Eq, Ord, Show, Read) say :: Verbosity -> String -> IO () -say Normal msg = hPutStrLn stderr msg -say Quiet _msg = return () +say verb_l msg = + case verb_l of + Quiet -> return () + Normal -> hPutStrLn stderr msg + Verbose -> hPutStrLn stderr msg + +vsay :: Verbosity -> String -> IO () +vsay verb_l msg = + case verb_l of + Quiet -> return () + Normal -> return () + Verbose -> hPutStrLn stderr msg -- Print a bullet list of values with one value per line. printList :: Verbosity -> (a -> String) -> [a] -> IO () diff --git a/haskell-updater.cabal b/haskell-updater.cabal --- a/haskell-updater.cabal +++ b/haskell-updater.cabal @@ -1,6 +1,6 @@ Name: haskell-updater Homepage: http://haskell.org/haskellwiki/Gentoo#haskell-updater -Version: 1.2.0.12 +Version: 1.2.1 Synopsis: Rebuild Haskell dependencies in Gentoo Description: haskell-updater rebuilds Haskell packages on Gentoo after a GHC upgrade or a dependency upgrade.