haskell-updater 1.4.0.0 → 1.4.1.0
raw patch · 12 files changed
+683/−341 lines, 12 files
Files
- CHANGELOG.md +10/−0
- Distribution/Gentoo/CmdLine.hs +134/−162
- Distribution/Gentoo/CmdLine/Types.hs +173/−0
- Distribution/Gentoo/GHC.hs +6/−5
- Distribution/Gentoo/Packages.hs +8/−8
- Distribution/Gentoo/PkgManager.hs +77/−14
- Distribution/Gentoo/PkgManager/Types.hs +5/−0
- Distribution/Gentoo/Types.hs +45/−46
- Distribution/Gentoo/Types/HUMode.hs +59/−0
- Main.hs +158/−102
- Output.hs +3/−2
- haskell-updater.cabal +5/−2
CHANGELOG.md view
@@ -1,3 +1,13 @@+## v1.4.1.0 (2024-06-30)++Release v1.4.1.0++- Add support for custom targets+ - `--custom-target` (`-T`)+- Improve logic behind looping mechanism for `--mode=reinstall-atoms`+- Improve output and internal representations of packages/program state+- Test with ghc-9.10+ ## v1.4.0.0 (2024-05-25) Release v1.4.0.0
Distribution/Gentoo/CmdLine.hs view
@@ -1,218 +1,174 @@-{-# LANGUAGE ScopedTypeVariables #-}+{- |+ Module : Distribution.Gentoo.CmdLine.Types++ Functions and logic for parsing command line options and converting them+ into a valid internal representation of haskell-updater modes (see+ @Distribution.Gentoo.Types.HUMode@).+ -}++{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} module Distribution.Gentoo.CmdLine ( parseArgs+ , mkHUMode , options+ , argString ) where import Control.Monad ((>=>))-import Data.Char (toLower)-import qualified Data.List as L import Data.Proxy import System.Console.GetOpt +import Distribution.Gentoo.CmdLine.Types import Distribution.Gentoo.PkgManager import Distribution.Gentoo.PkgManager.Types import Distribution.Gentoo.Types+import qualified Distribution.Gentoo.Types.HUMode as Mode 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 :: PkgManager -> RawPMArgs -> Either String (CmdLineArgs, RawPMArgs) 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- }+ (,raw) <$> foldr (>=>) pure fs (defCmdLineArgs defPM) --- | Make sure there is at least one of 'UpdateAsNeeded' or 'UpdateDeep'--- in 'flags'.-postProcessRM :: RunModifier -> RunModifier-postProcessRM rm = rm { flags = flags' }+mkHUMode :: CmdLineArgs -> RawPMArgs -> Either String Mode.HUMode+mkHUMode cmdLine raw+ | cmdLineHelp cmdLine = pure Mode.HelpMode+ | cmdLineVersion cmdLine = pure Mode.VersionMode+ | otherwise = do+ let pkgMgr = cmdLinePkgManager cmdLine+ mPkgMgr <- go pkgMgr+ pure $ Mode.RunMode runModifier mPkgMgr where- flags'- | or $ [(==UpdateAsNeeded), (==UpdateDeep)] <*> nubFlags = nubFlags- | otherwise = UpdateDeep : nubFlags- nubFlags = L.nub (flags rm)+ go :: PkgManager -> Either String Mode.PkgManager+ go pkgMgr = case (pkgMgr, cmdLineMode cmdLine, cmdLineTarget cmdLine) of+ (Portage, ReinstallAtomsMode, Right WorldTarget) -> pure+ $ Mode.Portage $ Right $ Mode.ReinstallAtomsMode+ $ Right $ Mode.WorldTarget+ (Portage, ReinstallAtomsMode, Left targs) -> pure+ $ Mode.Portage $ Right $ Mode.ReinstallAtomsMode+ $ Right $ Mode.CustomTargets targs+ (Portage, _, Right WorldTarget) -> Left+ "\"world\" target is only valid with reinstall-atoms mode"+ (Portage, _, Left _) -> Left+ "custom targets are only valid with reinstall-atoms mode"+ (Portage, ReinstallAtomsMode, Right targ) -> pure+ $ Mode.Portage $ Right $ Mode.ReinstallAtomsMode+ $ Left $ convTarget targ+ (_, ReinstallAtomsMode, Right WorldTarget) -> Left+ "\"world\" target is only valid with portage package manager"+ (_, _, Right WorldTarget) -> Left $ unwords+ [ "\"world\" target is only valid with reinstall-atoms mode and portage"+ , "package manager"]+ (_, _, Left _) -> Left $ unwords+ [ "custom targets are only valid with reinstall-atoms mode and portage"+ , "package manager"]+ (_, ReinstallAtomsMode, _) -> Left+ "reinstall-atoms mode is only valid with portage package manager"+ (_, mode, Right targ) -> pure $ convPkgMgr pkgMgr mode targ -options :: [OptDescr (RunModifier -> Either String RunModifier)]+ convPkgMgr :: PkgManager -> RunMode -> BuildTarget -> Mode.PkgManager+ convPkgMgr Portage mode targ = Mode.Portage $ Left $ convMode mode targ+ convPkgMgr Paludis mode targ = Mode.Paludis $ convMode mode targ+ convPkgMgr PkgCore mode targ = Mode.PkgCore $ convMode mode targ+ convPkgMgr (CustomPM pm) mode targ = Mode.CustomPM pm $ convMode mode targ+ convPkgMgr _ _ _ = error "Undefined behavior in convPkgMgr"++ convMode :: RunMode -> BuildTarget -> Mode.RunMode+ convMode BasicMode targ = Mode.BasicMode (convTarget targ)+ convMode ListMode targ = Mode.ListMode (convTarget targ)+ convMode _ _ = error "Undefined behavior in convMode"++ convTarget :: BuildTarget -> Mode.Target+ convTarget OnlyInvalid = Mode.OnlyInvalid+ convTarget AllInstalled = Mode.AllInstalled+ convTarget _ = error "Undefined behavior in convTarget"++ runModifier :: RunModifier+ runModifier = RM+ { flags = (if cmdLinePretend cmdLine then (PretendBuild:) else id)+ $ if cmdLineNoDeep cmdLine+ then [UpdateAsNeeded]+ else [UpdateDeep]+ , withCmd = cmdLineAction cmdLine+ , rawPMArgs = raw+ , verbosity = cmdLineVerbosity cmdLine+ }++options :: [OptDescr (CmdLineArgs -> Either String CmdLineArgs)] 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")+ (ReqArg (\s c -> pure $ c { cmdLinePkgManager = CustomPM s }) "command") $ "Use custom command as package manager;\n"- ++ "ignores the --pretend and --no-deep flags."+ ++ " ignores the --pretend and --no-deep flags." , Option ['p'] ["pretend"]- (naUpdate $ \r -> r { flags = PretendBuild : flags r } )+ (naUpdate $ \c -> c { cmdLinePretend = True } ) "Only pretend to build packages." , Option [] ["no-deep"]- (naUpdate $ \r -> r { flags = UpdateAsNeeded : flags r } )+ (naUpdate $ \c -> c { cmdLineNoDeep = True } ) "Don't pull deep dependencies (--deep with emerge)." , Option ['V'] ["version"]- (naUpdate $ \r -> r { showVer = True })+ (naUpdate $ \c -> c { cmdLineVersion = True }) "Version information." , Option [] ["action"]- (ReqArg (fromCmdline (\a r -> r { withCmd = a })) "action")+ (ReqArg (fromCmdline (\a c -> c { cmdLineAction = a })) "action") (argHelp (Proxy @WithCmd)) , Option [] ["target"]- (ReqArg (fromCmdline (\a r -> r { target = a })) "target")+ (ReqArg (fromCmdline (\a -> updateTarget (Right a))) "target") (argHelp (Proxy @BuildTarget)) , Option ['c'] ["dep-check"]- (naUpdate $ \r -> r { target = OnlyInvalid })+ (naUpdate $ updateTarget (Right OnlyInvalid)) $ "alias for --target=" ++ argString OnlyInvalid -- deprecated alias for 'dep-check' , Option ['u'] ["upgrade"]- (naUpdate $ \r -> r { target = OnlyInvalid })+ (naUpdate $ updateTarget (Right OnlyInvalid)) $ "alias for --target=" ++ argString OnlyInvalid , Option ['a'] ["all"]- (naUpdate $ \r -> r { target = AllInstalled })+ (naUpdate $ updateTarget (Right AllInstalled)) $ "alias for --target=" ++ argString AllInstalled , Option ['W'] ["world"]- (naUpdate $ \r -> r- { pkgmgr = Portage- , target = WorldTarget- , mode = ReinstallAtomsMode+ (naUpdate $ \c -> updateTarget (Right WorldTarget) c+ { cmdLinePkgManager = Portage+ , cmdLineMode = ReinstallAtomsMode } ) $ "alias for --package-manager=portage" ++ " \\\n --target=" ++ argString WorldTarget ++ " \\\n --mode=" ++ argString ReinstallAtomsMode+ , Option ['T'] ["custom-target"]+ (ReqArg+ (\s c -> pure $ updateTarget (Left s) c+ { cmdLinePkgManager = Portage+ , cmdLineMode = ReinstallAtomsMode+ }+ )+ "target")+ $ "Use a custom target. May be given multiple times.\n"+ ++ " Enables portage PM and reinstall-targets mode.\n"+ ++ " Will override any non-custom targets." , Option [] ["mode"]- (ReqArg (fromCmdline (\a r -> r { mode = a })) "mode")- (argHelp (Proxy @HackportMode))+ (ReqArg (fromCmdline (\a c -> c { cmdLineMode = a })) "mode")+ (argHelp (Proxy @RunMode)) , Option ['l'] ["list-only"]- (naUpdate $ \r -> r { mode = ListMode })+ (naUpdate $ \c -> c { cmdLineMode = ListMode }) $ "alias for --mode=" ++ argString ListMode , Option ['R'] ["reinstall-atoms"]- (naUpdate $ \r -> r { mode = ReinstallAtomsMode })+ (naUpdate $ \c -> c { cmdLineMode = ReinstallAtomsMode }) $ "alias for --mode=" ++ argString ReinstallAtomsMode , Option ['q'] ["quiet"]- (naUpdate $ \r -> r { verbosity = Quiet })+ (naUpdate $ \c -> c { cmdLineVerbosity = Quiet }) "Print only fatal errors (to stderr)." , Option ['v'] ["verbose"]- (naUpdate $ \r -> r { verbosity = Verbose })+ (naUpdate $ \c -> c { cmdLineVerbosity = Verbose }) "Be more elaborate (to stderr)." , Option ['h', '?'] ["help"]- (naUpdate $ \r -> r { showHelp = True })+ (naUpdate $ \c -> c { cmdLineHelp = True }) "Print this help message." ] @@ -220,19 +176,35 @@ 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+ mkPM :: String -> CmdLineArgs -> Either String CmdLineArgs+ mkPM s c = 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+ Portage -> Right $ c { cmdLinePkgManager = Portage }+ Paludis -> Right $ c { cmdLinePkgManager = Paludis }+ PkgCore -> Right $ c { cmdLinePkgManager = PkgCore }+ CustomPM _ -> error "Undefined behavior in mkPM" 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."+ \ The default package manager is: " ++ defaultPMName ++ ",\n\+ \ which can be overriden with the \"PACKAGE_MANAGER\"\n\+ \ environment variable."++ -- Custom targets always override BuildTargets+ -- New custom targets are appended to old custom targets+ -- New BuildTargets override old BuildTargets+ updateTarget :: Either String BuildTarget -> CmdLineArgs -> CmdLineArgs+ updateTarget new old =+ let newT = case (new, cmdLineTarget old) of+ -- Override old BuildTargets with new BuildTargets+ (Right t, Right _) -> Right t+ -- Append new custom target+ (Left s, Left ss) -> Left $ ss ++ [s]+ -- Drop old BuildTargets for new custom target+ (Left s, Right _) -> Left [s]+ -- Drop new BuildTargets in favor of old custom targets+ (Right _, Left ss) -> Left ss+ in old { cmdLineTarget = newT }
+ Distribution/Gentoo/CmdLine/Types.hs view
@@ -0,0 +1,173 @@+{- |+ Module : Distribution.Gentoo.CmdLine.Types++ Types representing command-line options+ -}++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}++module Distribution.Gentoo.CmdLine.Types+ (+ -- * main type+ CmdLineArgs(..)+ , defCmdLineArgs+ -- * sub types+ , BuildTarget(..)+ , RunMode(..)+ , CmdlineOpt(..)+ -- * getter functions+ , argString+ , argDescription+ -- * utility functions+ , argHelp+ , fromCmdline+ ) where++import Data.Char (toLower)+import qualified Data.List as L+import Data.Proxy++import Distribution.Gentoo.PkgManager.Types+import Distribution.Gentoo.Types+import Output++-- | Represents possible options given on the command line+data CmdLineArgs = CmdLineArgs+ { cmdLinePkgManager :: PkgManager+ , cmdLinePretend :: Bool+ , cmdLineNoDeep :: Bool+ , cmdLineVersion :: Bool+ , cmdLineAction :: WithCmd+ , cmdLineTarget :: Either CustomTargets BuildTarget+ , cmdLineMode :: RunMode+ , cmdLineVerbosity :: Verbosity+ , cmdLineHelp :: Bool+ } deriving (Show, Eq, Ord)++defCmdLineArgs :: PkgManager -> CmdLineArgs+defCmdLineArgs defPM = CmdLineArgs+ defPM+ False+ False+ False+ PrintAndRun+ (Right OnlyInvalid)+ BasicMode+ Normal+ False++data BuildTarget+ = OnlyInvalid -- ^ Default+ | AllInstalled -- ^ Rebuild every haskell package+ | WorldTarget -- ^ Target @world portage set+ deriving (Eq, Ord, Show, Read, Enum, Bounded)++data RunMode+ = BasicMode+ | ListMode+ | ReinstallAtomsMode+ deriving (Show, Eq, Ord, Enum, Bounded)++-- | 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 RunMode 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 -> CmdLineArgs -> CmdLineArgs)+ -> String+ -> CmdLineArgs+ -> Either String CmdLineArgs+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]
Distribution/Gentoo/GHC.hs view
@@ -36,6 +36,7 @@ import Data.Maybe import qualified Data.List as L import qualified Data.Map.Strict as Map+import qualified Data.Set as Set import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BL8 import System.FilePath((</>), takeExtension, pathSeparator)@@ -208,7 +209,7 @@ -> IO ([Package],[CabalPV],[FilePath]) checkPkgs v (pns, gentoo_cnfs) = do files_to_pkgs <- resolveFiles gentoo_cnfs- let (gentoo_files, pkgs) = unzip files_to_pkgs+ let (gentoo_files, pkgs) = unzip $ Set.toList files_to_pkgs orphan_gentoo_files = gentoo_cnfs L.\\ gentoo_files vsay v $ unwords [ "checkPkgs: searching for gentoo .conf orphans" , show (length orphan_gentoo_files)@@ -220,7 +221,7 @@ -- ----------------------------------------------------------------------------- -- Finding packages installed with other versions of GHC-oldGhcPkgs :: Verbosity -> IO [Package]+oldGhcPkgs :: Verbosity -> IO (Set.Set Package) oldGhcPkgs v = do thisGhc <- ghcLibDir vsay v $ "oldGhcPkgs ghc lib: " ++ show thisGhc@@ -232,7 +233,7 @@ -- Find packages installed by other versions of GHC in this possible -- library directory.-checkLibDirs :: Verbosity -> BSFilePath -> [BSFilePath] -> IO [Package]+checkLibDirs :: Verbosity -> BSFilePath -> [BSFilePath] -> IO (Set.Set Package) checkLibDirs v thisGhc libDirs = do vsay v $ "checkLibDir ghc libs: " ++ show (thisGhc, libDirs) pkgsHaveContent (hasDirMatching wanted)@@ -352,7 +353,7 @@ -- Here we pick orphan ones and notify user about it. registered_confs <- listConfFiles ghcConfsPath confs_to_pkgs <- resolveFiles registered_confs- let (conf_files, _conf_pkgs) = unzip confs_to_pkgs+ let (conf_files, _conf_pkgs) = unzip $ Set.toList confs_to_pkgs orphan_conf_files = registered_confs L.\\ conf_files orphan_packages <- fmap catMaybes $ forM orphan_conf_files $@@ -416,7 +417,7 @@ -- ----------------------------------------------------------------------------- -allInstalledPackages :: IO [Package]+allInstalledPackages :: IO (Set.Set Package) allInstalledPackages = do libDir <- ghcLibDir let libDir' = BS.pack libDir fmap notGHC $ pkgsHaveContent
Distribution/Gentoo/Packages.hs view
@@ -9,7 +9,7 @@ packages in Gentoo. -} module Distribution.Gentoo.Packages- ( Package+ ( Package(..) , Content , notGHC , printPkg@@ -58,8 +58,8 @@ ghcPkg = Package "dev-lang" "ghc" Nothing -- Return all packages that are not a version of GHC.-notGHC :: [Package] -> [Package]-notGHC = filter (isNot ghcPkg)+notGHC :: S.Set Package -> S.Set Package+notGHC = S.filter (isNot ghcPkg) where isNot p1 = not . samePackageAs p1 @@ -171,8 +171,8 @@ -- ----------------------------------------------------------------------------- -- Find all the packages that contain given files.-resolveFiles :: [FilePath] -> IO [(FilePath, Package)]-resolveFiles fps = expand <$> forPkg grep+resolveFiles :: [FilePath] -> IO (S.Set (FilePath, Package))+resolveFiles fps = S.fromList . expand <$> forPkg grep where fps' = S.fromList $ map (Obj . BS.pack) fps expand pfs = [ (BS.unpack fn, pn)@@ -183,7 +183,7 @@ -- | Run predecate 'p' for each installed package -- and gather all 'Just' values-forPkg :: (Package -> [Content] -> Maybe a) -> IO [a]+forPkg :: Ord a => (Package -> [Content] -> Maybe a) -> IO [a] forPkg p = do categories <- installedCats catMaybes <$> do@@ -205,8 +205,8 @@ -- Find which packages have Content information that matches the -- provided predicate; to be used with the searching predicates -- above.-pkgsHaveContent :: ([Content] -> Bool) -> IO [Package]-pkgsHaveContent p = forPkg p'+pkgsHaveContent :: ([Content] -> Bool) -> IO (S.Set Package)+pkgsHaveContent p = S.fromList <$> forPkg p' where p' pn cont = if p cont then Just pn else Nothing
Distribution/Gentoo/PkgManager.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ {- | Module : Distribution.Gentoo.PkgManager Description : Using package managers in Gentoo.@@ -14,17 +16,21 @@ , defaultPM , defaultPMName , nameOfPM+ , toPkgManager , buildCmd , buildAltCmd ) where import Distribution.Gentoo.Packages import Distribution.Gentoo.PkgManager.Types+import Distribution.Gentoo.Types+import qualified Distribution.Gentoo.Types.HUMode as Mode import Data.Char(toLower) import Data.Maybe(mapMaybe, fromMaybe) import qualified Data.Map as M import Data.Map(Map)+import qualified Data.Set as Set import System.Environment(getEnvironment) -- -----------------------------------------------------------------------------@@ -87,7 +93,6 @@ defaultPMFlags Portage = [ "--oneshot" , "--keep-going" , "--complete-graph"- , "--usepkg=n" ] defaultPMFlags PkgCore = [ "--deep" , "--oneshot"@@ -101,12 +106,36 @@ defaultPMFlags CustomPM{} = [] defaultPMFlags (InvalidPM _) = undefined -buildCmd :: PkgManager -> [PMFlag] -> [String] -> [Package] -> (String, [String])-buildCmd pm fs raw_pm_flags ps = (pmCommand pm, fs' ++ ps')- where- fs' = defaultPMFlags pm ++ mapMaybe (flagRep pm) fs ++ raw_pm_flags- ps' = map printPkg ps+toPkgManager :: Mode.PkgManager -> PkgManager+toPkgManager (Mode.Portage _) = Portage+toPkgManager (Mode.PkgCore _) = PkgCore+toPkgManager (Mode.Paludis _) = Paludis+toPkgManager (Mode.CustomPM s _) = CustomPM s +buildCmd+ :: Mode.PkgManager+ -> [PMFlag]+ -> [String]+ -> DefaultModePkgs+ -> (String, [String])+buildCmd mpm fs raw_pm_flags ps =+ ( pmCommand pm+ , defaultPMFlags pm+ ++ mapMaybe (flagRep pm) fs+ ++ raw_pm_flags+ ++ rest+ )+ where+ rest = case (pm, ps) of+ (Portage, DefaultInvalid p) -> usepkgExclude p ++ targs p+ (Portage, DefaultAll a) -> usepkgExclude a ++ targs a+ (_, DefaultInvalid p) -> targs p+ (_, DefaultAll a) -> targs a++ targs p = printPkg <$> Set.toList (getPkgs p)++ pm = toPkgManager mpm+ -- | Alternative version of 'buildCmd' which uses experimental @emerge@ -- invocation (using @--reinstall-atoms@). This is only to be used with the -- 'Portage' 'PkgManager'.@@ -121,16 +150,50 @@ 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]+ -> RAModePkgs -- ^ Set of packages to rebuild+ -- | 'True' denotes a @world@ target+ -> AllPkgs -> (String, [String])-buildAltCmd fs rawPmFlags ps allPs =- (pmCommand Portage, fs' ++ reinst ++ rawPmFlags ++ allPs')+buildAltCmd fs rawPmFlags raPS allPs =+ ( pmCommand Portage+ , defaultPMFlags Portage+ ++ mapMaybe (flagRep Portage) fs+ ++ ["--update"]+ ++ rawPmFlags+ ++ usepkgExclude allPs+ ++ reinst+ ++ targs+ ) where- fs' = defaultPMFlags Portage ++ mapMaybe (flagRep Portage) fs ++ ["--update"]- reinst = ["--reinstall-atoms", unwords (map printPkg ps)]- allPs' = maybe ["@world"] (map printPkg) allPs+ (reinst, targs) =+ let raArgs ps+ | Set.null ps = []+ | otherwise = ["--reinstall-atoms", unwords (printPkg <$> Set.toList ps)]+ in case raPS of+ RAModeInvalid p ->+ (raArgs (getPkgs p), printPkg <$> Set.toList (getPkgs allPs))+ RAModeAll ->+ (raArgs (getPkgs allPs), printPkg <$> Set.toList (getPkgs allPs))+ RAModeWorld p ->+ (raArgs (getPkgs p), ["@world"])+ RAModeCustom ts p ->+ (raArgs (getPkgs p), ts)++-- | Generate strings using portage's @--usepkg-exclude@ flag. This filters out+-- dev-haskell/* packages which can be specified using a wildcard, in order+-- to reduce the length of the emerge command a bit.+usepkgExclude :: PackageSet t => t -> [String]+usepkgExclude pkgs0+ | Set.null pkgs = []+ | otherwise = ["--usepkg-exclude", unwords ("dev-haskell/*" : filteredPkgs)]+ where+ filteredPkgs = mapMaybe+ ( \case+ Package "dev-haskell" _ _ -> Nothing+ p -> Just $ printPkg p+ )+ (Set.toList pkgs)+ pkgs = getPkgs pkgs0 -- -----------------------------------------------------------------------------
Distribution/Gentoo/PkgManager/Types.hs view
@@ -1,3 +1,8 @@+{- |+ Module : Distribution.Gentoo.PkgManager.Types++ Types relating to package managers supported by haskell-updater+ -} module Distribution.Gentoo.PkgManager.Types ( PkgManager(..)
Distribution/Gentoo/Types.hs view
@@ -1,10 +1,17 @@+{- |+ Module : Distribution.Gentoo.Types + General types needed for haskell-updater functionality+ -}++{-# LANGUAGE TypeApplications #-}+ module Distribution.Gentoo.Types ( RunModifier(..)+ , RawPMArgs , WithCmd(..) , WithUserCmd- , BuildTarget(..)- , HackportMode(..)+ , CustomTargets , PackageState(..) , DefaultModePkgs(..) , ListModePkgs(..)@@ -12,26 +19,26 @@ , HasTargets(..) , InvalidPkgs(..) , AllPkgs(..)- , PackageList(..)+ , PackageSet(..) ) where +import qualified Data.Set as Set+ import Distribution.Gentoo.Packages import Distribution.Gentoo.PkgManager.Types import Output --- | Full haskell-updater state-data RunModifier = RM { pkgmgr :: PkgManager- , flags :: [PMFlag]+-- | Run-mode haskell-updater state+data RunModifier = RM { flags :: [PMFlag] , withCmd :: WithCmd- , rawPMArgs :: [String]+ , rawPMArgs :: RawPMArgs , verbosity :: Verbosity- , showHelp :: Bool- , showVer :: Bool- , target :: BuildTarget- , mode :: HackportMode } deriving (Eq, Ord, Show) +-- | Arguments to be passed when calling the package manager+type RawPMArgs = [String]+ data WithCmd = PrintAndRun | PrintOnly | RunOnly@@ -39,23 +46,13 @@ 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)+type CustomTargets = [String] -- | The current package list(s) organized by mode and build target data PackageState = DefaultModeState (Maybe DefaultModePkgs) | ListModeState ListModePkgs- | RAModeState (Maybe RAModePkgs)+ | RAModeState AllPkgs RAModePkgs deriving (Show, Eq, Ord) data DefaultModePkgs@@ -69,47 +66,49 @@ deriving (Show, Eq, Ord) data RAModePkgs- = RAModeInvalid AllPkgs InvalidPkgs- | RAModeAll AllPkgs+ = RAModeInvalid InvalidPkgs+ | RAModeAll | RAModeWorld InvalidPkgs+ | RAModeCustom CustomTargets InvalidPkgs deriving (Show, Eq, Ord) class HasTargets t where- targets :: t -> [Package]+ targetPkgs :: t -> Set.Set Package instance HasTargets PackageState where- targets (DefaultModeState ps) = targets ps- targets (ListModeState ps) = targets ps- targets (RAModeState ps) = targets ps+ targetPkgs (DefaultModeState ps) = targetPkgs ps+ targetPkgs (ListModeState ps) = targetPkgs ps+ targetPkgs (RAModeState _ (RAModeInvalid ps)) = getPkgs ps+ targetPkgs (RAModeState ps RAModeAll) = getPkgs ps+ targetPkgs (RAModeState _ (RAModeWorld _)) = Set.empty+ targetPkgs (RAModeState _ (RAModeCustom _ _)) = Set.empty instance HasTargets DefaultModePkgs where- targets (DefaultInvalid ps) = getPkgs ps- targets (DefaultAll ps) = getPkgs ps+ targetPkgs (DefaultInvalid ps) = getPkgs ps+ targetPkgs (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+ targetPkgs (ListInvalid ps) = getPkgs ps+ targetPkgs (ListAll ps) = getPkgs ps instance HasTargets t => HasTargets (Maybe t) where- targets (Just ps) = targets ps- targets Nothing = []+ targetPkgs (Just ps) = targetPkgs ps+ targetPkgs Nothing = Set.empty -newtype InvalidPkgs = InvalidPkgs [Package]+newtype InvalidPkgs = InvalidPkgs (Set.Set Package) deriving (Show, Eq, Ord) -newtype AllPkgs = AllPkgs [Package]+newtype AllPkgs = AllPkgs (Set.Set Package) deriving (Show, Eq, Ord) -class PackageList t where- getPkgs :: t -> [Package]+class PackageSet t where+ getPkgs :: t -> Set.Set Package -instance PackageList InvalidPkgs where+instance PackageSet InvalidPkgs where getPkgs (InvalidPkgs ps) = ps -instance PackageList AllPkgs where+instance PackageSet AllPkgs where getPkgs (AllPkgs ps) = ps++instance PackageSet () where+ getPkgs () = Set.empty
+ Distribution/Gentoo/Types/HUMode.hs view
@@ -0,0 +1,59 @@+{- |+ Module : Distribution.Gentoo.Types.HUMode+ Description : Valid modes for haskell-updater++ This module houses a complex ADT which represents valid modes for+ haskell-updater. This is converted from @CmdLineArgs@ (in+ @Distribution.Gentoo.CmdLine.Types@), which represents+ possible options given on the command line.+ -}++module Distribution.Gentoo.Types.HUMode+ ( HUMode(..)+ , PkgManager(..)+ , RunMode(..)+ , runMode+ , Target(..)+ , ReinstallAtomsMode(..)+ , ReinstallAtomsTarget(..)+ ) where++import Distribution.Gentoo.Types++data HUMode+ = HelpMode+ | VersionMode+ | RunMode RunModifier PkgManager+ deriving (Eq, Ord, Show)++data PkgManager+ = Portage (Either RunMode ReinstallAtomsMode)+ | PkgCore RunMode+ | Paludis RunMode+ | CustomPM String RunMode+ deriving (Eq, Ord, Show)++data RunMode+ = BasicMode Target+ | ListMode Target+ deriving (Eq, Ord, Show)++data Target+ = OnlyInvalid+ | AllInstalled+ deriving (Eq, Ord, Show)++newtype ReinstallAtomsMode+ = ReinstallAtomsMode (Either Target ReinstallAtomsTarget)+ deriving (Eq, Ord, Show)++data ReinstallAtomsTarget+ = WorldTarget+ | CustomTargets CustomTargets+ deriving (Eq, Ord, Show)++runMode :: PkgManager -> Either RunMode ReinstallAtomsMode+runMode (Portage rm) = rm+runMode (PkgCore rm) = Left rm+runMode (Paludis rm) = Left rm+runMode (CustomPM _ rm) = Left rm
Main.hs view
@@ -13,16 +13,19 @@ module Main (main) where import Distribution.Gentoo.CmdLine+import qualified Distribution.Gentoo.CmdLine.Types as CmdLine -- (CmdLineArgs, BuildTarget) import Distribution.Gentoo.GHC import Distribution.Gentoo.Packages import Distribution.Gentoo.PkgManager-import Distribution.Gentoo.PkgManager.Types import Distribution.Gentoo.Types+import Distribution.Gentoo.Types.HUMode import Control.Monad (unless) import qualified Control.Monad as CM+import Data.Foldable (toList) import qualified Data.List as L-import qualified Data.Map as M+import Data.Sequence (Seq, ViewR(..), viewr)+import qualified Data.Sequence as Seq import qualified Data.Set as Set import Data.Version (showVersion) import qualified Paths_haskell_updater as Paths (version)@@ -39,112 +42,142 @@ defPM <- defaultPM case parseArgs defPM args of Left err -> die err- Right a -> runAction a+ Right (cmdArgs, rawArgs) -> runAction cmdArgs rawArgs -runAction :: RunModifier -> IO a-runAction rm- | showHelp rm = help- | showVer rm = version- | otherwise = runDriver rm+runAction :: CmdLine.CmdLineArgs -> RawPMArgs -> IO a+runAction cmdArgs rawArgs = do+ mode <- either die pure $ mkHUMode cmdArgs rawArgs+ case mode of+ HelpMode -> help+ VersionMode -> version+ RunMode rm pm -> runDriver rm pm rawArgs -- set of packages to rebuild at pass number-type DriverHistory = M.Map (Set.Set Package) Int+type DriverHistory = Seq (Set.Set Package, ExitCode) +data TargetType+ = InvalidTargets+ | AllTargets+ | UpdateTargets+ initialHistory :: DriverHistory-initialHistory = M.empty+initialHistory = Seq.empty dumpHistory :: Verbosity -> DriverHistory -> IO ()-dumpHistory v historyMap = do+dumpHistory v historySeq = 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 ]+ CM.forM_ historyList $ \(n, entry, ec) ->+ say v $ unwords $ ["Pass", show n, ":"] ++ map printPkg (Set.toList entry) ++ [show ec]+ where historyList :: [(Int, Set.Set Package, ExitCode)]+ historyList = L.sort [ (n, entry, ec) | ((entry, ec), n) <- zip (toList historySeq) [1..] ] -runDriver :: RunModifier -> IO a-runDriver rm = do- systemInfo v rm t md- updaterPass 1 initialHistory+runDriver :: RunModifier+ -> PkgManager+ -> RawPMArgs+ -> IO a+runDriver rm pkgMgr rawArgs = do+ systemInfo rm pkgMgr rawArgs+ updaterPass initialHistory success v "done!" where v = verbosity rm- t = target rm- md = mode rm - updaterPass :: Int -> DriverHistory -> IO ()- updaterPass n pastHistory = getPackageState rm >>= \case+ updaterPass :: DriverHistory -> IO ()+ updaterPass pastHistory = getPackageState v pkgMgr >>= \case ListModeState m -> do- mapM_ (putStrLn . printPkg) (targets m)+ mapM_ (putStrLn . printPkg) (targetPkgs m) success v "done!" DefaultModeState (Just (DefaultInvalid ts)) ->- continuePass (Left . DefaultInvalid) False ts+ continuePass (Left . DefaultInvalid) InvalidTargets ts DefaultModeState (Just (DefaultAll ts)) ->- continuePass (Left . DefaultAll) True ts+ continuePass (Left . DefaultAll) AllTargets 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-+ RAModeState allPs (RAModeInvalid ts) ->+ continuePass+ (\ps -> Right (RAModeInvalid ps, allPs))+ UpdateTargets+ ts+ RAModeState allPs RAModeAll ->+ continuePass+ (\_ -> Right (RAModeAll, allPs))+ AllTargets+ ()+ RAModeState allPs (RAModeWorld ts) ->+ continuePass+ (\ps -> Right (RAModeWorld ps, allPs))+ UpdateTargets+ ts+ RAModeState allPs (RAModeCustom cts ts) ->+ continuePass+ (\ps -> Right (RAModeCustom cts ps, allPs))+ UpdateTargets+ ts where alertDone = success (verbosity rm) "\nNothing to build!" continuePass- :: PackageList ts- => (ts -> Either DefaultModePkgs RAModePkgs)- -> Bool+ :: PackageSet ts+ => (ts -> Either DefaultModePkgs (RAModePkgs, AllPkgs))+ -> TargetType -> 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"+ continuePass cnst targetType ts = do+ let next ec = updaterPass+ $ pastHistory <> Seq.singleton (getPkgs ts, ec) - exitCode <- buildPkgs rm (cnst ts)+ case targetType of+ InvalidTargets -> do+ CM.when (getPkgs ts `elem` map fst (toList pastHistory)) $ do+ dumpHistory v pastHistory+ die "Updater stuck in the loop and can't progress" - -- don't try rerun rebuilder for cases where there- -- is no chance to converge to empty set- CM.when allTarget $ exitWith exitCode+ exitCode <- buildPkgs pkgMgr rm (cnst ts) - updaterPass (n + 1) $ M.insert (Set.fromList (getPkgs ts)) n pastHistory+ next exitCode+ AllTargets -> do+ exitCode <- buildPkgs pkgMgr rm (cnst ts) -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"+ exitWith exitCode+ UpdateTargets -> case viewr pastHistory of+ EmptyR -> buildPkgs pkgMgr rm (cnst ts) >>= next+ (_ :> (past, pastEC)) -> do+ case (getPkgs ts == past, pastEC) of+ (True, ExitFailure _) -> do+ dumpHistory v pastHistory+ die "Updater stuck in the loop and can't progress"+ (True, ExitSuccess) -> exitSuccess+ _ -> buildPkgs pkgMgr rm (cnst ts) >>= next++getPackageState :: Verbosity -> PkgManager -> IO PackageState+getPackageState v pkgMgr =+ case runMode pkgMgr of+ Left mode -> case mode of+ BasicMode OnlyInvalid ->+ DefaultModeState . checkForNull DefaultInvalid <$> getInvalid+ BasicMode AllInstalled ->+ DefaultModeState . checkForNull DefaultAll <$> getAll+ ListMode OnlyInvalid ->+ ListModeState . ListInvalid <$> getInvalid+ ListMode AllInstalled ->+ ListModeState . ListAll <$> getAll+ Right (ReinstallAtomsMode targ) -> case targ of+ Right WorldTarget -> do+ is <- getInvalid+ allPs <- getAll+ pure $ RAModeState allPs $ RAModeWorld is+ Right (CustomTargets cts) -> do+ is <- getInvalid+ allPs <- getAll+ pure $ RAModeState allPs $ RAModeCustom cts is+ Left OnlyInvalid -> do+ is <- getInvalid+ allPs <- getAll+ pure $ RAModeState allPs $ RAModeInvalid is+ Left AllInstalled -> do+ allPs <- getAll+ pure $ RAModeState allPs RAModeAll where getInvalid = do say v "Searching for packages installed with a different version of GHC."@@ -155,11 +188,12 @@ say v "Searching for Haskell libraries with broken dependencies." say v "" (broken, unknown_packages, unknown_files) <- brokenPkgs v+ let broken' = Set.fromList broken printUnknownPackagesLn (map unCPV unknown_packages) printUnknownFilesLn unknown_files- pkgListPrintLn v "broken" (notGHC broken)+ pkgListPrintLn v "broken" (notGHC broken') - return $ InvalidPkgs $ Set.toList $ Set.fromList $ old ++ broken+ return $ InvalidPkgs $ old <> broken' getAll = do say v "Searching for packages installed with the current version of GHC."@@ -168,7 +202,7 @@ pkgListPrintLn v "installed" pkgs return $ AllPkgs pkgs - checkForNull :: PackageList ts => (ts -> b) -> ts -> Maybe b+ checkForNull :: PackageSet ts => (ts -> b) -> ts -> Maybe b checkForNull cnst l | null (getPkgs l) = Nothing | otherwise = Just (cnst l)@@ -190,8 +224,6 @@ say v $ " It will likely need one more 'haskell-updater' run." say v "" - v = verbosity rm- runCmd :: WithCmd -> String -> [String] -> IO ExitCode runCmd m cmd args = case m of RunOnly -> runCommand cmd args@@ -206,20 +238,18 @@ runCommand :: String -> [String] -> IO ExitCode runCommand cmd args = rawSystem cmd args -buildPkgs :: RunModifier -> Either DefaultModePkgs RAModePkgs -> IO ExitCode-buildPkgs rm ts = runCmd (withCmd rm) cmd args+buildPkgs+ :: PkgManager+ -> RunModifier+ -> Either DefaultModePkgs (RAModePkgs, AllPkgs)+ -> IO ExitCode+buildPkgs pkgMgr rm ts = runCmd (withCmd rm) cmd args where (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+ Left ps ->+ buildCmd pkgMgr (flags rm) (rawPMArgs rm) ps+ Right (ps, allPkgs) ->+ buildAltCmd (flags rm) (rawPMArgs rm) ps allPkgs -- ----------------------------------------------------------------------------- -- Printing information.@@ -243,8 +273,12 @@ , "" , "Options:"] -systemInfo :: Verbosity -> RunModifier -> BuildTarget -> HackportMode -> IO ()-systemInfo v rm t m = do+systemInfo+ :: RunModifier+ -> PkgManager+ -> RawPMArgs+ -> IO ()+systemInfo rm pkgMgr rawArgs = do ver <- ghcVersion pName <- getProgName let pVer = showVersion Paths.version@@ -253,12 +287,34 @@ 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 $ " * Target: " ++ show t- say v $ " * Mode: " ++ show m+ say v $ " * Package manager (PM): " ++ nameOfPM (toPkgManager pkgMgr)+ unless (null rawArgs) $+ say v $ " * PM auxiliary arguments: " ++ unwords rawArgs+ say v $ " * Targets: " ++ ts+ say v $ " * Mode: " ++ argString m say v ""+ where+ v = verbosity rm++ (m, ts) = case runMode pkgMgr of+ Left mode -> case mode of+ BasicMode OnlyInvalid ->+ (CmdLine.BasicMode, argString CmdLine.OnlyInvalid)+ BasicMode AllInstalled ->+ (CmdLine.BasicMode, argString CmdLine.AllInstalled)+ ListMode OnlyInvalid ->+ (CmdLine.ListMode, argString CmdLine.OnlyInvalid)+ ListMode AllInstalled ->+ (CmdLine.ListMode, argString CmdLine.AllInstalled)+ Right (ReinstallAtomsMode targ) -> case targ of+ Left OnlyInvalid ->+ (CmdLine.ReinstallAtomsMode, argString CmdLine.OnlyInvalid)+ Left AllInstalled ->+ (CmdLine.ReinstallAtomsMode, argString CmdLine.AllInstalled)+ Right WorldTarget ->+ (CmdLine.ReinstallAtomsMode, argString CmdLine.WorldTarget)+ Right (CustomTargets cts) ->+ (CmdLine.ReinstallAtomsMode, unwords cts) -- ----------------------------------------------------------------------------- -- Utility functions
Output.hs view
@@ -13,6 +13,7 @@ , Verbosity(..) ) where +import qualified Data.Set as Set import System.IO (hPutStrLn, stderr) import Distribution.Gentoo.Packages@@ -42,11 +43,11 @@ printList v f = mapM_ (say v . (++) " * " . f) -- Print a list of packages, with a description of what they are.-pkgListPrintLn :: Verbosity -> String -> [Package] -> IO ()+pkgListPrintLn :: Verbosity -> String -> Set.Set Package -> IO () pkgListPrintLn v desc pkgs = do if null pkgs then say v $ unwords ["No", desc, "packages found!"] else do say v $ unwords ["Found the following" , desc, "packages:"]- printList v printPkg pkgs+ printList v printPkg (Set.toList pkgs) say v ""
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.4.0.0+version: 1.4.1.0 synopsis: Rebuild Haskell dependencies in Gentoo description: haskell-updater rebuilds Haskell packages on Gentoo@@ -38,8 +38,9 @@ , GHC ==9.0.2 , GHC ==9.2.8 , GHC ==9.4.8- , GHC ==9.6.4+ , GHC ==9.6.5 , GHC ==9.8.2+ , GHC ==9.10.1 source-repository head type: git@@ -61,11 +62,13 @@ main-is: Main.hs other-modules: Distribution.Gentoo.CmdLine+ Distribution.Gentoo.CmdLine.Types Distribution.Gentoo.GHC Distribution.Gentoo.Packages Distribution.Gentoo.PkgManager Distribution.Gentoo.PkgManager.Types Distribution.Gentoo.Types+ Distribution.Gentoo.Types.HUMode Distribution.Gentoo.Util Output Paths_haskell_updater