haskell-updater 1.3.3 → 1.4.0.0
raw patch · 9 files changed
+704/−310 lines, 9 files
Files
- CHANGELOG.md +22/−0
- Distribution/Gentoo/CmdLine.hs +238/−0
- Distribution/Gentoo/GHC.hs +96/−59
- Distribution/Gentoo/PkgManager.hs +28/−17
- Distribution/Gentoo/PkgManager/Types.hs +19/−0
- Distribution/Gentoo/Types.hs +115/−0
- Main.hs +141/−230
- README.md +36/−0
- haskell-updater.cabal +9/−4
+ CHANGELOG.md view
@@ -0,0 +1,22 @@+## v1.4.0.0 (2024-05-25)++Release v1.4.0.0++- Add new options for portage invocation++ - Add `--mode=reinstall-atoms` (`-R`)+ - Add `--world` (`-W`)++ This adds new functionality to haskell-updater which utilizes the+ --reinstall-atoms flag for portage. This should bypass issues where+ haskell-updater pulls in masked or unavailable packages and attempts to+ pull them into the dependency graph. This will remain as optional pending+ further testing.++- Add new flags to the command line to help organize functionality:++ - `--target={invalid|all|world}`+ - `--mode={basic|list|reinstall-atoms}`++- Fix bug where some installed package `.conf` files do not get parsed+ properly
+ Distribution/Gentoo/CmdLine.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Distribution.Gentoo.CmdLine+ ( parseArgs+ , options+ ) where++import Control.Monad ((>=>))+import Data.Char (toLower)+import qualified Data.List as L+import Data.Proxy+import System.Console.GetOpt++import Distribution.Gentoo.PkgManager+import Distribution.Gentoo.PkgManager.Types+import Distribution.Gentoo.Types+import Output++-- -----------------------------------------------------------------------------+-- Command-line flags++-- | A class for multiple-choice options selected by an argument on the command+-- line+class (Eq a, Enum a, Bounded a) => CmdlineOpt a where+ -- | Define the short name and an optional description for a constructor+ argInfo :: a -> (String, Maybe String)+ -- | Define the short name for the multiple-choice argument as a whole+ --+ -- e.g. @"action"@+ optName :: Proxy a -> String+ -- | Define the description for the multiple-choice argument as a whole+ --+ -- e.g. @"Specify whether to run the PM command or just print it"@+ optDescription :: Proxy a -> String+ -- | Define the default constructor for the multiple-choice argument+ --+ -- e.g. 'PrintAndRun'+ optDefault :: Proxy a -> a++instance CmdlineOpt WithCmd where+ argInfo PrintAndRun = ("print-and-run", Nothing)+ argInfo PrintOnly = ("print", Nothing)+ argInfo RunOnly = ("run", Nothing)++ optName _ = "action"+ optDescription _ =+ "Specify whether to run the PM command or just print it"+ optDefault _ = PrintAndRun++instance CmdlineOpt BuildTarget where+ argInfo OnlyInvalid = ("invalid", Just "broken Haskell packages")+ argInfo AllInstalled = ("all", Just "all installed Haskell packages")+ argInfo WorldTarget =+ ( "world"+ , Just $ "@world set (only valid with portage package\n"+ ++ "manager and reinstall-atoms mode)"+ )++ optName _ = "target"+ optDescription _ =+ "Choose the type of packages for the PM to target"+ optDefault _ = OnlyInvalid++instance CmdlineOpt HackportMode where+ argInfo BasicMode = ("basic", Just "classic haskell-updater behavior")+ argInfo ListMode =+ ( "list"+ , Just $ "just print a list of packages for rebuild,\n"+ ++ "one package per line"+ )+ argInfo ReinstallAtomsMode =+ ( "reinstall-atoms"+ , Just $ "experimental portage invocation using\n"+ ++ "--reinstall-atoms (may be more useful in\n"+ ++ "some situations)" )++ optName _ = "mode"+ optDescription _ =+ "Mode of operation for haskell-updater"+ optDefault _ = BasicMode++argString :: CmdlineOpt a => a -> String+argString = fst . argInfo++argDescription :: CmdlineOpt a => a -> Maybe String+argDescription = snd . argInfo++argHelp :: forall a. CmdlineOpt a => Proxy a -> String+argHelp _ = unlines $ [mainDesc] ++ (args >>= argLine)+ where+ mainDesc = optDescription (Proxy @a)+ argLine a = case (L.lookup a argFields, argDescription a) of+ (Nothing, _) -> []+ (Just s, Nothing) -> [s]+ (Just s, Just d) -> case lines d of+ (l:ls) -> [paddedFst s l] ++ (paddedRest <$> ls)+ _ -> []+ paddedFst s d =+ s ++ replicate (padMax - length s) ' ' ++ " : " ++ d+ paddedRest d = replicate (padMax + 3) ' ' ++ d+ padMax = maximum $ length . snd <$> argFields+ argFields = (\a -> (a, showArg a)) <$> args+ showArg a = " * " ++ argString a ++ showDef a+ showDef a+ | optDefault (Proxy @a) == a = " (default)"+ | otherwise = ""+ args = [minBound :: a .. maxBound]++fromCmdline+ :: forall a. CmdlineOpt a+ => (a -> RunModifier -> RunModifier)+ -> String+ -> RunModifier+ -> Either String RunModifier+fromCmdline update s rm =+ case L.find (\a -> argString a == lowerS) args of+ Nothing -> Left $ "Unknown " ++ name ++ ": " ++ lowerS+ Just a -> Right $ update a rm+ where+ lowerS = map toLower s+ name = optName $ Proxy @a+ args = [minBound :: a .. maxBound]++parseArgs :: PkgManager -> [String] -> Either String RunModifier+parseArgs defPM args = case getOpt' Permute options args of+ (_, _, _, errs@(_:_)) -> Left $ unwords $ "Errors in arguments:" : errs+ (_, _, unk@(_:_), _) -> Left $ unwords $ "Unknown options:" : unk+ (fs, raw, _, _) ->+ postProcessRM <$> foldr (>=>) pure fs (defRunModifier defPM raw)++defRunModifier :: PkgManager -> [String] -> RunModifier+defRunModifier defPM raw = RM+ { pkgmgr = defPM+ , flags = []+ , withCmd = optDefault $ Proxy @WithCmd+ , rawPMArgs = raw+ , verbosity = Normal+ , showHelp = False+ , showVer = False+ , target = OnlyInvalid+ , mode = BasicMode+ }++-- | Make sure there is at least one of 'UpdateAsNeeded' or 'UpdateDeep'+-- in 'flags'.+postProcessRM :: RunModifier -> RunModifier+postProcessRM rm = rm { flags = flags' }+ where+ flags'+ | or $ [(==UpdateAsNeeded), (==UpdateDeep)] <*> nubFlags = nubFlags+ | otherwise = UpdateDeep : nubFlags+ nubFlags = L.nub (flags rm)++options :: [OptDescr (RunModifier -> Either String RunModifier)]+options =+ [ Option ['P'] ["package-manager"]+ (ReqArg mkPM "PM")+ $ "Use package manager PM, where PM can be one of:\n"+ ++ pmList ++ defPM+ , Option ['C'] ["custom-pm"]+ (ReqArg (\s r -> pure $ r { pkgmgr = CustomPM s }) "command")+ $ "Use custom command as package manager;\n"+ ++ "ignores the --pretend and --no-deep flags."+ , Option ['p'] ["pretend"]+ (naUpdate $ \r -> r { flags = PretendBuild : flags r } )+ "Only pretend to build packages."+ , Option [] ["no-deep"]+ (naUpdate $ \r -> r { flags = UpdateAsNeeded : flags r } )+ "Don't pull deep dependencies (--deep with emerge)."+ , Option ['V'] ["version"]+ (naUpdate $ \r -> r { showVer = True })+ "Version information."+ , Option [] ["action"]+ (ReqArg (fromCmdline (\a r -> r { withCmd = a })) "action")+ (argHelp (Proxy @WithCmd))+ , Option [] ["target"]+ (ReqArg (fromCmdline (\a r -> r { target = a })) "target")+ (argHelp (Proxy @BuildTarget))+ , Option ['c'] ["dep-check"]+ (naUpdate $ \r -> r { target = OnlyInvalid })+ $ "alias for --target=" ++ argString OnlyInvalid+ -- deprecated alias for 'dep-check'+ , Option ['u'] ["upgrade"]+ (naUpdate $ \r -> r { target = OnlyInvalid })+ $ "alias for --target=" ++ argString OnlyInvalid+ , Option ['a'] ["all"]+ (naUpdate $ \r -> r { target = AllInstalled })+ $ "alias for --target=" ++ argString AllInstalled+ , Option ['W'] ["world"]+ (naUpdate $ \r -> r+ { pkgmgr = Portage+ , target = WorldTarget+ , mode = ReinstallAtomsMode+ }+ ) $ "alias for --package-manager=portage"+ ++ " \\\n --target=" ++ argString WorldTarget+ ++ " \\\n --mode=" ++ argString ReinstallAtomsMode+ , Option [] ["mode"]+ (ReqArg (fromCmdline (\a r -> r { mode = a })) "mode")+ (argHelp (Proxy @HackportMode))+ , Option ['l'] ["list-only"]+ (naUpdate $ \r -> r { mode = ListMode })+ $ "alias for --mode=" ++ argString ListMode+ , Option ['R'] ["reinstall-atoms"]+ (naUpdate $ \r -> r { mode = ReinstallAtomsMode })+ $ "alias for --mode=" ++ argString ReinstallAtomsMode+ , Option ['q'] ["quiet"]+ (naUpdate $ \r -> r { verbosity = Quiet })+ "Print only fatal errors (to stderr)."+ , Option ['v'] ["verbose"]+ (naUpdate $ \r -> r { verbosity = Verbose })+ "Be more elaborate (to stderr)."+ , Option ['h', '?'] ["help"]+ (naUpdate $ \r -> r { showHelp = True })+ "Print this help message."+ ]++ where+ naUpdate f = NoArg (pure . f)++ -- This touches some legacy code so we need a custom handler for it+ mkPM :: String -> RunModifier -> Either String RunModifier+ mkPM s rm = case choosePM s of+ InvalidPM pm -> Left $ "Unknown package manager: " ++ pm+ Portage -> Right $ rm { pkgmgr = Portage }+ Paludis -> Right $ rm { pkgmgr = Paludis }+ PkgCore -> Right $ rm { pkgmgr = PkgCore }+ CustomPM _ -> undefined++ 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."+++
Distribution/Gentoo/GHC.hs view
@@ -24,16 +24,18 @@ -- Cabal imports import qualified Distribution.Simple.Utils as DSU import Distribution.Verbosity(silent)-import Distribution.Package(packageId)-import Distribution.InstalledPackageInfo(InstalledPackageInfo)+import Distribution.Package(mungedId)+import Distribution.InstalledPackageInfo+ (InstalledPackageInfo(sourceLibName), parseInstalledPackageInfo) import Distribution.Text(display)+import Distribution.Types.LibraryName (LibraryName(..)) -- Other imports import Data.Char(isDigit) import Data.Either(partitionEithers) import Data.Maybe import qualified Data.List as L-import qualified Data.Map as Map+import qualified Data.Map.Strict as Map import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BL8 import System.FilePath((</>), takeExtension, pathSeparator)@@ -109,20 +111,15 @@ ghcPkgLoc :: IO FilePath ghcPkgLoc = fromJust <$> findExecutable "ghc-pkg" -data ConfSubdir = GHCConfs- | GentooConfs--subdirToDirname :: ConfSubdir -> FilePath-subdirToDirname subdir =- case subdir of- GHCConfs -> "package.conf.d"- GentooConfs -> "gentoo"+ghcConfsPath, gentooConfsPath :: FilePath+ghcConfsPath = "package.conf.d"+gentooConfsPath = "gentoo" -- Return the Gentoo .conf files found in this GHC libdir-listConfFiles :: ConfSubdir -> IO [FilePath]+listConfFiles :: FilePath -> IO [FilePath] listConfFiles subdir = do dir <- ghcLibDir- let gDir = dir </> subdirToDirname subdir+ let gDir = dir </> subdir exists <- doesDirectoryExist gDir if exists then do conts <- listDirectory gDir@@ -132,23 +129,12 @@ where isConf file = takeExtension file == ".conf" -tryMaybe :: (a -> Maybe b) -> a -> Either a b-tryMaybe f a = maybe (Left a) Right $ f a- newtype CabalPV = CPV { unCPV :: String } -- serialized 'PackageIdentifier' deriving (Ord, Eq, Show) -- 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 = tryMaybe . flip Map.lookup- -- Fold Gentoo .conf files from the current GHC version and -- create a Map foldConf :: Verbosity -> [FilePath] -> IO ConfMap@@ -156,16 +142,11 @@ -- cabal package text format -- "[InstalledPackageInfo {installedPackageId = Insta..."-parse_as_cabal_package :: String -> Maybe CabalPV+parse_as_cabal_package :: BS.ByteString -> Maybe InstalledPackageInfo parse_as_cabal_package cont =- case reads cont of- [] -> Nothing- -- ebuilds that have CABAL_CORE_LIB_GHC_PV set- -- for this version of GHC will have a .conf- -- file containing just []- (([] ,_):_) -> Nothing- ((i:_,_):_) -> Just $ CPV $ display- $ packageId (i :: InstalledPackageInfo)+ case parseInstalledPackageInfo cont of+ Left _es -> Nothing+ Right (_ws, ipi) -> Just ipi -- ghc package text format -- "name: zlib-conduit\n@@ -179,29 +160,49 @@ -> Just $ CPV $ BS.unpack bn ++ "-" ++ BS.unpack bv _ -> Nothing --- Add this .conf file to the Map+-- | Add this .conf file to the Map+--+-- NOTE: It is important that the 'CabalPV's that are added to the 'ConfMap'+-- should be in their "munged form", which may be z-encoded+--+-- See:+-- * <https://hackage.haskell.org/package/Cabal-syntax-3.12.0.0/docs/Distribution-Types-MungedPackageName.html>+-- * <https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/symbol-names> addConf :: Verbosity -> ConfMap -> FilePath -> IO ConfMap addConf v cmp conf = do- cont <- BS.readFile conf- 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:", show dn]- return $ pushConf cmp dn conf- (_, Just dn) -> do vsay v $ unwords [conf, "resolved as cabal package:", show dn]- return $ pushConf cmp dn conf- -- empty files are created for- -- phony packages like CABAL_CORE_LIB_GHC_PV- -- and binary-only packages.- _ | BS.null cont- -> return cmp- _ -> do say v $ unwords [ "failed to parse"- , show conf- , ":"- , show (BS.take 30 cont)- ]- return cmp+ bs <- BS.readFile conf+ case+ ( BS.null bs+ , parse_as_ghc_package bs+ , parse_as_cabal_package bs+ ) of+ -- empty files are created for+ -- phony packages like CABAL_CORE_LIB_GHC_PV+ -- and binary-only packages.+ (True, _ , _ ) -> pure cmp+ -- 'parse_as_ghc_package' is more efficient, so try it first+ (_ , Just dn, _ ) -> do+ vsay v $ unwords [conf, "resolved as ghc package:", show dn]+ pure $ pushConf cmp dn conf+ -- 'parse_as_cabal_package' is more flexible, so use it as a fallback+ (_ , _ , Just ipi) -> do+ let cpv = toCPV ipi+ vsay v $ unwords [conf, "resolved as cabal package:", show (cpv, ipi)]+ pure $ pushConf cmp cpv conf+ _ -> do+ say v $ unwords+ [ "failed to parse", show conf, ":", show (BS.take 30 bs)]+ return cmp+ where+ pushConf :: ConfMap -> CabalPV -> FilePath -> ConfMap+ pushConf m k fp = Map.insertWith (++) k [fp] m + -- 'MungedPackageId's get displayed using the z-encoded format, so are+ -- compatible with ghc-pkg. This is important for resolving broken packages+ -- (reported by ghc-pkg) to @.conf@ files!+ toCPV :: InstalledPackageInfo -> CabalPV+ toCPV = CPV . display . mungedId+ checkPkgs :: Verbosity -> ([CabalPV], [FilePath]) -> IO ([Package],[CabalPV],[FilePath])@@ -325,10 +326,18 @@ ] vsay v "brokenConfs: reading '*.conf' files"- cnfs <- listConfFiles GentooConfs >>= foldConf v+ cnfs <- listConfFiles gentooConfsPath >>= 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 ++ L.concat orphans)+ where+ -- Attempt to match the provided broken package to one of the+ -- installed packages.+ matchConf :: ConfMap -> CabalPV -> Either CabalPV [FilePath]+ matchConf cmp cpv =+ case Map.lookup cpv cmp of+ Just fps -> Right fps+ Nothing -> Left cpv -- Return the closure of all packages affected by breakage -- in format of ["name-version", ... ]@@ -341,7 +350,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 <- listConfFiles GHCConfs+ registered_confs <- listConfFiles ghcConfsPath confs_to_pkgs <- resolveFiles registered_confs let (conf_files, _conf_pkgs) = unzip confs_to_pkgs orphan_conf_files = registered_confs L.\\ conf_files@@ -357,8 +366,8 @@ -- due to unregistration bugs in old eclass. getNotRegistered :: Verbosity -> IO [CabalPV] getNotRegistered v = do- installed_confs <- listConfFiles GentooConfs >>= foldConf v- registered_confs <- listConfFiles GHCConfs >>= foldConf v+ installed_confs <- listConfFiles gentooConfsPath >>= foldConf v+ registered_confs <- listConfFiles ghcConfsPath >>= foldConf v return $ Map.keys installed_confs L.\\ Map.keys registered_confs -- Return packages, that seem to have@@ -373,9 +382,37 @@ -- It's is easy to fix just by reinstalling transformers. getRegisteredTwice :: Verbosity -> IO [CabalPV] getRegisteredTwice v = do- registered_confs <- listConfFiles GHCConfs >>= foldConf v+ registered_confs <- listConfFiles ghcConfsPath >>= foldConf v let registered_twice = Map.filter (\fs -> length fs > 1) registered_confs- return $ Map.keys registered_twice++ -- Double check that all of the "duplicates" are main libraries, since+ -- a package may also have one or more sub-libraries registered as+ -- well.+ rtMainLibs <- foldM+ (\m k -> Map.alterF onlyMultipleMains k m)+ registered_twice+ (Map.keys registered_twice)++ return $ Map.keys rtMainLibs+ where+ -- Filter out all but entries with multiple main libraries+ onlyMultipleMains :: Maybe [FilePath] -> IO (Maybe [FilePath])+ onlyMultipleMains (Just fps@(_:_)) = do+ fps' <- filterM filterMain fps+ -- Remove entries with one or less elements, since they are no longer+ -- relevant to the getRegisteredTwice function+ pure $ if length fps' <= 1 then Nothing else Just fps'+ onlyMultipleMains _ = pure Nothing++ -- Only keep conf files that correspond to main libraries. This runs+ -- 'parse_as_cabal_package' to get+ filterMain :: FilePath -> IO Bool+ filterMain conf = do+ bs <- BS.readFile conf+ let ipi = parse_as_cabal_package bs+ pure $ case sourceLibName <$> ipi of+ Just LMainLibName -> True+ _ -> False -- -----------------------------------------------------------------------------
Distribution/Gentoo/PkgManager.hs view
@@ -7,19 +7,19 @@ This module defines ways to use different Gentoo package managers. -} module Distribution.Gentoo.PkgManager- ( PkgManager- , definedPMs+ ( definedPMs , choosePM , stringToCustomPM , isValidPM , defaultPM , defaultPMName , nameOfPM- , PMFlag(..) , buildCmd+ , buildAltCmd ) where import Distribution.Gentoo.Packages+import Distribution.Gentoo.PkgManager.Types import Data.Char(toLower) import Data.Maybe(mapMaybe, fromMaybe)@@ -29,14 +29,6 @@ -- ----------------------------------------------------------------------------- --- | Defines the available Gentoo package managers.-data PkgManager = Portage- | PkgCore- | Paludis- | InvalidPM String- | CustomPM String- deriving (Eq, Ord, Show, Read)- -- | The default package manager. If the environment variable -- @PACKAGE_MANAGER@ exists, use that; otherwise default to -- "portage". Note that even if that environment variable is@@ -115,13 +107,32 @@ fs' = defaultPMFlags pm ++ mapMaybe (flagRep pm) fs ++ raw_pm_flags ps' = map printPkg ps --- -----------------------------------------------------------------------------+-- | Alternative version of 'buildCmd' which uses experimental @emerge@+-- invocation (using @--reinstall-atoms@). This is only to be used with the+-- 'Portage' 'PkgManager'.+--+-- The rationale is that by marking broken packages by using+-- @--reinstall-atoms@, portage will pretend that they are not yet+-- installed, thus forcing their reinstallation. @--update@ is+-- used and all installed Haskell packages are targeted so that the entire+-- Haskell environment is examined. This has a side-effect of skipping+-- packages that are masked or otherwise unavailable while still rebuilding+-- needed dependencies that have been broken.+buildAltCmd+ :: [PMFlag] -- ^ Basic flags+ -> [String] -- ^ User-supplied flags+ -> [Package] -- ^ List of packages to rebuild+ -- | List of /all/ installed haskell packages ('Nothing' denotes a @world@ target)+ -> Maybe [Package]+ -> (String, [String])+buildAltCmd fs rawPmFlags ps allPs =+ (pmCommand Portage, fs' ++ reinst ++ rawPmFlags ++ allPs')+ where+ fs' = defaultPMFlags Portage ++ mapMaybe (flagRep Portage) fs ++ ["--update"]+ reinst = ["--reinstall-atoms", unwords (map printPkg ps)]+ allPs' = maybe ["@world"] (map printPkg) allPs --- | Different optional flags to be passed to the PM.-data PMFlag = PretendBuild- | UpdateDeep- | UpdateAsNeeded- deriving (Eq, Ord, Show, Read)+-- ----------------------------------------------------------------------------- flagRep :: PkgManager -> PMFlag -> Maybe String flagRep Portage = portagePMFlag
+ Distribution/Gentoo/PkgManager/Types.hs view
@@ -0,0 +1,19 @@++module Distribution.Gentoo.PkgManager.Types+ ( PkgManager(..)+ , PMFlag(..)+ ) where++-- | Defines the available Gentoo package managers.+data PkgManager = Portage+ | PkgCore+ | Paludis+ | InvalidPM String+ | CustomPM String+ deriving (Eq, Ord, Show, Read)++-- | Different optional flags to be passed to the PM.+data PMFlag = PretendBuild+ | UpdateDeep+ | UpdateAsNeeded+ deriving (Eq, Ord, Show, Read)
+ Distribution/Gentoo/Types.hs view
@@ -0,0 +1,115 @@++module Distribution.Gentoo.Types+ ( RunModifier(..)+ , WithCmd(..)+ , WithUserCmd+ , BuildTarget(..)+ , HackportMode(..)+ , PackageState(..)+ , DefaultModePkgs(..)+ , ListModePkgs(..)+ , RAModePkgs(..)+ , HasTargets(..)+ , InvalidPkgs(..)+ , AllPkgs(..)+ , PackageList(..)+ ) where++import Distribution.Gentoo.Packages+import Distribution.Gentoo.PkgManager.Types+import Output++-- | Full haskell-updater state+data RunModifier = RM { pkgmgr :: PkgManager+ , flags :: [PMFlag]+ , withCmd :: WithCmd+ , rawPMArgs :: [String]+ , verbosity :: Verbosity+ , showHelp :: Bool+ , showVer :: Bool+ , target :: BuildTarget+ , mode :: HackportMode+ }+ deriving (Eq, Ord, Show)++data WithCmd = PrintAndRun+ | PrintOnly+ | RunOnly+ deriving (Eq, Ord, Show, Read, Enum, Bounded)++type WithUserCmd = Either String WithCmd++data BuildTarget+ = OnlyInvalid -- ^ Default+ | AllInstalled -- ^ Rebuild every haskell package+ | WorldTarget -- ^ Target @world portage set+ deriving (Eq, Ord, Show, Read, Enum, Bounded)++data HackportMode+ = BasicMode+ | ListMode+ | ReinstallAtomsMode+ deriving (Show, Eq, Ord, Enum, Bounded)++-- | The current package list(s) organized by mode and build target+data PackageState+ = DefaultModeState (Maybe DefaultModePkgs)+ | ListModeState ListModePkgs+ | RAModeState (Maybe RAModePkgs)+ deriving (Show, Eq, Ord)++data DefaultModePkgs+ = DefaultInvalid InvalidPkgs+ | DefaultAll AllPkgs+ deriving (Show, Eq, Ord)++data ListModePkgs+ = ListInvalid InvalidPkgs+ | ListAll AllPkgs+ deriving (Show, Eq, Ord)++data RAModePkgs+ = RAModeInvalid AllPkgs InvalidPkgs+ | RAModeAll AllPkgs+ | RAModeWorld InvalidPkgs+ deriving (Show, Eq, Ord)++class HasTargets t where+ targets :: t -> [Package]++instance HasTargets PackageState where+ targets (DefaultModeState ps) = targets ps+ targets (ListModeState ps) = targets ps+ targets (RAModeState ps) = targets ps++instance HasTargets DefaultModePkgs where+ targets (DefaultInvalid ps) = getPkgs ps+ targets (DefaultAll ps) = getPkgs ps++instance HasTargets ListModePkgs where+ targets (ListInvalid ps) = getPkgs ps+ targets (ListAll ps) = getPkgs ps++instance HasTargets RAModePkgs where+ targets (RAModeInvalid _ ps) = getPkgs ps+ targets (RAModeAll ps) = getPkgs ps+ targets (RAModeWorld ps) = getPkgs ps++instance HasTargets t => HasTargets (Maybe t) where+ targets (Just ps) = targets ps+ targets Nothing = []++newtype InvalidPkgs = InvalidPkgs [Package]+ deriving (Show, Eq, Ord)++newtype AllPkgs = AllPkgs [Package]+ deriving (Show, Eq, Ord)++class PackageList t where+ getPkgs :: t -> [Package]++instance PackageList InvalidPkgs where+ getPkgs (InvalidPkgs ps) = ps++instance PackageList AllPkgs where+ getPkgs (AllPkgs ps) = ps
Main.hs view
@@ -7,20 +7,22 @@ The executable module of haskell-updater, which finds Haskell packages to rebuild after a dep upgrade or a GHC upgrade. -}++{-# LANGUAGE LambdaCase #-}+ module Main (main) where +import Distribution.Gentoo.CmdLine import Distribution.Gentoo.GHC import Distribution.Gentoo.Packages import Distribution.Gentoo.PkgManager+import Distribution.Gentoo.PkgManager.Types+import Distribution.Gentoo.Types import Control.Monad (unless) import qualified Control.Monad as CM-import Data.Char (toLower)-import Data.Either (partitionEithers)-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 import Data.Version (showVersion) import qualified Paths_haskell_updater as Paths (version)@@ -61,244 +63,163 @@ runDriver :: RunModifier -> IO a runDriver rm = do- systemInfo v rm t+ systemInfo v rm t md updaterPass 1 initialHistory success v "done!"- where v = verbosity rm- 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- dumpHistory v pastHistory- die "Updater stuck in the loop and can't progress"+ where+ v = verbosity rm+ t = target rm+ md = mode rm - exitCode <- buildPkgs rm ps+ updaterPass :: Int -> DriverHistory -> IO ()+ updaterPass n pastHistory = getPackageState rm >>= \case+ ListModeState m -> do+ mapM_ (putStrLn . printPkg) (targets m)+ success v "done!"+ DefaultModeState (Just (DefaultInvalid ts)) ->+ continuePass (Left . DefaultInvalid) False ts+ DefaultModeState (Just (DefaultAll ts)) ->+ continuePass (Left . DefaultAll) True ts+ DefaultModeState Nothing -> alertDone+ RAModeState (Just (RAModeInvalid ps ts)) ->+ continuePass (Right . RAModeInvalid ps) False ts+ RAModeState (Just (RAModeAll ts)) ->+ continuePass (Right . RAModeAll) True ts+ RAModeState (Just (RAModeWorld ts)) ->+ continuePass (Right . RAModeWorld) True ts+ RAModeState Nothing -> alertDone - -- 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+ where -data BuildTarget = OnlyInvalid- | AllInstalled -- Rebuild every haskell package- deriving (Eq, Ord, Show, Read)+ alertDone = success (verbosity rm) "\nNothing to build!" -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+ continuePass+ :: PackageList ts+ => (ts -> Either DefaultModePkgs RAModePkgs)+ -> Bool+ -> ts+ -> IO ()+ continuePass cnst allTarget ts = do+ CM.when (Set.fromList (getPkgs ts) `M.member` pastHistory) $ do+ dumpHistory v pastHistory+ die "Updater stuck in the loop and can't progress" - 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)+ exitCode <- buildPkgs rm (cnst ts) - return $ Set.toList $ Set.fromList $ old ++ broken+ -- don't try rerun rebuilder for cases where there+ -- is no chance to converge to empty set+ CM.when allTarget $ exitWith exitCode - AllInstalled -> do say v "Searching for packages installed with the current version of GHC."- say v ""- pkgs <- allInstalledPackages- pkgListPrintLn v "installed" pkgs- return pkgs+ updaterPass (n + 1) $ M.insert (Set.fromList (getPkgs ts)) n pastHistory - where printUnknownPackagesLn [] = return ()- printUnknownPackagesLn ps =- do say v "The following packages are orphan (not installed by your package manager):"- printList v id ps- say v ""- printUnknownFilesLn [] = return ()- printUnknownFilesLn fs =- do say v $ "The following files are orphan (not installed by your package manager):"- printList v id fs- 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 $(ghc --print-libdir)/gentoo/*.conf`"- say v $ " # ghc-pkg recache"- say v $ " It will likely need one more 'haskell-updater' run."- say v ""+getPackageState :: RunModifier -> IO PackageState+getPackageState rm =+ case (mode rm, target rm, pkgmgr rm) of+ -- world target+ (ReinstallAtomsMode, WorldTarget, Portage) ->+ RAModeState . checkForNull RAModeWorld <$> getInvalid+ (_, WorldTarget, Portage) -> die+ "\"world\" target is only valid with reinstall-atoms mode"+ (ReinstallAtomsMode, WorldTarget, _) -> die+ "\"world\" target is only valid with portage package manager"+ (_, WorldTarget, _) -> die $ unwords+ ["\"world\" target is only valid with reinstall-atoms mode and portage"+ , "package manager"]+ -- list mode+ (ListMode, OnlyInvalid, _) ->+ ListModeState . ListInvalid <$> getInvalid+ (ListMode, AllInstalled, _) ->+ ListModeState . ListAll <$> getAll+ -- default mode+ (BasicMode, OnlyInvalid, _) ->+ DefaultModeState . checkForNull DefaultInvalid <$> getInvalid+ (BasicMode, AllInstalled, _) ->+ DefaultModeState . checkForNull DefaultAll <$> getAll+ -- reinstall-atoms mode+ (ReinstallAtomsMode, OnlyInvalid, Portage) -> getInvalid >>= \is ->+ RAModeState <$> if null (getPkgs is)+ then pure Nothing+ else Just . flip RAModeInvalid is <$> getAll+ (ReinstallAtomsMode, AllInstalled, Portage) ->+ RAModeState . checkForNull RAModeAll <$> getAll+ (ReinstallAtomsMode, _, _) -> die+ "reinstall-atoms mode is only valid with portage package manager"+ where+ getInvalid = do+ say v "Searching for packages installed with a different version of GHC."+ say v ""+ old <- oldGhcPkgs v+ pkgListPrintLn v "old" old --- 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)+ 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) -data WithCmd = RunOnly- | PrintOnly- | PrintAndRun- deriving (Eq, Ord, Show, Read)+ return $ InvalidPkgs $ Set.toList $ Set.fromList $ old ++ broken -type WithUserCmd = Either String WithCmd+ getAll = do+ say v "Searching for packages installed with the current version of GHC."+ say v ""+ pkgs <- allInstalledPackages+ pkgListPrintLn v "installed" pkgs+ return $ AllPkgs pkgs -withCmdMap :: Map String WithCmd-withCmdMap = M.fromList [ ("print", PrintOnly)- , ("run", RunOnly)- , ("print-and-run", PrintAndRun)- ]+ checkForNull :: PackageList ts => (ts -> b) -> ts -> Maybe b+ checkForNull cnst l+ | null (getPkgs l) = Nothing+ | otherwise = Just (cnst l) -defaultWithCmd :: String-defaultWithCmd = "print-and-run"+ printUnknownPackagesLn [] = return ()+ printUnknownPackagesLn ps = do+ say v "The following packages are orphan (not installed by your package manager):"+ printList v id ps+ say v ""+ printUnknownFilesLn [] = return ()+ printUnknownFilesLn fs = do+ say v $ "The following files are orphan (not installed by your package manager):"+ printList v id fs+ 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 $(ghc --print-libdir)/gentoo/*.conf`"+ say v $ " # ghc-pkg recache"+ say v $ " It will likely need one more 'haskell-updater' run."+ say v "" + v = verbosity rm+ runCmd :: WithCmd -> String -> [String] -> IO ExitCode-runCmd mode cmd args = case mode of+runCmd m cmd args = case m of RunOnly -> runCommand cmd args PrintOnly -> putStrLn cmd_line >> exitSuccess PrintAndRun -> putStrLn cmd_line >> runCommand cmd args- where cmd_line = unwords (cmd:args)+ where+ cmd_line = unwords (cmd : (showArg <$> args))+ showArg s+ | words s == [s] = s+ | otherwise = show s -- Put quotes around args with spaces in them runCommand :: String -> [String] -> IO ExitCode runCommand cmd args = rawSystem cmd args -buildPkgs :: RunModifier -> [Package] -> IO ExitCode-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- | FixInvalid- | RebuildAll- | Pretend- | NoDeep- | QuietFlag- | VerboseFlag- | ListOnlyFlag- | Cmd String- deriving (Eq, Ord, Show, Read)--parseArgs :: PkgManager -> [String] -> Either String RunModifier-parseArgs defPM args = argParser defPM $ getOpt' Permute options args--argParser :: PkgManager- -> ([Flag], [String], [String], [String])- -> 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- where- (fls', ts) = partitionBy flagToTarget 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 id (PretendBuild:) (hasFlag Pretend)- . return $ bool UpdateDeep UpdateAsNeeded (hasFlag NoDeep)- rm = RM { pkgmgr = pm- , flags = pmFlags- , withCmd = cmd- , rawPMArgs = nonoptions- , verbosity = case () of- _ | hasFlag VerboseFlag -> Verbose- _ | hasFlag QuietFlag -> Quiet- _ -> Normal- , listOnly = hasFlag ListOnlyFlag- , showVer = hasFlag VersionFlag- , showHelp = hasFlag HelpFlag- , target = last $ OnlyInvalid : ts- }--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-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+buildPkgs :: RunModifier -> Either DefaultModePkgs RAModePkgs -> IO ExitCode+buildPkgs rm ts = runCmd (withCmd rm) cmd args 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 FixInvalid)- "Check dependencies of Haskell packages."- -- 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."- , 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 [] ["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)- "Be more elaborate (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."- actionList = unlines . map (" * " ++) $ M.keys withCmdMap- defAction = "The last specified action is chosen.\n\- \The default action is: " ++ defaultWithCmd+ (cmd, args) = case ts of+ Left (DefaultInvalid (InvalidPkgs ps)) ->+ buildCmd (pkgmgr rm) (flags rm) (rawPMArgs rm) ps+ Left (DefaultAll (AllPkgs ps)) ->+ buildCmd (pkgmgr rm) (flags rm) (rawPMArgs rm) ps+ Right (RAModeInvalid (AllPkgs allPs) (InvalidPkgs ps)) ->+ buildAltCmd (flags rm) (rawPMArgs rm) ps (Just allPs)+ Right (RAModeAll (AllPkgs allPs)) ->+ buildAltCmd (flags rm) (rawPMArgs rm) allPs (Just allPs)+ Right (RAModeWorld (InvalidPkgs ps)) ->+ buildAltCmd (flags rm) (rawPMArgs rm) ps Nothing -- ----------------------------------------------------------------------------- -- Printing information.@@ -322,8 +243,8 @@ , "" , "Options:"] -systemInfo :: Verbosity -> RunModifier -> BuildTarget -> IO ()-systemInfo v rm t = do+systemInfo :: Verbosity -> RunModifier -> BuildTarget -> HackportMode -> IO ()+systemInfo v rm t m = do ver <- ghcVersion pName <- getProgName let pVer = showVersion Paths.version@@ -335,7 +256,8 @@ 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 $ " * Target: " ++ show t+ say v $ " * Mode: " ++ show m say v "" -- -----------------------------------------------------------------------------@@ -351,14 +273,3 @@ 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
+ README.md view
@@ -0,0 +1,36 @@+# haskell-updater++Rebuilds Haskell packages on Gentoo after a GHC upgrade or a dependency upgrade.++Updating Haskell packages+=========================++Sometimes:++``` shell+emerge -auvDN --keep-going @world+```++has trouble figuring out how to update Haskell packages. Providing emerge+with the full list of dev-haskell packages that have upgrades available can+sometimes help:++``` shell+emerge -avu --oneshot --keep-going --with-bdeps=y @world+haskell-updater -- --verbose-conflicts+```++Sometimes we have sub-slot blockers (when updating ghc or some specific package+there are a list of blockers). Subslot blockers are a portage limitation (bug).++To find solution use larger `--backtrack=` with `emerge` and `haskell-updater`.++Experimental portage invocation+===============================++If you run into errors where `haskell-updater` tries to reinstall a masked or+unavailable package, try `haskell-updater --mode=reinstall-atoms` or+`haskell-updater --world`. If you find any bugs, report them to the [bug+tracker](https://github.com/gentoo-haskell/haskell-updater/issues).++
haskell-updater.cabal view
@@ -2,7 +2,7 @@ name: haskell-updater homepage: https://github.com/gentoo-haskell/haskell-updater#readme bug-reports: https://github.com/gentoo-haskell/haskell-updater/issues-version: 1.3.3+version: 1.4.0.0 synopsis: Rebuild Haskell dependencies in Gentoo description: haskell-updater rebuilds Haskell packages on Gentoo@@ -28,9 +28,11 @@ maintainer: haskell@gentoo.org build-type: Simple-extra-source-files:- man/haskell-updater.1- TODO+extra-doc-files:+ , CHANGELOG.md+ , man/haskell-updater.1+ , README.md+ , TODO tested-with: , GHC ==9.0.2@@ -58,9 +60,12 @@ import: all main-is: Main.hs other-modules:+ Distribution.Gentoo.CmdLine Distribution.Gentoo.GHC Distribution.Gentoo.Packages Distribution.Gentoo.PkgManager+ Distribution.Gentoo.PkgManager.Types+ Distribution.Gentoo.Types Distribution.Gentoo.Util Output Paths_haskell_updater