diff --git a/Distribution/Gentoo/GHC.hs b/Distribution/Gentoo/GHC.hs --- a/Distribution/Gentoo/GHC.hs +++ b/Distribution/Gentoo/GHC.hs @@ -11,7 +11,6 @@ ( ghcVersion , ghcLoc , ghcLibDir - , libFronts , oldGhcPkgs , brokenPkgs , allInstalledPackages @@ -25,7 +24,7 @@ import Distribution.Verbosity(silent) import Distribution.Package(PackageIdentifier, packageId) import Distribution.InstalledPackageInfo(InstalledPackageInfo_) -import Distribution.Text(display, simpleParse) +import Distribution.Text(simpleParse) -- Other imports import Data.Char(isDigit) @@ -38,8 +37,7 @@ import System.Directory( canonicalizePath , doesDirectoryExist , findExecutable) -import Control.Monad(foldM, liftM, unless) - +import Control.Monad(foldM, liftM) -- ----------------------------------------------------------------------------- -- Common helper utils, etc. @@ -90,20 +88,6 @@ where isConf file = takeExtension file == ".conf" --- Print a list of packages, with a description of what they are. -pkgListPrint :: String -> [Package] -> IO () -pkgListPrint desc pkgs - = if null pkgs - then putStrLn $ unwords ["No", desc, "packages found!\n"] - else do putStrLn $ unwords ["Found the following" - , desc, "packages:"] - printList printPkg pkgs - putStrLn "" - --- Print a bullet list of values with one value per line. -printList :: (a -> String) -> [a] -> IO () -printList f = mapM_ (putStrLn . (++) " * " . f) - tryMaybe :: (a -> Maybe b) -> a -> Either a b tryMaybe f a = maybe (Left a) Right $ f a @@ -136,47 +120,26 @@ 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 ++ "." - 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 +checkPkgs :: ([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 - 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 oldGhcPkgs :: IO [Package] -oldGhcPkgs = do putStrLn "Searching for packages installed with a \ - \different version of GHC." - thisGhc <- ghcLibDir +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 - pkgListPrint "old" pkgs return pkgs -- Find packages installed by other versions of GHC in this possible @@ -219,9 +182,8 @@ -- ----------------------------------------------------------------------------- -- Finding broken packages in this install of GHC. -brokenPkgs :: IO [Package] -brokenPkgs = brokenConfs >>= - checkPkgs "Haskell libraries with broken dependencies" "broken" +brokenPkgs :: IO ([Package],[PackageIdentifier],[FilePath]) +brokenPkgs = brokenConfs >>= checkPkgs -- .conf files from broken packages of this GHC version brokenConfs :: IO ([PackageIdentifier], [FilePath]) @@ -242,11 +204,8 @@ -- ----------------------------------------------------------------------------- allInstalledPackages :: IO [Package] -allInstalledPackages = do putStrLn "Finding all libraries installed with the \ - \current version of GHC." - libDir <- ghcLibDir +allInstalledPackages = do libDir <- ghcLibDir let libDir' = BS.pack libDir pkgs <- liftM notGHC $ pkgsHaveContent $ hasDirMatching (==libDir') - pkgListPrint "installed" pkgs return pkgs diff --git a/Distribution/Gentoo/PkgManager.hs b/Distribution/Gentoo/PkgManager.hs --- a/Distribution/Gentoo/PkgManager.hs +++ b/Distribution/Gentoo/PkgManager.hs @@ -15,7 +15,6 @@ , defaultPM , defaultPMName , nameOfPM - , dummy , PMFlag(..) , buildCmd ) where @@ -38,10 +37,6 @@ | InvalidPM String | CustomPM String deriving (Eq, Ord, Show, Read) - --- | A dummy package manager used for testing purposes. -dummy :: PkgManager -dummy = CustomPM "echo" -- | The default package manager. If the environment variable -- @PACKAGE_MANAGER@ exists, use that; otherwise default to diff --git a/Distribution/Gentoo/Util.hs b/Distribution/Gentoo/Util.hs --- a/Distribution/Gentoo/Util.hs +++ b/Distribution/Gentoo/Util.hs @@ -6,7 +6,12 @@ Common utility functions. -} -module Distribution.Gentoo.Util where +module Distribution.Gentoo.Util + ( BSFilePath + , concatMapM + , breakAll + , getDirectoryContents' + ) where import Data.List(groupBy) import Data.ByteString.Char8(ByteString) diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -7,18 +7,19 @@ The executable module of haskell-updater, which finds Haskell packages to rebuild after a dep upgrade or a GHC upgrade. -} -module Main where +module Main (main) where import Distribution.Gentoo.GHC import Distribution.Gentoo.Packages import Distribution.Gentoo.PkgManager import Distribution.Gentoo.Util +import Distribution.Text(display) + import Data.Either(partitionEithers) import Data.List(foldl1', nub) import Data.Version(showVersion) import qualified Data.Set as Set -import Data.Set(Set) import qualified Paths_haskell_updater as Paths(version) import System.Console.GetOpt import System.Environment(getArgs, getProgName) @@ -27,18 +28,23 @@ import Control.Monad(liftM, unless) import System.Process(rawSystem) +import Output + -- ----------------------------------------------------------------------------- -- The overall program. main :: IO () -main = uncurry runAction =<< parseArgs - +main = do args <- getArgs + defPM <- defaultPM + case parseArgs defPM args of + Left err -> die err + Right a -> uncurry runAction a -- ----------------------------------------------------------------------------- -- The possible actions that haskell-updater can perform. data Action = Help | Version - | Build { targets :: Set BuildTarget } + | Build { targets :: Set.Set BuildTarget } -- If anything is added here after Build, MAKE SURE YOU -- UPDATE combineActions or it won't always work! deriving (Eq, Ord, Show, Read) @@ -57,16 +63,22 @@ -- the lower of one is a Build that they're both build. combineActions :: Action -> Action -> Action combineActions a1 a2 = case (a1 `min` a2) of + Help -> Help + Version -> Version Build{} -> Build $ targets a1 `Set.union` targets a2 - a -> a -runAction :: RunModifier -> Action -> IO a -runAction _ Help = help -runAction _ Version = version -runAction rm (Build ts) = do systemInfo rm - ps <- allGetPackages ts - buildPkgs rm ps - +runAction :: RunModifier -> Action -> IO a +runAction rm action = + case action of + Help -> help + Version -> version + Build ts -> do systemInfo v rm + ps <- allGetPackages v ts + if listOnly rm + then mapM_ (putStrLn . printPkg) ps + else buildPkgs rm ps + success v "done!" + where v = verbosity rm -- ----------------------------------------------------------------------------- -- The possible things to build. @@ -75,14 +87,39 @@ | AllInstalled deriving (Eq, Ord, Show, Read) -getPackages :: BuildTarget -> IO [Package] -getPackages GhcUpgrade = oldGhcPkgs -getPackages DepCheck = brokenPkgs -getPackages AllInstalled = allInstalledPackages +getPackages :: Verbosity -> BuildTarget -> IO [Package] +getPackages v target = + case target of + GhcUpgrade -> do say v "Searching for packages installed with a different version of GHC." + pkgs <- oldGhcPkgs + pkgListPrint v "old" pkgs + return pkgs -allGetPackages :: Set BuildTarget -> IO [Package] -allGetPackages = liftM nub - . concatMapM getPackages + AllInstalled -> do say v "Finding all libraries installed with the current version of GHC." + pkgs <- allInstalledPackages + pkgListPrint v "installed" pkgs + return pkgs + + DepCheck -> do say v "Searching for Haskell libraries with broken dependencies." + (pkgs, unknown_packages, unknown_files) <- brokenPkgs + printUnknownPackages unknown_packages + printUnknownFiles unknown_files + pkgListPrint v "broken" (notGHC pkgs) + return pkgs + + where printUnknownPackages [] = return () + printUnknownPackages ps = + do say v "\nThe following packages don't seem to have been installed by your package manager:" + printList v display ps + printUnknownFiles [] = return () + printUnknownFiles fs = + do say v $ "\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 v id fs + +allGetPackages :: Verbosity -> Set.Set BuildTarget -> IO [Package] +allGetPackages v = liftM nub + . concatMapM (getPackages v) . Set.toList -- ----------------------------------------------------------------------------- @@ -92,6 +129,8 @@ , flags :: [PMFlag] , withCmd :: WithCmd , rawPMArgs :: [String] + , verbosity :: Verbosity + , listOnly :: Bool } deriving (Eq, Ord, Show, Read) @@ -104,7 +143,7 @@ runCmd :: WithCmd -> String -> [String] -> IO a runCmd mode cmd args = case mode of RunOnly -> runCommand cmd args - PrintOnly -> success cmd_line + PrintOnly -> putStrLn cmd_line >> exitWith (ExitSuccess) PrintAndRun -> putStrLn cmd_line >> runCommand cmd args where cmd_line = unwords (cmd:args) @@ -112,7 +151,7 @@ runCommand cmd args = rawSystem cmd args >>= exitWith buildPkgs :: RunModifier -> [Package] -> IO a -buildPkgs _ [] = success "\nNothing to build!" +buildPkgs rm [] = success (verbosity rm) "\nNothing to build!" buildPkgs rm ps = runCmd (withCmd rm) cmd args where (cmd, args) = buildCmd (pkgmgr rm) (flags rm) (rawPMArgs rm) ps @@ -129,24 +168,22 @@ | RebuildAll | Pretend | NoDeep + | QuietFlag + | ListOnlyFlag deriving (Eq, Ord, Show, Read) -parseArgs :: IO (RunModifier, Action) -parseArgs = do args <- getArgs - defPM <- defaultPM - argParser defPM $ getOpt' Permute options args +parseArgs :: PkgManager -> [String] -> Either String (RunModifier, Action) +parseArgs defPM args = argParser defPM $ getOpt' Permute options args -argParser :: PkgManager -> ([Flag], [String], [String], [String]) - -> IO (RunModifier, Action) -argParser dPM (fls, nonoptions, unrecognized, []) = - do unless (null unrecognized) - $ putErrLn - $ unwords $ "Unknown options:" : unrecognized - unless (null bPms) - $ putErrLn - $ unwords $ "Unknown package managers:" : bPms - return (rm, a) - where +argParser :: PkgManager + -> ([Flag], [String], [String], [String]) + -> Either String (RunModifier, Action) +argParser dPM (fls, nonoptions, unrecognized, errs) + | (not . null) errs = Left $ unwords $ "Errors in arguments:" : errs + | (not . null) unrecognized = Left $ unwords $ "Unknown options:" : unrecognized + | (not . null) bPms = Left $ unwords $ "Unknown package managers:" : bPms + | otherwise = Right (rm, a) + where (fls', as) = partitionBy flagToAction fls a = combineAllActions as (opts, pms) = partitionBy flagToPM fls' @@ -161,10 +198,10 @@ -- We need to get Flags that represent this as well. , withCmd = PrintAndRun , rawPMArgs = nonoptions + , verbosity = bool Normal Quiet (hasFlag QuietFlag) + , listOnly = hasFlag ListOnlyFlag } -argParser _ (_, _, _, errs) = die $ unwords $ "Errors in arguments:" : errs - flagToAction :: Flag -> Either Flag Action flagToAction HelpFlag = Right Help flagToAction VersionFlag = Right Version @@ -189,15 +226,19 @@ , Option ['P'] ["package-manager"] (ReqArg PM "PM") $ "Use package manager PM, where PM can be one of:\n" ++ pmList ++ defPM - , Option ['C'] ["--custom-pm"] (ReqArg CustomPMFlag "command") + , Option ['C'] ["custom-pm"] (ReqArg CustomPMFlag "command") "Use custom command as package manager;\n\ \ignores the --pretend and --no-deep flags." , Option ['p'] ["pretend"] (NoArg Pretend) "Only pretend to build packages." , Option [] ["no-deep"] (NoArg NoDeep) "Don't pull deep dependencies (--deep with emerge)." - , Option ['v'] ["version"] (NoArg VersionFlag) + , Option ['l'] ["list-only"] (NoArg ListOnlyFlag) + "Output only list of packages for rebuild. One package per line." + , Option ['V'] ["version"] (NoArg VersionFlag) "Version information." + , Option ['q'] ["quiet"] (NoArg QuietFlag) + "Print only fatal errors (to stderr)." , Option ['h', '?'] ["help"] (NoArg HelpFlag) "Print this help message." ] @@ -212,52 +253,47 @@ -- Printing information. help :: IO a -help = progInfo >>= success +help = progInfo >>= success Normal version :: IO a -version = fmap (++ '-' : showVersion Paths.version) getProgName >>= success - -err :: String -> IO a -err msg = liftM addMsg progInfo >>= die - where - addMsg str = msg ++ "\n\n"++ str +version = fmap (++ '-' : showVersion Paths.version) getProgName >>= success Normal progInfo :: IO String progInfo = do pName <- getProgName return $ usageInfo (header pName) options where - header pName = pName ++ " -- Find and rebuild packages broken due to either:\n\ - \ * GHC upgrade\n\ - \ * Haskell dependency upgrade\n\ - \ Default action is to do both.\n\ - \\n\ - \Usage: " ++ pName ++ " [Options [-- [PM options]]\n\ - \\n\ - \\n\ - \Options:" + header pName = unlines [ pName ++ " -- Find and rebuild packages broken due to either:" + , " * GHC upgrade" + , " * Haskell dependency upgrade" + , " Default action is to do both." + , "" + , "Usage: " ++ pName ++ " [Options [-- [PM options]]" + , "" + , "" + , "Options:"] -systemInfo :: RunModifier -> IO () -systemInfo rm = do ver <- ghcVersion - pName <- getProgName - pLoc <- ghcLoc - libDir <- ghcLibDir - putStrLn $ "Running " ++ pName ++ " using GHC " ++ ver - putStrLn $ " * Executable: " ++ pLoc - putStrLn $ " * Library directory: " ++ libDir - putStrLn $ " * Package manager (PM): " ++ nameOfPM (pkgmgr rm) - unless (null (rawPMArgs rm)) $ - putStrLn $ " * PM auxiliary arguments: " ++ unwords (rawPMArgs rm) - putStrLn "" +systemInfo :: Verbosity -> RunModifier -> IO () +systemInfo v rm = do ver <- ghcVersion + pName <- getProgName + pLoc <- ghcLoc + libDir <- ghcLibDir + say v $ "Running " ++ pName ++ " using GHC " ++ ver + say v $ " * Executable: " ++ pLoc + say v $ " * Library directory: " ++ libDir + say v $ " * Package manager (PM): " ++ nameOfPM (pkgmgr rm) + unless (null (rawPMArgs rm)) $ + say v $ " * PM auxiliary arguments: " ++ unwords (rawPMArgs rm) + say v "" -- ----------------------------------------------------------------------------- -- Utility functions -success :: String -> IO a -success msg = do putStrLn msg - exitWith ExitSuccess +success :: Verbosity -> String -> IO a +success v msg = do say v msg + exitWith ExitSuccess die :: String -> IO a -die msg = do putErrLn msg +die msg = do putErrLn ("ERROR: " ++ msg) exitWith (ExitFailure 1) putErrLn :: String -> IO () diff --git a/Output.hs b/Output.hs new file mode 100644 --- /dev/null +++ b/Output.hs @@ -0,0 +1,40 @@ +{- | + Module : Main + Description : The haskell-updater executable + License : GPL-2 or later + + Fancy output facility. +-} +module Output ( + pkgListPrint + , printList + , say + , Verbosity(..) + ) where + +import System.IO (hPutStrLn, stderr) + +import Distribution.Gentoo.Packages + +-- output mode (chattiness) +data Verbosity = Normal + | Quiet + deriving (Eq, Ord, Show, Read) + +say :: Verbosity -> String -> IO () +say Normal msg = hPutStrLn stderr msg +say Quiet _msg = return () + +-- Print a bullet list of values with one value per line. +printList :: Verbosity -> (a -> String) -> [a] -> IO () +printList v f = mapM_ (say v . (++) " * " . f) + +-- Print a list of packages, with a description of what they are. +pkgListPrint :: Verbosity -> String -> [Package] -> IO () +pkgListPrint v desc pkgs + = if null pkgs + then say v $ unwords ["No", desc, "packages found!\n"] + else do say v $ unwords ["Found the following" + , desc, "packages:"] + printList v printPkg pkgs + say v "" 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.5 +Version: 1.2.0.6 Synopsis: Rebuild Haskell dependencies in Gentoo Description: haskell-updater rebuilds Haskell packages on Gentoo after a GHC upgrade or a dependency upgrade. @@ -29,16 +29,17 @@ Extra-Source-Files: TODO Source-Repository head - Type: darcs - Location: http://code.haskell.org/gentoo/haskell-updater/ + Type: git + Location: git://github.com/gentoo-haskell/haskell-updater.git Executable haskell-updater { Main-Is: Main.hs Other-Modules: Distribution.Gentoo.GHC, - Distribution.Gentoo.Util, Distribution.Gentoo.Packages, Distribution.Gentoo.PkgManager, + Distribution.Gentoo.Util, + Output, Paths_haskell_updater Ghc-Options: -Wall Ghc-Prof-Options: -auto-all