diff --git a/Distribution/Gentoo/GHC.hs b/Distribution/Gentoo/GHC.hs --- a/Distribution/Gentoo/GHC.hs +++ b/Distribution/Gentoo/GHC.hs @@ -334,7 +334,7 @@ -- It usually happens this way: -- 1. user installs dev-lang/ghc-7.8.4-r0 (comes with bundled transformers-3.0.0.0-ghc-7.8.4-{abi}.conf) -- 2. user installs dev-haskell/transformers-0.4.3.0 (registered as transformers-0.4.3.0-{abi}.conf) --- 3. user upgrade up to dev-lang/ghc-7.8.4-r4 (comes with bundled transformers-0.4.3.0-ghc-7.8.4-{abi}.conf) +-- 3. user upgrades up to dev-lang/ghc-7.8.4-r4 (comes with bundled transformers-0.4.3.0-ghc-7.8.4-{abi}.conf) -- this way we have single package registered twice: -- transformers-0.4.3.0-ghc-7.8.4-{abi}.conf -- transformers-0.4.3.0-{abi}.conf diff --git a/Distribution/Gentoo/PkgManager.hs b/Distribution/Gentoo/PkgManager.hs --- a/Distribution/Gentoo/PkgManager.hs +++ b/Distribution/Gentoo/PkgManager.hs @@ -120,7 +120,6 @@ data PMFlag = PretendBuild | UpdateDeep | UpdateAsNeeded - | PMQuiet deriving (Eq, Ord, Show, Read) flagRep :: PkgManager -> PMFlag -> Maybe String @@ -134,7 +133,6 @@ portagePMFlag PretendBuild = Just "--pretend" portagePMFlag UpdateDeep = Just "--deep" portagePMFlag UpdateAsNeeded = Nothing -portagePMFlag PMQuiet = Just "--quiet" pkgcorePMFlag :: PMFlag -> Maybe String pkgcorePMFlag = portagePMFlag -- The options are the same for the 3 @@ -144,4 +142,3 @@ cavePMFlag PretendBuild = Just "--no-execute" cavePMFlag UpdateDeep = Just "--complete" cavePMFlag UpdateAsNeeded = Just "--lazy" -cavePMFlag PMQuiet = Nothing -- Just "--quiet" diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -12,13 +12,13 @@ import Distribution.Gentoo.GHC import Distribution.Gentoo.Packages import Distribution.Gentoo.PkgManager -import Distribution.Gentoo.Util -import Control.Monad (liftM, unless) +import Control.Monad (unless) +import qualified Control.Monad as CM import Data.Char (toLower) import Data.Either (partitionEithers) -import Data.List (foldl1', nub) import Data.Map (Map) +import qualified Data.List as L import qualified Data.Map as M import Data.Maybe (fromJust) import qualified Data.Set as Set @@ -32,86 +32,89 @@ 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. + Right a -> runAction a -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) +runAction :: RunModifier -> IO a +runAction rm + | showHelp rm = help + | showVer rm = version + | otherwise = runDriver rm -defaultAction :: Action -defaultAction = Build $ Set.fromList [GhcUpgrade, DepCheck] +-- set of packages to rebuild at pass number +type DriverHistory = M.Map (Set.Set Package) Int --- Combine all the actions together. If the list is empty, use the --- defaultAction. -combineAllActions :: [Action] -> Action -combineAllActions = emptyElse defaultAction (foldl1' combineActions) +initialHistory :: DriverHistory +initialHistory = M.empty --- 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 +dumpHistory :: Verbosity -> DriverHistory -> IO () +dumpHistory v historyMap = do + say v "Updater's past history:" + CM.forM_ historyList $ \(n, entry) -> + say v $ unwords $ ["Pass", show n, " : "] ++ map printPkg (Set.toList entry) + where historyList :: [(Int, Set.Set Package)] + historyList = L.sort [ (n, entry) | (entry, n) <- M.toList historyMap ] -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!" +runDriver :: RunModifier -> IO a +runDriver rm = do + systemInfo v rm t + updaterPass 1 initialHistory + success v "done!" where v = verbosity rm --- ----------------------------------------------------------------------------- --- The possible things to build. + t = target rm + updaterPass :: Int -> DriverHistory -> IO () + updaterPass n pastHistory = do + ps <- getTargetPackages v t + CM.when (listOnly rm) $ do + mapM_ (putStrLn . printPkg) ps + success v "done!" + CM.when (null ps) $ + success (verbosity rm) "\nNothing to build!" + CM.when (Set.fromList ps `M.member` pastHistory) $ do + say v "Updater stuck in the loop and can't progress" + dumpHistory v pastHistory -data BuildTarget = GhcUpgrade - | DepCheck - | AllInstalled + exitCode <- buildPkgs rm ps + + -- don't try rerun rebuilder for cases where there + -- is no chance to converge to empty set + CM.when (target rm == AllInstalled) $ + exitWith exitCode + + -- continue rebuild attempts + updaterPass (n + 1) $ M.insert (Set.fromList ps) n pastHistory + +data BuildTarget = OnlyInvalid + | AllInstalled -- Rebuild every haskell package 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." - say v "" - pkgs <- oldGhcPkgs v - pkgListPrintLn v "old" pkgs - return pkgs +getTargetPackages :: Verbosity -> BuildTarget -> IO [Package] +getTargetPackages v t = + case t of + OnlyInvalid -> do say v "Searching for packages installed with a different version of GHC." + say v "" + old <- oldGhcPkgs v + pkgListPrintLn v "old" old + say v "Searching for Haskell libraries with broken dependencies." + say v "" + (broken, unknown_packages, unknown_files) <- brokenPkgs v + printUnknownPackagesLn (map unCPV unknown_packages) + printUnknownFilesLn unknown_files + pkgListPrintLn v "broken" (notGHC broken) + + return $ Set.toList $ Set.fromList $ old ++ broken + AllInstalled -> do say v "Searching for packages installed with the current version of GHC." say v "" pkgs <- allInstalledPackages pkgListPrintLn v "installed" pkgs return pkgs - DepCheck -> do say v "Searching for Haskell libraries with broken dependencies." - say v "" - (pkgs, unknown_packages, unknown_files) <- brokenPkgs v - printUnknownPackagesLn (map unCPV unknown_packages) - printUnknownFilesLn unknown_files - pkgListPrintLn v "broken" (notGHC pkgs) - return pkgs - where printUnknownPackagesLn [] = return () printUnknownPackagesLn ps = do say v "The following packages are orphan (not installed by your package manager):" @@ -124,29 +127,24 @@ say v $ "It is strongly advised to remove orphans:" say v $ " One of known sources of orphans is packages installed before 01 Jan 2015." say v $ " If you know it's your case you can easily remove such files:" - say v $ " # rm -v -- `qfile -o $(ghc --print-libdir)/package.conf.d/*.conf`" + say v $ " # rm -v -- `qfile -o $(ghc --print-libdir)/package.conf.d/*.conf $(ghc --print-libdir)/gentoo/*.conf`" say v $ " # ghc-pkg recache" say v $ " It will likely need one more 'haskell-updater' run." say v "" -allGetPackages :: Verbosity -> Set.Set BuildTarget -> IO [Package] -allGetPackages v = liftM nub - . concatMapM (getPackages v) - . Set.toList - --- ----------------------------------------------------------------------------- --- How to build packages. - +-- Full haskell-updater state data RunModifier = RM { pkgmgr :: PkgManager , flags :: [PMFlag] , withCmd :: WithCmd , rawPMArgs :: [String] , verbosity :: Verbosity , listOnly :: Bool + , showHelp :: Bool + , showVer :: Bool + , target :: BuildTarget } deriving (Eq, Ord, Show, Read) --- At the moment, PrintAndRun is the only option available. data WithCmd = RunOnly | PrintOnly | PrintAndRun @@ -163,18 +161,17 @@ defaultWithCmd :: String defaultWithCmd = "print-and-run" -runCmd :: WithCmd -> String -> [String] -> IO a +runCmd :: WithCmd -> String -> [String] -> IO ExitCode runCmd mode cmd args = case mode of RunOnly -> runCommand cmd args PrintOnly -> putStrLn cmd_line >> 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 +runCommand :: String -> [String] -> IO ExitCode +runCommand cmd args = rawSystem cmd args -buildPkgs :: RunModifier -> [Package] -> IO a -buildPkgs rm [] = success (verbosity rm) "\nNothing to build!" +buildPkgs :: RunModifier -> [Package] -> IO ExitCode buildPkgs rm ps = runCmd (withCmd rm) cmd args where (cmd, args) = buildCmd (pkgmgr rm) (flags rm) (rawPMArgs rm) ps @@ -186,8 +183,7 @@ | VersionFlag | PM String | CustomPMFlag String - | Check - | Upgrade + | FixInvalid | RebuildAll | Pretend | NoDeep @@ -197,21 +193,20 @@ | Cmd String deriving (Eq, Ord, Show, Read) -parseArgs :: PkgManager -> [String] -> Either String (RunModifier, Action) +parseArgs :: PkgManager -> [String] -> Either String RunModifier parseArgs defPM args = argParser defPM $ getOpt' Permute options args argParser :: PkgManager -> ([Flag], [String], [String], [String]) - -> Either String (RunModifier, Action) + -> Either String RunModifier 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 | (not . null) bCmds = Left $ unwords $ "Unknown action:" : bCmds - | otherwise = Right (rm, a) + | otherwise = Right rm where - (fls', as) = partitionBy flagToAction fls - a = combineAllActions as + (fls', ts) = partitionBy flagToTarget fls (fls'', pms) = partitionBy flagToPM fls' (bPms, pms') = partitionBy isValidPM pms (opts, cmds') = partitionBy flagToCmd fls'' @@ -220,8 +215,7 @@ opts' = Set.fromList opts cmd = emptyElse (fromJust $ M.lookup defaultWithCmd withCmdMap) last cmds hasFlag = flip Set.member opts' - pmFlags = bool (PMQuiet:) id (hasFlag QuietFlag) - . bool id (PretendBuild:) (hasFlag Pretend) + pmFlags = bool id (PretendBuild:) (hasFlag Pretend) . return $ bool UpdateDeep UpdateAsNeeded (hasFlag NoDeep) rm = RM { pkgmgr = pm , flags = pmFlags @@ -232,15 +226,15 @@ _ | hasFlag QuietFlag -> Quiet _ -> Normal , listOnly = hasFlag ListOnlyFlag + , showVer = hasFlag VersionFlag + , showHelp = hasFlag HelpFlag + , target = last $ OnlyInvalid : ts } -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 +flagToTarget :: Flag -> Either Flag BuildTarget +flagToTarget FixInvalid = Right OnlyInvalid +flagToTarget RebuildAll = Right AllInstalled +flagToTarget f = Left f flagToPM :: Flag -> Either Flag PkgManager flagToPM (CustomPMFlag pm) = Right $ stringToCustomPM pm @@ -265,9 +259,10 @@ options :: [OptDescr Flag] options = - [ Option ['c'] ["dep-check"] (NoArg Check) + [ Option ['c'] ["dep-check"] (NoArg FixInvalid) "Check dependencies of Haskell packages." - , Option ['u'] ["upgrade"] (NoArg Upgrade) + -- deprecated alias for 'dep-check' + , Option ['u'] ["upgrade"] (NoArg FixInvalid) "Rebuild Haskell packages after a GHC upgrade." , Option ['a'] ["all"] (NoArg RebuildAll) "Rebuild all Haskell libraries built with current GHC." @@ -318,29 +313,30 @@ progInfo = do pName <- getProgName return $ usageInfo (header pName) options where - header pName = unlines [ pName ++ " -- Find and rebuild packages broken due to either:" + header pName = unlines [ pName ++ " -- Find and rebuild packages broken due to any of:" , " * 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 - let pVer = showVersion Paths.version - pLoc <- ghcLoc - libDir <- ghcLibDir - say v $ "Running " ++ pName ++ "-" ++ pVer ++ " 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 "" +systemInfo :: Verbosity -> RunModifier -> BuildTarget -> IO () +systemInfo v rm t = do + ver <- ghcVersion + pName <- getProgName + let pVer = showVersion Paths.version + pLoc <- ghcLoc + libDir <- ghcLibDir + say v $ "Running " ++ pName ++ "-" ++ pVer ++ " 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 $ " * Mode: " ++ show t + say v "" -- ----------------------------------------------------------------------------- -- Utility functions 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.10 +Homepage: https://haskell.org/haskellwiki/Gentoo#haskell-updater +Version: 1.2.11 Synopsis: Rebuild Haskell dependencies in Gentoo Description: haskell-updater rebuilds Haskell packages on Gentoo after a GHC upgrade or a dependency upgrade. @@ -33,7 +33,7 @@ Source-Repository head Type: git - Location: git://github.com/gentoo-haskell/haskell-updater.git + Location: https://github.com/gentoo-haskell/haskell-updater.git Executable haskell-updater Main-Is: Main.hs