diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Distribution/Gentoo/CmdLine.hs b/Distribution/Gentoo/CmdLine.hs --- a/Distribution/Gentoo/CmdLine.hs +++ b/Distribution/Gentoo/CmdLine.hs @@ -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 } diff --git a/Distribution/Gentoo/CmdLine/Types.hs b/Distribution/Gentoo/CmdLine/Types.hs new file mode 100644 --- /dev/null +++ b/Distribution/Gentoo/CmdLine/Types.hs @@ -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] diff --git a/Distribution/Gentoo/GHC.hs b/Distribution/Gentoo/GHC.hs --- a/Distribution/Gentoo/GHC.hs +++ b/Distribution/Gentoo/GHC.hs @@ -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 diff --git a/Distribution/Gentoo/Packages.hs b/Distribution/Gentoo/Packages.hs --- a/Distribution/Gentoo/Packages.hs +++ b/Distribution/Gentoo/Packages.hs @@ -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 diff --git a/Distribution/Gentoo/PkgManager.hs b/Distribution/Gentoo/PkgManager.hs --- a/Distribution/Gentoo/PkgManager.hs +++ b/Distribution/Gentoo/PkgManager.hs @@ -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 -- ----------------------------------------------------------------------------- diff --git a/Distribution/Gentoo/PkgManager/Types.hs b/Distribution/Gentoo/PkgManager/Types.hs --- a/Distribution/Gentoo/PkgManager/Types.hs +++ b/Distribution/Gentoo/PkgManager/Types.hs @@ -1,3 +1,8 @@ +{- | + Module : Distribution.Gentoo.PkgManager.Types + + Types relating to package managers supported by haskell-updater + -} module Distribution.Gentoo.PkgManager.Types ( PkgManager(..) diff --git a/Distribution/Gentoo/Types.hs b/Distribution/Gentoo/Types.hs --- a/Distribution/Gentoo/Types.hs +++ b/Distribution/Gentoo/Types.hs @@ -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 diff --git a/Distribution/Gentoo/Types/HUMode.hs b/Distribution/Gentoo/Types/HUMode.hs new file mode 100644 --- /dev/null +++ b/Distribution/Gentoo/Types/HUMode.hs @@ -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 diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/Output.hs b/Output.hs --- a/Output.hs +++ b/Output.hs @@ -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 "" diff --git a/haskell-updater.cabal b/haskell-updater.cabal --- a/haskell-updater.cabal +++ b/haskell-updater.cabal @@ -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