{- | Module : Main Description : The haskell-updater executable Copyright : (c) Ivan Lazar Miljenovic, Stephan Friedrichs, Emil Karlson 2010 License : GPL-2 or later The executable module of haskell-updater, which finds Haskell packages to rebuild after a dep upgrade or a GHC upgrade. -} 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 qualified Paths_haskell_updater as Paths(version) import System.Console.GetOpt import System.Environment(getArgs, getProgName) import System.Exit(ExitCode(..), exitWith) import System.IO(hPutStrLn, stderr) import Control.Monad(liftM, unless) import System.Process(rawSystem) import Output -- ----------------------------------------------------------------------------- -- The overall program. main :: IO () 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.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) defaultAction :: Action defaultAction = Build $ Set.fromList [GhcUpgrade, DepCheck] -- Combine all the actions together. If the list is empty, use the -- defaultAction. combineAllActions :: [Action] -> Action combineAllActions = emptyElse defaultAction (foldl1' combineActions) -- Combine two actions together. If they're both Build blah, merge -- them; otherwise, pick the lower of the two (i.e. more important). -- Note that it's safe (at the moment at least) to assume that when -- 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 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. data BuildTarget = GhcUpgrade | DepCheck | AllInstalled deriving (Eq, Ord, Show, Read) 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 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 -- ----------------------------------------------------------------------------- -- How to build packages. data RunModifier = RM { pkgmgr :: PkgManager , flags :: [PMFlag] , withCmd :: WithCmd , rawPMArgs :: [String] , verbosity :: Verbosity , listOnly :: Bool } deriving (Eq, Ord, Show, Read) -- At the moment, PrintAndRun is the only option available. data WithCmd = RunOnly | PrintOnly | PrintAndRun deriving (Eq, Ord, Show, Read) runCmd :: WithCmd -> String -> [String] -> IO a runCmd mode cmd args = case mode of RunOnly -> runCommand cmd args PrintOnly -> putStrLn cmd_line >> exitWith (ExitSuccess) PrintAndRun -> putStrLn cmd_line >> runCommand cmd args where cmd_line = unwords (cmd:args) runCommand :: String -> [String] -> IO a runCommand cmd args = rawSystem cmd args >>= exitWith buildPkgs :: RunModifier -> [Package] -> IO a 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 -- ----------------------------------------------------------------------------- -- Command-line flags data Flag = HelpFlag | VersionFlag | PM String | CustomPMFlag String | Check | Upgrade | RebuildAll | Pretend | NoDeep | QuietFlag | ListOnlyFlag deriving (Eq, Ord, Show, Read) parseArgs :: PkgManager -> [String] -> Either String (RunModifier, Action) parseArgs defPM args = argParser defPM $ getOpt' Permute options args 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' (bPms, pms') = partitionBy isValidPM pms pm = emptyElse dPM last pms' opts' = Set.fromList opts hasFlag = flip Set.member opts' pmFlags = bool (PMQuiet:) id (hasFlag QuietFlag) . bool id (PretendBuild:) (hasFlag Pretend) . return $ bool UpdateDeep UpdateAsNeeded (hasFlag NoDeep) rm = RM { pkgmgr = pm , flags = pmFlags -- We need to get Flags that represent this as well. , withCmd = PrintAndRun , rawPMArgs = nonoptions , verbosity = bool Normal Quiet (hasFlag QuietFlag) , listOnly = hasFlag ListOnlyFlag } flagToAction :: Flag -> Either Flag Action 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 flagToPM (CustomPMFlag pm) = Right $ stringToCustomPM pm flagToPM (PM pm) = Right $ choosePM pm flagToPM f = Left f options :: [OptDescr Flag] options = [ Option ['c'] ["dep-check"] (NoArg Check) "Check dependencies of Haskell packages." , Option ['u'] ["upgrade"] (NoArg Upgrade) "Rebuild Haskell packages after a GHC upgrade." , Option ['a'] ["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 , 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 ['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." ] where pmList = unlines . map ((++) " * ") $ definedPMs defPM = "The last valid value of PM specified is chosen.\n\ \The default package manager is: " ++ defaultPMName ++ ",\n\ \which can be overriden with the \"PACKAGE_MANAGER\"\n\ \environment variable." -- ----------------------------------------------------------------------------- -- Printing information. help :: IO a help = progInfo >>= success Normal version :: IO a version = fmap (++ '-' : showVersion Paths.version) getProgName >>= success Normal progInfo :: IO String progInfo = do pName <- getProgName return $ usageInfo (header pName) options where 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 :: 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 :: Verbosity -> String -> IO a success v msg = do say v msg exitWith ExitSuccess die :: String -> IO a die msg = do putErrLn ("ERROR: " ++ msg) exitWith (ExitFailure 1) putErrLn :: String -> IO () putErrLn = hPutStrLn stderr bool :: a -> a -> Bool -> a bool f t b = if b then t else f partitionBy :: (a -> Either l r) -> [a] -> ([l], [r]) partitionBy f = partitionEithers . map f -- If the list is empty, return the provided value; otherwise use the function. emptyElse :: b -> ([a] -> b) -> [a] -> b emptyElse e _ [] = e emptyElse _ f as = f as