diff --git a/Distribution/Gentoo/GHC.hs b/Distribution/Gentoo/GHC.hs --- a/Distribution/Gentoo/GHC.hs +++ b/Distribution/Gentoo/GHC.hs @@ -15,6 +15,7 @@ , oldGhcPkgs , brokenPkgs , allInstalledPackages + , unCPV ) where import Distribution.Gentoo.Util @@ -33,7 +34,6 @@ import Data.Maybe import qualified Data.List as L import qualified Data.Map as Map -import Data.Map(Map) import qualified Data.ByteString.Char8 as BS import System.FilePath((), takeExtension, pathSeparator) import System.Directory( canonicalizePath @@ -89,10 +89,20 @@ ghcPkgLoc :: IO FilePath ghcPkgLoc = liftM fromJust $ findExecutable "ghc-pkg" +data ConfSubdir = GHCConfs + | GentooConfs + +subdirToDirname :: ConfSubdir -> FilePath +subdirToDirname subdir = + case subdir of + GHCConfs -> "package.conf.d" + GentooConfs -> "gentoo" + -- Return the Gentoo .conf files found in this GHC libdir -confFiles :: FilePath -> FilePath -> IO [FilePath] -confFiles subdir dir = do - let gDir = dir subdir +listConfFiles :: ConfSubdir -> IO [FilePath] +listConfFiles subdir = do + dir <- ghcLibDir + let gDir = dir subdirToDirname subdir exists <- doesDirectoryExist gDir if exists then do conts <- getDirectoryContents' gDir @@ -105,18 +115,24 @@ tryMaybe :: (a -> Maybe b) -> a -> Either a b tryMaybe f a = maybe (Left a) Right $ f a -type CabalPV = String -- serialized 'PackageIdentifier' -type ConfMap = Map CabalPV FilePath +newtype CabalPV = CPV { unCPV :: String } -- serialized 'PackageIdentifier' + deriving (Ord, Eq) -- for ConfMap, can be removed once ConfMap goes away +-- Unique (normal) or multiple (broken) mapping +type ConfMap = Map.Map CabalPV [FilePath] + +pushConf :: ConfMap -> CabalPV -> FilePath -> ConfMap +pushConf m k v = Map.insertWith (++) k [v] m + -- Attempt to match the provided broken package to one of the -- installed packages. -matchConf :: ConfMap -> CabalPV -> Either CabalPV FilePath +matchConf :: ConfMap -> CabalPV -> Either CabalPV [FilePath] matchConf = tryMaybe . flip Map.lookup --- Read in all Gentoo .conf files from the current GHC version and +-- Fold Gentoo .conf files from the current GHC version and -- create a Map -readConf :: Verbosity -> FilePath -> IO ConfMap -readConf v conf_subdir = ghcLibDir >>= confFiles conf_subdir >>= foldM (addConf v) Map.empty +foldConf :: Verbosity -> [FilePath] -> IO ConfMap +foldConf v = foldM (addConf v) Map.empty -- cabal package text format -- "[InstalledPackageInfo {installedPackageId = Insta..." @@ -128,7 +144,7 @@ -- for this version of GHC will have a .conf -- file containing just [] [([],_)] -> Nothing - rd -> Just $ display $ cfNm rd + rd -> Just $ CPV $ display $ cfNm rd where -- It's not InstalledPackageInfo, as it can't read the modules cfNm :: [([InstalledPackageInfo_ String], String)] -> PackageIdentifier @@ -143,7 +159,7 @@ case (map BS.words . BS.lines) cont of ( [name_key, bn] : [ver_key, bv] : _) | name_key == BS.pack "name:" && ver_key == BS.pack "version:" - -> Just $ BS.unpack bn ++ "-" ++ BS.unpack bv + -> Just $ CPV $ BS.unpack bn ++ "-" ++ BS.unpack bv _ -> Nothing -- Add this .conf file to the Map @@ -153,10 +169,10 @@ case ( parse_as_ghc_package cont , parse_as_cabal_package (BS.unpack cont) ) of - (Just dn, _) -> do vsay v $ unwords [conf, "resolved as ghc package:", dn] - return $ Map.insert dn conf cmp - (_, Just dn) -> do vsay v $ unwords [conf, "resolved as cabal package:", dn] - return $ Map.insert dn conf cmp + (Just dn, _) -> do vsay v $ unwords [conf, "resolved as ghc package:", unCPV dn] + return $ pushConf cmp dn conf + (_, Just dn) -> do vsay v $ unwords [conf, "resolved as cabal package:", unCPV dn] + return $ pushConf cmp dn conf -- empty files are created for -- phony packages like CABAL_CORE_LIB_GHC_PV -- and binary-only packages. @@ -244,40 +260,49 @@ brokenConfs v = do vsay v "brokenConfs: getting broken output from 'ghc-pkg'" ghc_pkg_brokens <- getBroken - -- Check if we actually have to go look up files and - -- do IO. vsay v $ unwords ["brokenConfs: resolving package names to gentoo equivalents." , show (length ghc_pkg_brokens) , "are broken:" - , L.intercalate " " ghc_pkg_brokens + , L.intercalate " " (map unCPV ghc_pkg_brokens) ] (orphan_broken, orphan_confs) <- getOrphanBroken vsay v $ unwords [ "checkPkgs: ghc .conf orphans:" , show (length orphan_broken) , "are orphan:" - , L.intercalate " " orphan_broken + , L.intercalate " " (map unCPV orphan_broken) ] installed_but_not_registered <- getNotRegistered v vsay v $ unwords [ "checkPkgs: ghc .conf not registered:" , show (length installed_but_not_registered) , "are not registered:" - , L.intercalate " " installed_but_not_registered + , L.intercalate " " (map unCPV installed_but_not_registered) ] - let all_broken = ghc_pkg_brokens ++ orphan_broken ++ installed_but_not_registered + registered_twice <- getRegisteredTwice v + vsay v $ unwords [ "checkPkgs: ghc .conf registered twice:" + , show (length registered_twice) + , "are registered twice:" + , L.intercalate " " (map unCPV registered_twice) + ] + let all_broken = concat [ ghc_pkg_brokens + , orphan_broken + , installed_but_not_registered + , registered_twice + ] + vsay v "brokenConfs: reading '*.conf' files" - cnfs <- readConf v "gentoo" + cnfs <- listConfFiles GentooConfs >>= foldConf v vsay v $ "brokenConfs: got " ++ show (Map.size cnfs) ++ " '*.conf' files" let (known_broken, orphans) = partitionEithers $ map (matchConf cnfs) all_broken - return (known_broken, orphan_confs ++ orphans) + return (known_broken, orphan_confs ++ L.concat orphans) -- Return the closure of all packages affected by breakage -- in format of ["name-version", ... ] getBroken :: IO [CabalPV] -getBroken = liftM words +getBroken = liftM (map CPV . words) $ ghcPkgRawOut ["check", "--simple-output"] getOrphanBroken :: IO ([CabalPV], [FilePath]) @@ -285,7 +310,7 @@ -- Around Jan 2015 we have started to install -- all the .conf files in 'src_install()' phase. -- Here we pick orphan ones and notify user about it. - registered_confs <- ghcLibDir >>= confFiles "package.conf.d" + registered_confs <- listConfFiles GHCConfs confs_to_pkgs <- resolveFiles registered_confs let (conf_files, _conf_pkgs) = unzip confs_to_pkgs orphan_conf_files = registered_confs L.\\ conf_files @@ -301,9 +326,25 @@ -- due to unregistration bugs in old eclass. getNotRegistered :: Verbosity -> IO [CabalPV] getNotRegistered v = do - installed_confs <- readConf v "gentoo" - registered_confs <- readConf v "package.conf.d" + installed_confs <- listConfFiles GentooConfs >>= foldConf v + registered_confs <- listConfFiles GHCConfs >>= foldConf v return $ Map.keys installed_confs L.\\ Map.keys registered_confs + +-- Return packages, that seem to have +-- been installed more, than once. +-- 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) +-- 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 +-- It's is easy to fix just by reinstalling transformers. +getRegisteredTwice :: Verbosity -> IO [CabalPV] +getRegisteredTwice v = do + registered_confs <- listConfFiles GHCConfs >>= foldConf v + let registered_twice = Map.filter (\fs -> length fs > 1) registered_confs + return $ Map.keys registered_twice -- ----------------------------------------------------------------------------- diff --git a/Distribution/Gentoo/Packages.hs b/Distribution/Gentoo/Packages.hs --- a/Distribution/Gentoo/Packages.hs +++ b/Distribution/Gentoo/Packages.hs @@ -1,3 +1,4 @@ +{-# Language TupleSections #-} {- | Module : Distribution.Gentoo.Packages Description : Dealing with installed packages on Gentoo. @@ -18,6 +19,7 @@ ) where import Data.Char(isDigit, isAlphaNum) +import Data.List(isPrefixOf) import Data.Maybe import qualified Data.ByteString.Char8 as BS import Data.ByteString.Char8(ByteString) @@ -186,12 +188,18 @@ liftM catMaybes $ do (flip concatMapM) categories $ \cat -> do maybe_pkgs <- getDirectoryContents' (pkgDBDir cat) - packages <- filterM (\pn' -> doesDirectoryExist $ pkgPath (cat, pn')) maybe_pkgs + packages <- filterM (isPackage . (cat,)) maybe_pkgs forM packages $ \pkg -> do let cp = (cat, pkg) cpn <- toPackage cp cont <- parseContents cp return $ p cpn cont + where + isPackage :: VCatPkg -> IO Bool + isPackage vcp@(_, vp) = do + c1 <- doesDirectoryExist $ pkgPath vcp + let c2 = not $ "-MERGING-" `isPrefixOf` vp + return $ c1 && c2 -- Find which packages have Content information that matches the -- provided predicate; to be used with the searching predicates diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -14,17 +14,21 @@ import Distribution.Gentoo.PkgManager import Distribution.Gentoo.Util -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(..), exitSuccess, exitWith) -import System.IO(hPutStrLn, stderr) -import Control.Monad(liftM, unless) -import System.Process(rawSystem) +import Control.Monad (liftM, unless) +import Data.Char (toLower) +import Data.Either (partitionEithers) +import Data.List (foldl1', nub) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromJust) +import qualified Data.Set as Set +import Data.Version (showVersion) +import qualified Paths_haskell_updater as Paths (version) +import System.Console.GetOpt +import System.Environment (getArgs, getProgName) +import System.Exit (ExitCode (..), exitSuccess, exitWith) +import System.IO (hPutStrLn, stderr) +import System.Process (rawSystem) import Output @@ -103,7 +107,7 @@ DepCheck -> do say v "Searching for Haskell libraries with broken dependencies." say v "" (pkgs, unknown_packages, unknown_files) <- brokenPkgs v - printUnknownPackagesLn unknown_packages + printUnknownPackagesLn (map unCPV unknown_packages) printUnknownFilesLn unknown_files pkgListPrintLn v "broken" (notGHC pkgs) return pkgs @@ -121,6 +125,7 @@ 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 $ " # ghc-pkg recache" say v $ " It will likely need one more 'haskell-updater' run." say v "" @@ -147,6 +152,17 @@ | PrintAndRun deriving (Eq, Ord, Show, Read) +type WithUserCmd = Either String WithCmd + +withCmdMap :: Map String WithCmd +withCmdMap = M.fromList [ ("print", PrintOnly) + , ("run", RunOnly) + , ("print-and-run", PrintAndRun) + ] + +defaultWithCmd :: String +defaultWithCmd = "print-and-run" + runCmd :: WithCmd -> String -> [String] -> IO a runCmd mode cmd args = case mode of RunOnly -> runCommand cmd args @@ -178,6 +194,7 @@ | QuietFlag | VerboseFlag | ListOnlyFlag + | Cmd String deriving (Eq, Ord, Show, Read) parseArgs :: PkgManager -> [String] -> Either String (RunModifier, Action) @@ -190,22 +207,25 @@ | (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) where (fls', as) = partitionBy flagToAction fls a = combineAllActions as - (opts, pms) = partitionBy flagToPM fls' + (fls'', pms) = partitionBy flagToPM fls' (bPms, pms') = partitionBy isValidPM pms + (opts, cmds') = partitionBy flagToCmd fls'' + (bCmds, cmds) = partitionBy isValidCmd cmds' pm = emptyElse dPM last pms' 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) . return $ bool UpdateDeep UpdateAsNeeded (hasFlag NoDeep) rm = RM { pkgmgr = pm , flags = pmFlags - -- We need to get Flags that represent this as well. - , withCmd = PrintAndRun + , withCmd = cmd , rawPMArgs = nonoptions , verbosity = case () of _ | hasFlag VerboseFlag -> Verbose @@ -227,6 +247,22 @@ flagToPM (PM pm) = Right $ choosePM pm flagToPM f = Left f +flagToCmd :: Flag -> Either Flag WithUserCmd +flagToCmd (Cmd cmd) = Right $ chooseCmd cmd +flagToCmd f = Left f + +chooseCmd :: String -> WithUserCmd +chooseCmd cmd = chooseCmd' $ map toLower cmd + where + chooseCmd' :: String -> WithUserCmd + chooseCmd' "run" = Right RunOnly + chooseCmd' "print" = Right PrintOnly + chooseCmd' "print-and-run" = Right PrintAndRun + chooseCmd' c = Left c + +isValidCmd :: WithUserCmd -> Either String WithCmd +isValidCmd = id + options :: [OptDescr Flag] options = [ Option ['c'] ["dep-check"] (NoArg Check) @@ -249,6 +285,9 @@ "Output only list of packages for rebuild. One package per line." , Option ['V'] ["version"] (NoArg VersionFlag) "Version information." + , Option [] ["action"] (ReqArg Cmd "action") + $ "Specify whether to run the PM command or just print it\n" + ++ actionList ++ defAction , Option ['q'] ["quiet"] (NoArg QuietFlag) "Print only fatal errors (to stderr)." , Option ['v'] ["verbose"] (NoArg VerboseFlag) @@ -262,6 +301,9 @@ \The default package manager is: " ++ defaultPMName ++ ",\n\ \which can be overriden with the \"PACKAGE_MANAGER\"\n\ \environment variable." + actionList = unlines . map (" * " ++) $ M.keys withCmdMap + defAction = "The last specified action is chosen.\n\ + \The default action is: " ++ defaultWithCmd -- ----------------------------------------------------------------------------- -- Printing information. @@ -289,9 +331,10 @@ 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 ++ " using GHC " ++ ver + 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) diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,5 +1,3 @@ -* Have the option to spit out the PM command to be used instead of using it. - * Pretty colours in output? * Detect packages that are installed but not registered with GHC. 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.8 +Version: 1.2.9 Synopsis: Rebuild Haskell dependencies in Gentoo Description: haskell-updater rebuilds Haskell packages on Gentoo after a GHC upgrade or a dependency upgrade. @@ -28,7 +28,8 @@ Maintainer: haskell@gentoo.org Cabal-Version: >= 1.6 Build-Type: Simple -Extra-Source-Files: TODO +Extra-Source-Files: TODO, + man/haskell-updater.1 Source-Repository head Type: git diff --git a/man/haskell-updater.1 b/man/haskell-updater.1 new file mode 100644 --- /dev/null +++ b/man/haskell-updater.1 @@ -0,0 +1,73 @@ +.TH HASKELL-UPDATER "1" "May 2014" "haskell-updater-1.2.1" "User Commands" +.SH NAME +haskell-updater \- Version 1.2.1 +.SH SYNOPSIS +.B haskell-updater +[\fIOptions \fR[\fI-- \fR[\fIPM options\fR]] +.SH DESCRIPTION +.SS "haskell-updater \fB\-\-\fR Find and rebuild packages broken due to either:" +.IP +\(bu GHC upgrade +.IP +\(bu Haskell dependency upgrade +.TP +Default action is to do both. +.SH OPTIONS + +.TP +\fB\-c\fR \fB\-\-dep\-check\fR +Check dependencies of Haskell packages. +.TP +\fB\-u\fR \fB\-\-upgrade\fR +Rebuild Haskell packages after a GHC upgrade. +.TP +\fB\-a\fR \fB\-\-all\fR +Rebuild all Haskell libraries built with current GHC. +.TP +\fB\-P\fR PM \fB\-\-package\-manager\fR=\fIPM\fR +Use package manager PM, where PM can be one of: +* paludis +* pkgcore +* portage +.IP +The last valid value of PM specified is chosen. +The default package manager is: portage, +which can be overriden with the "PACKAGE_MANAGER" +environment variable. +.TP +\fB\-C\fR command \fB\-\-custom\-pm\fR=\fIcommand\fR +Use custom command as package manager; +ignores the \fB\-\-pretend\fR and \fB\-\-no\-deep\fR flags. +.TP +\fB\-p\fR \fB\-\-pretend\fR +Only pretend to build packages. +.TP +\fB\-\-no\-deep\fR +Don't pull deep dependencies (\fB\-\-deep\fR with emerge). +.TP +\fB\-l\fR \fB\-\-list\-only\fR +Output only list of packages for rebuild. One package per line. +.TP +\fB\-V\fR \fB\-\-version\fR +Version information. +.TP +\fB\-q\fR \fB\-\-quiet\fR +Print only fatal errors (to stderr). +.TP +\fB\-v\fR \fB\-\-verbose\fR +Be more elaborate (to stderr). +.TP +\fB\-h\fR, \-? \fB\-\-help\fR +Print this help message. +.SH EXAMPLES +\(bu Look for broken packages and rebuild them: +.IP + $> haskell-updater +.TP +\(bu Rebuild all packages: +.IP + $> haskell-updater --all +.TP +\(bu Run haskell-updater and set an emerge flag, color. +.IP + $> haskell-updater -- --color=n