haskell-updater 1.4.1.0 → 1.5.0.0
raw patch · 25 files changed
+2775/−1869 lines, 25 filesdep +mtldep ~Cabaldep ~basedep ~bytestring
Dependencies added: mtl
Dependency ranges changed: Cabal, base, bytestring, containers, directory, filepath, process
Files
- CHANGELOG.md +10/−0
- Distribution/Gentoo/CmdLine.hs +0/−210
- Distribution/Gentoo/CmdLine/Types.hs +0/−173
- Distribution/Gentoo/GHC.hs +0/−424
- Distribution/Gentoo/Packages.hs +0/−226
- Distribution/Gentoo/PkgManager.hs +0/−219
- Distribution/Gentoo/PkgManager/Types.hs +0/−24
- Distribution/Gentoo/Types.hs +0/−114
- Distribution/Gentoo/Types/HUMode.hs +0/−59
- Distribution/Gentoo/Util.hs +0/−25
- Main.hs +0/−331
- Output.hs +0/−53
- haskell-updater.cabal +15/−11
- src/Distribution/Gentoo/CmdLine.hs +281/−0
- src/Distribution/Gentoo/CmdLine/Types.hs +191/−0
- src/Distribution/Gentoo/Env.hs +103/−0
- src/Distribution/Gentoo/GHC.hs +457/−0
- src/Distribution/Gentoo/Packages.hs +232/−0
- src/Distribution/Gentoo/PkgManager.hs +328/−0
- src/Distribution/Gentoo/PkgManager/Types.hs +28/−0
- src/Distribution/Gentoo/Types.hs +231/−0
- src/Distribution/Gentoo/Types/Mode.hs +193/−0
- src/Distribution/Gentoo/Util.hs +103/−0
- src/Main.hs +501/−0
- src/Output.hs +102/−0
CHANGELOG.md view
@@ -1,3 +1,13 @@+## v1.5.0.0 (2025-03-06)++Release v1.5.0.0++- Add `--world-full` and `--preserved-rebuild` modes+- Allow mixing/matching targets for `--reinstall-atoms` mode+- Improve readability of output+- Many internal improvments for code readability and ensuring proper behavior+ (no tests yet, but much has been done to pave the way for this)+ ## v1.4.1.0 (2024-06-30) Release v1.4.1.0
− Distribution/Gentoo/CmdLine.hs
@@ -1,210 +0,0 @@-{- |- 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.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--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, _, _) ->- (,raw) <$> foldr (>=>) pure fs (defCmdLineArgs defPM)--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- 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-- 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 c -> pure $ c { cmdLinePkgManager = CustomPM s }) "command")- $ "Use custom command as package manager;\n"- ++ " ignores the --pretend and --no-deep flags."- , Option ['p'] ["pretend"]- (naUpdate $ \c -> c { cmdLinePretend = True } )- "Only pretend to build packages."- , Option [] ["no-deep"]- (naUpdate $ \c -> c { cmdLineNoDeep = True } )- "Don't pull deep dependencies (--deep with emerge)."- , Option ['V'] ["version"]- (naUpdate $ \c -> c { cmdLineVersion = True })- "Version information."- , Option [] ["action"]- (ReqArg (fromCmdline (\a c -> c { cmdLineAction = a })) "action")- (argHelp (Proxy @WithCmd))- , Option [] ["target"]- (ReqArg (fromCmdline (\a -> updateTarget (Right a))) "target")- (argHelp (Proxy @BuildTarget))- , Option ['c'] ["dep-check"]- (naUpdate $ updateTarget (Right OnlyInvalid))- $ "alias for --target=" ++ argString OnlyInvalid- -- deprecated alias for 'dep-check'- , Option ['u'] ["upgrade"]- (naUpdate $ updateTarget (Right OnlyInvalid))- $ "alias for --target=" ++ argString OnlyInvalid- , Option ['a'] ["all"]- (naUpdate $ updateTarget (Right AllInstalled))- $ "alias for --target=" ++ argString AllInstalled- , Option ['W'] ["world"]- (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 c -> c { cmdLineMode = a })) "mode")- (argHelp (Proxy @RunMode))- , Option ['l'] ["list-only"]- (naUpdate $ \c -> c { cmdLineMode = ListMode })- $ "alias for --mode=" ++ argString ListMode- , Option ['R'] ["reinstall-atoms"]- (naUpdate $ \c -> c { cmdLineMode = ReinstallAtomsMode })- $ "alias for --mode=" ++ argString ReinstallAtomsMode- , Option ['q'] ["quiet"]- (naUpdate $ \c -> c { cmdLineVerbosity = Quiet })- "Print only fatal errors (to stderr)."- , Option ['v'] ["verbose"]- (naUpdate $ \c -> c { cmdLineVerbosity = Verbose })- "Be more elaborate (to stderr)."- , Option ['h', '?'] ["help"]- (naUpdate $ \c -> c { cmdLineHelp = True })- "Print this help message."- ]-- where- naUpdate f = NoArg (pure . f)-- -- This touches some legacy code so we need a custom handler for it- mkPM :: String -> CmdLineArgs -> Either String CmdLineArgs- mkPM s c = case choosePM s of- InvalidPM pm -> Left $ "Unknown package manager: " ++ pm- 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."-- -- 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
@@ -1,173 +0,0 @@-{- |- 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
@@ -1,424 +0,0 @@-{-# LANGUAGE CPP #-}-{- |- Module : Distribution.Gentoo.GHC- Description : Find GHC-related breakages on Gentoo.- Copyright : (c) Ivan Lazar Miljenovic 2009- License : GPL-2 or later-- This module defines helper functions to find broken packages in- GHC, or else find packages installed with older versions of GHC.- -}-module Distribution.Gentoo.GHC- ( ghcVersion- , ghcLoc- , ghcLibDir- , oldGhcPkgs- , brokenPkgs- , allInstalledPackages- , unCPV- ) where--import Distribution.Gentoo.Util-import Distribution.Gentoo.Packages---- Cabal imports-import qualified Distribution.Simple.Utils as DSU-import Distribution.Verbosity(silent)-import Distribution.Package(mungedId)-import Distribution.InstalledPackageInfo- (InstalledPackageInfo(sourceLibName), parseInstalledPackageInfo)-import Distribution.Text(display)-import Distribution.Types.LibraryName (LibraryName(..))---- Other imports-import Data.Char(isDigit)-import Data.Either(partitionEithers)-import Data.Maybe-import qualified Data.List as L-import qualified Data.Map.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)-import System.Directory( canonicalizePath- , doesDirectoryExist- , findExecutable- , listDirectory )-import Control.Monad--import Output---- --------------------------------------------------------------------------------- Common helper utils, etc.---- Get only the first line of output-rawSysStdOutLine :: FilePath -> [String] -> IO String-rawSysStdOutLine app args = do- out <- rawCommand app args- case lines out of- [] -> error $ unwords- [ "rawSysStdOutLine: Empty output from rawCommand"- , show app, show args ]- (s:_) -> pure s--rawCommand :: FilePath -> [String] -> IO String-rawCommand cmd args = do (out,_,_) <- DSU.rawSystemStdInOut- silent -- verbosity- cmd -- program loc- args -- args-#if MIN_VERSION_Cabal(1,18,0)- Nothing -- cabal-1.18+: new working dir- Nothing -- cabal-1.18+: new environment-#endif /* MIN_VERSION_Cabal(1,18,0) */- Nothing -- input text and binary mode-#if MIN_VERSION_Cabal(2,1,0)- DSU.IODataModeBinary-#else- False -- is output in binary mode-#endif /* MIN_VERSION_Cabal(2,1,0) */-#if MIN_VERSION_Cabal(3,2,0)- return (BL8.unpack out)-#elif MIN_VERSION_Cabal(2,1,0)- case out of- ~(DSU.IODataBinary bs) -> return (BL8.unpack bs)-#else- return out-#endif /* MIN_VERSION_Cabal(2,1,0) */---- Get the first line of output from calling GHC with the given--- arguments.-ghcRawOut :: [String] -> IO String-ghcRawOut args = ghcLoc >>= flip rawSysStdOutLine args---- Cheat with using fromJust since we know that GHC must be in $PATH--- somewhere, probably /usr/bin.-ghcLoc :: IO FilePath-ghcLoc = fromJust <$> findExecutable "ghc"---- The version of GHC installed.-ghcVersion :: IO String-ghcVersion = dropWhile (not . isDigit) <$> ghcRawOut ["--version"]---- The directory where GHC has all its libraries, etc.-ghcLibDir :: IO FilePath-ghcLibDir = canonicalizePath =<< ghcRawOut ["--print-libdir"]--ghcPkgRawOut :: [String] -> IO String-ghcPkgRawOut args = ghcPkgLoc >>= flip rawCommand args---- Cheat with using fromJust since we know that ghc-pkg must be in $PATH--- somewhere, probably /usr/bin.-ghcPkgLoc :: IO FilePath-ghcPkgLoc = fromJust <$> findExecutable "ghc-pkg"--ghcConfsPath, gentooConfsPath :: FilePath-ghcConfsPath = "package.conf.d"-gentooConfsPath = "gentoo"---- Return the Gentoo .conf files found in this GHC libdir-listConfFiles :: FilePath -> IO [FilePath]-listConfFiles subdir = do- dir <- ghcLibDir- let gDir = dir </> subdir- exists <- doesDirectoryExist gDir- if exists- then do conts <- listDirectory gDir- return $ map (gDir </>)- $ filter isConf conts- else return []- where- isConf file = takeExtension file == ".conf"--newtype CabalPV = CPV { unCPV :: String } -- serialized 'PackageIdentifier'- deriving (Ord, Eq, Show)---- Unique (normal) or multiple (broken) mapping-type ConfMap = Map.Map CabalPV [FilePath]---- Fold Gentoo .conf files from the current GHC version and--- create a Map-foldConf :: Verbosity -> [FilePath] -> IO ConfMap-foldConf v = foldM (addConf v) Map.empty---- cabal package text format--- "[InstalledPackageInfo {installedPackageId = Insta..."-parse_as_cabal_package :: BS.ByteString -> Maybe InstalledPackageInfo-parse_as_cabal_package cont =- case parseInstalledPackageInfo cont of- Left _es -> Nothing- Right (_ws, ipi) -> Just ipi---- ghc package text format--- "name: zlib-conduit\n--- version: 1.1.0\n--- id: zlib-condui..."-parse_as_ghc_package :: BS.ByteString -> Maybe CabalPV-parse_as_ghc_package cont =- case (map BS.words . BS.lines) cont of- ( [name_key, bn] : [ver_key, bv] : _)- | name_key == BS.pack "name:" && ver_key == BS.pack "version:"- -> Just $ CPV $ BS.unpack bn ++ "-" ++ BS.unpack bv- _ -> Nothing---- | Add this .conf file to the Map------ NOTE: It is important that the 'CabalPV's that are added to the 'ConfMap'--- should be in their "munged form", which may be z-encoded------ See:--- * <https://hackage.haskell.org/package/Cabal-syntax-3.12.0.0/docs/Distribution-Types-MungedPackageName.html>--- * <https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/symbol-names>-addConf :: Verbosity -> ConfMap -> FilePath -> IO ConfMap-addConf v cmp conf = do- bs <- BS.readFile conf- case- ( BS.null bs- , parse_as_ghc_package bs- , parse_as_cabal_package bs- ) of- -- empty files are created for- -- phony packages like CABAL_CORE_LIB_GHC_PV- -- and binary-only packages.- (True, _ , _ ) -> pure cmp- -- 'parse_as_ghc_package' is more efficient, so try it first- (_ , Just dn, _ ) -> do- vsay v $ unwords [conf, "resolved as ghc package:", show dn]- pure $ pushConf cmp dn conf- -- 'parse_as_cabal_package' is more flexible, so use it as a fallback- (_ , _ , Just ipi) -> do- let cpv = toCPV ipi- vsay v $ unwords [conf, "resolved as cabal package:", show (cpv, ipi)]- pure $ pushConf cmp cpv conf- _ -> do- say v $ unwords- [ "failed to parse", show conf, ":", show (BS.take 30 bs)]- return cmp- where- pushConf :: ConfMap -> CabalPV -> FilePath -> ConfMap- pushConf m k fp = Map.insertWith (++) k [fp] m-- -- 'MungedPackageId's get displayed using the z-encoded format, so are- -- compatible with ghc-pkg. This is important for resolving broken packages- -- (reported by ghc-pkg) to @.conf@ files!- toCPV :: InstalledPackageInfo -> CabalPV- toCPV = CPV . display . mungedId--checkPkgs :: Verbosity- -> ([CabalPV], [FilePath])- -> IO ([Package],[CabalPV],[FilePath])-checkPkgs v (pns, gentoo_cnfs) = do- files_to_pkgs <- resolveFiles gentoo_cnfs- 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)- , "of"- , show (length gentoo_cnfs)- ]- return (pkgs, pns, orphan_gentoo_files)---- --------------------------------------------------------------------------------- Finding packages installed with other versions of GHC-oldGhcPkgs :: Verbosity -> IO (Set.Set Package)-oldGhcPkgs v =- do thisGhc <- ghcLibDir- vsay v $ "oldGhcPkgs ghc lib: " ++ show thisGhc- let thisGhc' = BS.pack thisGhc- -- It would be nice to do this, but we can't assume- -- some crazy user hasn't deleted one of these dirs- -- libFronts' <- filterM doesDirectoryExist libFronts- notGHC <$> checkLibDirs v thisGhc' libFronts---- Find packages installed by other versions of GHC in this possible--- library directory.-checkLibDirs :: Verbosity -> BSFilePath -> [BSFilePath] -> IO (Set.Set Package)-checkLibDirs v thisGhc libDirs =- do vsay v $ "checkLibDir ghc libs: " ++ show (thisGhc, libDirs)- pkgsHaveContent (hasDirMatching wanted)- where- wanted dir = isValid dir && (not . isInvalid) dir-- isValid dir = any (`isGhcLibDir` dir) libDirs--#if MIN_VERSION_bytestring(0,11,1)- -- Correct the path for hadrian-based installations- -- See https://github.com/gentoo-haskell/haskell-updater/issues/20- thisGhc' = if BS.isSuffixOf (BS.pack "/lib") thisGhc then BS.dropEnd 4 thisGhc else thisGhc-- -- Invalid if it's this GHC- isInvalid fp = fp == thisGhc' || BS.isPrefixOf (thisGhc' `BS.snoc` pathSeparator) fp-#else- -- Versions of GHC with old 'bytestring' can use the old behavior- isInvalid fp = fp == thisGhc || BS.isPrefixOf (thisGhc `BS.snoc` pathSeparator) fp-#endif---- A valid GHC library directory starting at libdir has a name of--- "ghc", then a hyphen and then a version number.-isGhcLibDir :: BSFilePath -> BSFilePath -> Bool-isGhcLibDir libdir dir = go ghcDirName- where- -- This is hacky because FilePath doesn't work on Bytestrings...- libdir' = BS.snoc libdir pathSeparator- ghcDirName = BS.pack "ghc"-- go dn = BS.isPrefixOf ghcDir dir- -- Any possible version starts with a digit- && isDigit (BS.index dir ghcDirLen)- where- ghcDir = flip BS.snoc '-' $ BS.append libdir' dn- ghcDirLen = BS.length ghcDir----- The possible places GHC could have installed lib directories-libFronts :: [BSFilePath]-libFronts = map BS.pack- $ do lib <- ["lib", "lib64"]- return $ "/" </> "usr" </> lib---- --------------------------------------------------------------------------------- Finding broken packages in this install of GHC.-brokenPkgs :: Verbosity -> IO ([Package],[CabalPV],[FilePath])-brokenPkgs v = brokenConfs v >>= checkPkgs v---- .conf files from broken packages of this GHC version--- Returns two lists:--- '[CabalPV]' - list of broken cabal packages we could not resolve--- to Gentoo's .conf files--- '[FilePath]' - list of '.conf' files resolved from broken--- CabalPV reported by 'ghc-pkg check'-brokenConfs :: Verbosity -> IO ([CabalPV], [FilePath])-brokenConfs v =- do vsay v "brokenConfs: getting broken output from 'ghc-pkg'"- ghc_pkg_brokens <- getBrokenGhcPkg- vsay v $ unwords ["brokenConfs: resolving Cabal package names to gentoo equivalents."- , show (length ghc_pkg_brokens)- , "Cabal packages are broken:"- , unwords $ map unCPV ghc_pkg_brokens- ]-- (orphan_broken, orphan_confs) <- getOrphanBroken- vsay v $ unwords [ "brokenConfs: ghc .conf orphans:"- , show (length orphan_broken)- , "are orphan:"- , unwords $ map unCPV orphan_broken- ]-- installed_but_not_registered <- getNotRegistered v- vsay v $ unwords [ "brokenConfs: ghc .conf not registered:"- , show (length installed_but_not_registered)- , "are not registered:"- , unwords $ map unCPV installed_but_not_registered- ]-- registered_twice <- getRegisteredTwice v- vsay v $ unwords [ "brokenConfs: ghc .conf registered twice:"- , show (length registered_twice)- , "are registered twice:"- , unwords $ map unCPV registered_twice- ]-- let all_broken = concat [ ghc_pkg_brokens- , orphan_broken- , installed_but_not_registered- , registered_twice- ]-- vsay v "brokenConfs: reading '*.conf' files"- cnfs <- listConfFiles gentooConfsPath >>= foldConf v- vsay v $ "brokenConfs: got " ++ show (Map.size cnfs) ++ " '*.conf' files"- let (known_broken, orphans) = partitionEithers $ map (matchConf cnfs) all_broken- return (known_broken, orphan_confs ++ L.concat orphans)- where- -- Attempt to match the provided broken package to one of the- -- installed packages.- matchConf :: ConfMap -> CabalPV -> Either CabalPV [FilePath]- matchConf cmp cpv =- case Map.lookup cpv cmp of- Just fps -> Right fps- Nothing -> Left cpv---- Return the closure of all packages affected by breakage--- in format of ["name-version", ... ]-getBrokenGhcPkg :: IO [CabalPV]-getBrokenGhcPkg = map CPV . words- <$> ghcPkgRawOut ["check", "--simple-output"]--getOrphanBroken :: IO ([CabalPV], [FilePath])-getOrphanBroken = do- -- Around Jan 2015 we have started to install- -- all the .conf files in 'src_install()' phase.- -- Here we pick orphan ones and notify user about it.- registered_confs <- listConfFiles ghcConfsPath- confs_to_pkgs <- resolveFiles registered_confs- 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 $- fmap parse_as_ghc_package . BS.readFile- return (orphan_packages, orphan_conf_files)---- Return packages, that seem to have--- been installed via emerge (have gentoo/.conf entry),--- but are not registered in package.conf.d.--- Usually happens on manual cleaning or--- due to unregistration bugs in old eclass.-getNotRegistered :: Verbosity -> IO [CabalPV]-getNotRegistered v = do- installed_confs <- listConfFiles gentooConfsPath >>= foldConf v- registered_confs <- listConfFiles ghcConfsPath >>= foldConf v- return $ Map.keys installed_confs L.\\ Map.keys registered_confs---- Return packages, that seem to have--- been installed more, than once.--- It usually happens this way:--- 1. user installs dev-lang/ghc-7.8.4-r0 (comes with bundled transformers-3.0.0.0-ghc-7.8.4-{abi}.conf)--- 2. user installs dev-haskell/transformers-0.4.3.0 (registered as transformers-0.4.3.0-{abi}.conf)--- 3. user upgrades up to dev-lang/ghc-7.8.4-r4 (comes with bundled transformers-0.4.3.0-ghc-7.8.4-{abi}.conf)--- this way we have single package registered twice:--- transformers-0.4.3.0-ghc-7.8.4-{abi}.conf--- transformers-0.4.3.0-{abi}.conf--- It's is easy to fix just by reinstalling transformers.-getRegisteredTwice :: Verbosity -> IO [CabalPV]-getRegisteredTwice v = do- registered_confs <- listConfFiles ghcConfsPath >>= foldConf v- let registered_twice = Map.filter (\fs -> length fs > 1) registered_confs-- -- Double check that all of the "duplicates" are main libraries, since- -- a package may also have one or more sub-libraries registered as- -- well.- rtMainLibs <- foldM- (\m k -> Map.alterF onlyMultipleMains k m)- registered_twice- (Map.keys registered_twice)-- return $ Map.keys rtMainLibs- where- -- Filter out all but entries with multiple main libraries- onlyMultipleMains :: Maybe [FilePath] -> IO (Maybe [FilePath])- onlyMultipleMains (Just fps@(_:_)) = do- fps' <- filterM filterMain fps- -- Remove entries with one or less elements, since they are no longer- -- relevant to the getRegisteredTwice function- pure $ if length fps' <= 1 then Nothing else Just fps'- onlyMultipleMains _ = pure Nothing-- -- Only keep conf files that correspond to main libraries. This runs- -- 'parse_as_cabal_package' to get- filterMain :: FilePath -> IO Bool- filterMain conf = do- bs <- BS.readFile conf- let ipi = parse_as_cabal_package bs- pure $ case sourceLibName <$> ipi of- Just LMainLibName -> True- _ -> False---- -------------------------------------------------------------------------------allInstalledPackages :: IO (Set.Set Package)-allInstalledPackages = do libDir <- ghcLibDir- let libDir' = BS.pack libDir- fmap notGHC $ pkgsHaveContent- $ hasDirMatching (==libDir')
− Distribution/Gentoo/Packages.hs
@@ -1,226 +0,0 @@-{-# Language TupleSections #-}-{- |- Module : Distribution.Gentoo.Packages- Description : Dealing with installed packages on Gentoo.- Copyright : (c) Ivan Lazar Miljenovic, Lennart Kolmodin 2009- License : GPL-2 or later-- This module defines helper functions that deal with installed- packages in Gentoo.--}-module Distribution.Gentoo.Packages- ( Package(..)- , Content- , notGHC- , printPkg- , resolveFiles- , pkgsHaveContent- , hasDirMatching- ) where--import Data.Char(isDigit, isAlphaNum)-import Data.List(isPrefixOf)-import Data.Maybe-import qualified Data.ByteString.Char8 as BS-import Data.ByteString.Char8(ByteString)-import qualified Data.Set as S-import System.Directory( doesDirectoryExist- , doesFileExist- , listDirectory)-import System.FilePath((</>))-import Control.Monad--import Distribution.Gentoo.Util---- --------------------------------------------------------------------------------- Representation of a cat/pkgname in Gentoo. Note that this is--- overly simplified.--type Category = String-type Pkg = String -- Package name.-type VerPkg = String -- Package name with version.-type VCatPkg = (Category, VerPkg)-type Slot = String---- When we are (re-)building packages, we don't care about the--- version, just the slot.-data Package = Package Category Pkg (Maybe Slot)- deriving(Eq, Ord, Show, Read)---- Package equality, ignoring the Slot (i.e. same category and package--- name).-samePackageAs :: Package -> Package -> Bool-samePackageAs (Package c1 p1 _) (Package c2 p2 _)- = c1 == c2 && p1 == p2--ghcPkg :: Package-ghcPkg = Package "dev-lang" "ghc" Nothing---- Return all packages that are not a version of GHC.-notGHC :: S.Set Package -> S.Set Package-notGHC = S.filter (isNot ghcPkg)- where- isNot p1 = not . samePackageAs p1---- Pretty-print the Package name based on how PMs expect it-printPkg :: Package -> String-printPkg (Package c p s) = addS cp- where- addS = maybe id (flip (++) . (:) ':') s- cp = c ++ '/' : p---- Determine which slot the specific version of the package is in and--- create the appropriate Package value.-toPackage :: VCatPkg -> IO Package-toPackage cp@(c,vp) = do sl <- getSlot cp- let p = stripVersion vp- return $ Package c p sl---- Determine which slot the specific version of the package is in.-getSlot :: VCatPkg -> IO (Maybe Slot)-getSlot cp = do ex <- doesFileExist sFile- if ex- then parse- else return Nothing- where- sFile = pkgPath cp </> "SLOT"- -- EAPI=5 defines subslots- split_slot_subslot = break (== '/')- parse = do fl <- BS.unpack <$> BS.readFile sFile- -- Don't want the trailing newline- return $ listToMaybe $ map (fst . split_slot_subslot) $ lines fl---- | Remove the version information from the package name.-stripVersion :: VerPkg -> Pkg-stripVersion = concat . takeUntilVer . breakAll partSep- where- partSep x = x `elem` ['-', '_']-- -- Only the last bit that matches isVer is the real version bit.- -- Note that this doesn't check that the last non-version bit is- -- not a hyphen followed by digits.- takeUntilVer = concat . init . breakAll isVer-- isVer as = isVerFront (init as) && isAlphaNum (last as)- isVerFront ('-':as) = all (\a -> isDigit a || a == '.') as- isVerFront _ = False--pkgPath :: VCatPkg -> FilePath-pkgPath (c, vp) = pkgDBDir </> c </> vp--pkgDBDir :: FilePath-pkgDBDir = "/var/db/pkg"---- --------------------------------------------------------------------------------- Parsing the CONTENTS file of installed packages.---- Representation of individual lines in a CONTENTS file.-data Content = Dir BSFilePath- | Obj BSFilePath- deriving (Eq, Show, Ord)--isDir :: Content -> Bool-isDir (Dir _) = True-isDir _ = False--pathOf :: Content -> BSFilePath-pathOf (Dir dir) = dir-pathOf (Obj obj) = obj---- Searching predicates.--hasContentMatching :: (BSFilePath -> Bool) -> [Content] -> Bool-hasContentMatching p = any (p . pathOf)--hasDirMatching :: (BSFilePath -> Bool) -> [Content] -> Bool-hasDirMatching p = hasContentMatching p . filter isDir---- Parse the CONTENTS file.-parseContents :: VCatPkg -> IO [Content]-parseContents cp = do ex <- doesFileExist cFile- if ex- then parse- else return []- where- cFile = pkgPath cp </> "CONTENTS"-- parse = do lns <- BS.lines <$> BS.readFile cFile- return $ mapMaybe (parseCLine . BS.words) lns-- -- Use unwords of list rather than taking next element because of- -- how spaces are represented in file names.- -- This might cause a problem if there is more than a single- -- space (or a tab) in the filename...- -- Also require at least 3 words in case of an object, as the CONTENTS- -- file can be corrupt (fixes actual problem reported by user).- parseCLine :: [ByteString] -> Maybe Content- parseCLine (tp:ln)- | tp == dir = Just . Dir . BS.unwords $ ln- | tp == obj && length ln >= 3 = Just . Obj . BS.unwords $ dropLastTwo ln- | otherwise = Nothing- parseCLine [] = Nothing-- dropLastTwo :: [a] -> [a]- dropLastTwo = init . init-- obj = BS.pack "obj"- dir = BS.pack "dir"---- --------------------------------------------------------------------------------- Find all the packages that contain given files.-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)- | (pn, conts) <- pfs- , Obj fn <- conts- ]- grep pn cont = Just (pn, filter (\e -> S.member e fps') cont)---- | Run predecate 'p' for each installed package--- and gather all 'Just' values-forPkg :: Ord a => (Package -> [Content] -> Maybe a) -> IO [a]-forPkg p = do- categories <- installedCats- catMaybes <$> do- flip concatMapM categories $ \cat -> do- maybe_pkgs <- listDirectory (pkgDBDir </> cat)- packages <- filterM (isPackage . (cat,)) maybe_pkgs- forM packages $ \pkg -> do- let cp = (cat, pkg)- cpn <- toPackage cp- cont <- parseContents cp- return $ p cpn cont- where- isPackage :: VCatPkg -> IO Bool- isPackage vcp@(_, vp) = do- c1 <- doesDirectoryExist $ pkgPath vcp- let c2 = not $ "-MERGING-" `isPrefixOf` vp- return $ c1 && c2---- Find which packages have Content information that matches the--- provided predicate; to be used with the searching predicates--- above.-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---- Determine if this is a valid Category (such that at least one--- package in that category has been installed).-isCat :: String -> IO Bool-isCat fp = do isD <- doesDirectoryExist (pkgDBDir </> fp)- return $ isD && isCat' fp- where- isCat' ('.':_) = False- isCat' "world" = False- isCat' _ = True---- Return all Categories known in this system.-installedCats :: IO [Category]-installedCats = filterM isCat =<< listDirectory pkgDBDir
− Distribution/Gentoo/PkgManager.hs
@@ -1,219 +0,0 @@-{-# LANGUAGE LambdaCase #-}--{- |- Module : Distribution.Gentoo.PkgManager- Description : Using package managers in Gentoo.- Copyright : (c) Ivan Lazar Miljenovic, Emil Karlson 2010- License : GPL-2 or later-- This module defines ways to use different Gentoo package managers.- -}-module Distribution.Gentoo.PkgManager- ( definedPMs- , choosePM- , stringToCustomPM- , isValidPM- , 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)---- --------------------------------------------------------------------------------- | The default package manager. If the environment variable--- @PACKAGE_MANAGER@ exists, use that; otherwise default to--- "portage". Note that even if that environment variable is--- defined, if it is unknown then it won't be used.-defaultPM :: IO PkgManager-defaultPM = do eDPM <- lookup "PACKAGE_MANAGER" `fmap` getEnvironment- let dPM = fromMaybe defaultPMName eDPM- mPM = dPM `M.lookup` pmNameMap- return $ fromMaybe knownDef mPM- where- knownDef = pmNameMap M.! defaultPMName--defaultPMName :: String-defaultPMName = "portage"---- | The names of known package managers.-definedPMs :: [String]-definedPMs = M.keys pmNameMap--isValidPM :: PkgManager -> Either String PkgManager-isValidPM (InvalidPM pmname) = Left pmname-isValidPM pm = Right pm--pmNameMap :: Map String PkgManager-pmNameMap = M.fromList [ ("portage", Portage)- , ("pkgcore", PkgCore)- , ("paludis", Paludis)- ]--pmNameMap' :: Map PkgManager String-pmNameMap' = M.fromList . map (\(nm,pm) -> (pm,nm)) $ M.toList pmNameMap--nameOfPM :: PkgManager -> String-nameOfPM (CustomPM pmname) = "custom package manager command: " ++ pmname-nameOfPM (InvalidPM pmname) = "invalid package manager: " ++ pmname-nameOfPM pm = pmNameMap' M.! pm---- | Choose the appropriate PM from the textual representation; throws--- an error if that PM isn't known.-choosePM :: String -> PkgManager-choosePM pm = fromMaybe (InvalidPM pm) $ pm' `M.lookup` pmNameMap- where- pm' = map toLower pm--stringToCustomPM :: String -> PkgManager-stringToCustomPM = CustomPM--pmCommand :: PkgManager -> String-pmCommand Portage = "emerge"-pmCommand PkgCore = "pmerge"-pmCommand Paludis = "cave"-pmCommand (CustomPM cmd) = cmd-pmCommand (InvalidPM _) = undefined--defaultPMFlags :: PkgManager -> [String]-defaultPMFlags Portage = [ "--oneshot"- , "--keep-going"- , "--complete-graph"- ]-defaultPMFlags PkgCore = [ "--deep"- , "--oneshot"- , "--ignore-failures"- ]-defaultPMFlags Paludis = [ "resolve"- , "--execute"- , "--preserve-world"- , "--continue-on-failure", "if-independent"- ]-defaultPMFlags CustomPM{} = []-defaultPMFlags (InvalidPM _) = undefined--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'.------ The rationale is that by marking broken packages by using--- @--reinstall-atoms@, portage will pretend that they are not yet--- installed, thus forcing their reinstallation. @--update@ is--- used and all installed Haskell packages are targeted so that the entire--- Haskell environment is examined. This has a side-effect of skipping--- packages that are masked or otherwise unavailable while still rebuilding--- needed dependencies that have been broken.-buildAltCmd- :: [PMFlag] -- ^ Basic flags- -> [String] -- ^ User-supplied flags- -> RAModePkgs -- ^ Set of packages to rebuild- -- | 'True' denotes a @world@ target- -> AllPkgs- -> (String, [String])-buildAltCmd fs rawPmFlags raPS allPs =- ( pmCommand Portage- , defaultPMFlags Portage- ++ mapMaybe (flagRep Portage) fs- ++ ["--update"]- ++ rawPmFlags- ++ usepkgExclude allPs- ++ reinst- ++ targs- )- where- (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---- -------------------------------------------------------------------------------flagRep :: PkgManager -> PMFlag -> Maybe String-flagRep Portage = portagePMFlag-flagRep PkgCore = pkgcorePMFlag-flagRep Paludis = cavePMFlag-flagRep CustomPM{} = const Nothing -- Can't tell how flags would work.-flagRep (InvalidPM _) = undefined--portagePMFlag :: PMFlag -> Maybe String-portagePMFlag PretendBuild = Just "--pretend"-portagePMFlag UpdateDeep = Just "--deep"-portagePMFlag UpdateAsNeeded = Nothing--pkgcorePMFlag :: PMFlag -> Maybe String-pkgcorePMFlag = portagePMFlag -- The options are the same for the 3- -- current flags.--cavePMFlag :: PMFlag -> Maybe String-cavePMFlag PretendBuild = Just "--no-execute"-cavePMFlag UpdateDeep = Just "--complete"-cavePMFlag UpdateAsNeeded = Just "--lazy"
− Distribution/Gentoo/PkgManager/Types.hs
@@ -1,24 +0,0 @@-{- |- Module : Distribution.Gentoo.PkgManager.Types-- Types relating to package managers supported by haskell-updater- -}--module Distribution.Gentoo.PkgManager.Types- ( PkgManager(..)- , PMFlag(..)- ) where---- | Defines the available Gentoo package managers.-data PkgManager = Portage- | PkgCore- | Paludis- | InvalidPM String- | CustomPM String- deriving (Eq, Ord, Show, Read)---- | Different optional flags to be passed to the PM.-data PMFlag = PretendBuild- | UpdateDeep- | UpdateAsNeeded- deriving (Eq, Ord, Show, Read)
− Distribution/Gentoo/Types.hs
@@ -1,114 +0,0 @@-{- |- Module : Distribution.Gentoo.Types-- General types needed for haskell-updater functionality- -}--{-# LANGUAGE TypeApplications #-}--module Distribution.Gentoo.Types- ( RunModifier(..)- , RawPMArgs- , WithCmd(..)- , WithUserCmd- , CustomTargets- , PackageState(..)- , DefaultModePkgs(..)- , ListModePkgs(..)- , RAModePkgs(..)- , HasTargets(..)- , InvalidPkgs(..)- , AllPkgs(..)- , PackageSet(..)- ) where--import qualified Data.Set as Set--import Distribution.Gentoo.Packages-import Distribution.Gentoo.PkgManager.Types-import Output---- | Run-mode haskell-updater state-data RunModifier = RM { flags :: [PMFlag]- , withCmd :: WithCmd- , rawPMArgs :: RawPMArgs- , verbosity :: Verbosity- }- deriving (Eq, Ord, Show)---- | Arguments to be passed when calling the package manager-type RawPMArgs = [String]--data WithCmd = PrintAndRun- | PrintOnly- | RunOnly- deriving (Eq, Ord, Show, Read, Enum, Bounded)--type WithUserCmd = Either String WithCmd--type CustomTargets = [String]---- | The current package list(s) organized by mode and build target-data PackageState- = DefaultModeState (Maybe DefaultModePkgs)- | ListModeState ListModePkgs- | RAModeState AllPkgs RAModePkgs- deriving (Show, Eq, Ord)--data DefaultModePkgs- = DefaultInvalid InvalidPkgs- | DefaultAll AllPkgs- deriving (Show, Eq, Ord)--data ListModePkgs- = ListInvalid InvalidPkgs- | ListAll AllPkgs- deriving (Show, Eq, Ord)--data RAModePkgs- = RAModeInvalid InvalidPkgs- | RAModeAll- | RAModeWorld InvalidPkgs- | RAModeCustom CustomTargets InvalidPkgs- deriving (Show, Eq, Ord)--class HasTargets t where- targetPkgs :: t -> Set.Set Package--instance HasTargets PackageState where- 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- targetPkgs (DefaultInvalid ps) = getPkgs ps- targetPkgs (DefaultAll ps) = getPkgs ps--instance HasTargets ListModePkgs where- targetPkgs (ListInvalid ps) = getPkgs ps- targetPkgs (ListAll ps) = getPkgs ps--instance HasTargets t => HasTargets (Maybe t) where- targetPkgs (Just ps) = targetPkgs ps- targetPkgs Nothing = Set.empty--newtype InvalidPkgs = InvalidPkgs (Set.Set Package)- deriving (Show, Eq, Ord)--newtype AllPkgs = AllPkgs (Set.Set Package)- deriving (Show, Eq, Ord)--class PackageSet t where- getPkgs :: t -> Set.Set Package--instance PackageSet InvalidPkgs where- getPkgs (InvalidPkgs ps) = ps--instance PackageSet AllPkgs where- getPkgs (AllPkgs ps) = ps--instance PackageSet () where- getPkgs () = Set.empty
− Distribution/Gentoo/Types/HUMode.hs
@@ -1,59 +0,0 @@-{- |- 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
− Distribution/Gentoo/Util.hs
@@ -1,25 +0,0 @@-{- |- Module : Distribution.Gentoo.Util- Description : Utility functions- Copyright : (c) Ivan Lazar Miljenovic 2009- License : GPL-2 or later-- Common utility functions.- -}-module Distribution.Gentoo.Util- ( BSFilePath- , concatMapM- , breakAll- ) where--import qualified Data.List as L-import Data.ByteString.Char8(ByteString)---- Alias used to indicate that this ByteString represents a FilePath-type BSFilePath = ByteString--concatMapM :: (a -> IO [b]) -> [a] -> IO [b]-concatMapM f = fmap concat . traverse f--breakAll :: (a -> Bool) -> [a] -> [[a]]-breakAll p = L.groupBy (const (not . p))
− Main.hs
@@ -1,331 +0,0 @@-{- |- Module : Main- Description : The haskell-updater executable- Copyright : (c) Ivan Lazar Miljenovic, Stephan Friedrichs, Emil Karlson 2010- License : GPL-2 or later-- The executable module of haskell-updater, which finds Haskell- packages to rebuild after a dep upgrade or a GHC upgrade.--}--{-# LANGUAGE LambdaCase #-}--module Main (main) where--import Distribution.Gentoo.CmdLine-import qualified Distribution.Gentoo.CmdLine.Types as CmdLine -- (CmdLineArgs, BuildTarget)-import Distribution.Gentoo.GHC-import Distribution.Gentoo.Packages-import Distribution.Gentoo.PkgManager-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 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)-import System.Console.GetOpt-import System.Environment (getArgs, getProgName)-import System.Exit (ExitCode (..), exitSuccess, exitWith)-import System.IO (hPutStrLn, stderr)-import System.Process (rawSystem)--import Output--main :: IO ()-main = do args <- getArgs- defPM <- defaultPM- case parseArgs defPM args of- Left err -> die err- Right (cmdArgs, rawArgs) -> runAction cmdArgs rawArgs--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 = Seq (Set.Set Package, ExitCode)--data TargetType- = InvalidTargets- | AllTargets- | UpdateTargets--initialHistory :: DriverHistory-initialHistory = Seq.empty--dumpHistory :: Verbosity -> DriverHistory -> IO ()-dumpHistory v historySeq = do- say v "Updater's past history:"- 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- -> PkgManager- -> RawPMArgs- -> IO a-runDriver rm pkgMgr rawArgs = do- systemInfo rm pkgMgr rawArgs- updaterPass initialHistory- success v "done!"- where- v = verbosity rm-- updaterPass :: DriverHistory -> IO ()- updaterPass pastHistory = getPackageState v pkgMgr >>= \case- ListModeState m -> do- mapM_ (putStrLn . printPkg) (targetPkgs m)- success v "done!"- DefaultModeState (Just (DefaultInvalid ts)) ->- continuePass (Left . DefaultInvalid) InvalidTargets ts- DefaultModeState (Just (DefaultAll ts)) ->- continuePass (Left . DefaultAll) AllTargets ts- DefaultModeState 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- :: PackageSet ts- => (ts -> Either DefaultModePkgs (RAModePkgs, AllPkgs))- -> TargetType- -> ts- -> IO ()- continuePass cnst targetType ts = do- let next ec = updaterPass- $ pastHistory <> Seq.singleton (getPkgs ts, ec)-- 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"-- exitCode <- buildPkgs pkgMgr rm (cnst ts)-- next exitCode- AllTargets -> do- exitCode <- buildPkgs pkgMgr rm (cnst ts)-- 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."- say v ""- old <- oldGhcPkgs v- pkgListPrintLn v "old" old-- say v "Searching for Haskell libraries with broken dependencies."- say v ""- (broken, unknown_packages, unknown_files) <- brokenPkgs v- let broken' = Set.fromList broken- printUnknownPackagesLn (map unCPV unknown_packages)- printUnknownFilesLn unknown_files- pkgListPrintLn v "broken" (notGHC broken')-- return $ InvalidPkgs $ old <> broken'-- getAll = do- say v "Searching for packages installed with the current version of GHC."- say v ""- pkgs <- allInstalledPackages- pkgListPrintLn v "installed" pkgs- return $ AllPkgs pkgs-- checkForNull :: PackageSet ts => (ts -> b) -> ts -> Maybe b- checkForNull cnst l- | null (getPkgs l) = Nothing- | otherwise = Just (cnst l)-- printUnknownPackagesLn [] = return ()- printUnknownPackagesLn ps = do- say v "The following packages are orphan (not installed by your package manager):"- printList v id ps- say v ""- printUnknownFilesLn [] = return ()- printUnknownFilesLn fs = do- say v $ "The following files are orphan (not installed by your package manager):"- printList v id fs- say v $ "It is strongly advised to remove orphans:"- say v $ " One of known sources of orphans is packages installed before 01 Jan 2015."- say v $ " If you know it's your case you can easily remove such files:"- say v $ " # rm -v -- `qfile -o $(ghc --print-libdir)/package.conf.d/*.conf $(ghc --print-libdir)/gentoo/*.conf`"- say v $ " # ghc-pkg recache"- say v $ " It will likely need one more 'haskell-updater' run."- say v ""--runCmd :: WithCmd -> String -> [String] -> IO ExitCode-runCmd m cmd args = case m of- RunOnly -> runCommand cmd args- PrintOnly -> putStrLn cmd_line >> exitSuccess- PrintAndRun -> putStrLn cmd_line >> runCommand cmd args- where- cmd_line = unwords (cmd : (showArg <$> args))- showArg s- | words s == [s] = s- | otherwise = show s -- Put quotes around args with spaces in them--runCommand :: String -> [String] -> IO ExitCode-runCommand cmd args = rawSystem cmd args--buildPkgs- :: PkgManager- -> RunModifier- -> Either DefaultModePkgs (RAModePkgs, AllPkgs)- -> IO ExitCode-buildPkgs pkgMgr rm ts = runCmd (withCmd rm) cmd args- where- (cmd, args) = case ts of- Left ps ->- buildCmd pkgMgr (flags rm) (rawPMArgs rm) ps- Right (ps, allPkgs) ->- buildAltCmd (flags rm) (rawPMArgs rm) ps allPkgs---- -------------------------------------------------------------------------------- Printing information.--help :: IO a-help = progInfo >>= success Normal--version :: IO a-version = fmap (++ '-' : showVersion Paths.version) getProgName >>= success Normal--progInfo :: IO String-progInfo = do pName <- getProgName- return $ usageInfo (header pName) options- where- header pName = unlines [ pName ++ " -- Find and rebuild packages broken due to any of:"- , " * GHC upgrade"- , " * Haskell dependency upgrade"- , ""- , "Usage: " ++ pName ++ " [Options [-- [PM options]]"- , ""- , ""- , "Options:"]--systemInfo- :: RunModifier- -> PkgManager- -> RawPMArgs- -> IO ()-systemInfo rm pkgMgr rawArgs = do- ver <- ghcVersion- pName <- getProgName- let pVer = showVersion Paths.version- pLoc <- ghcLoc- libDir <- ghcLibDir- say v $ "Running " ++ pName ++ "-" ++ pVer ++ " using GHC " ++ ver- say v $ " * Executable: " ++ pLoc- say v $ " * Library directory: " ++ libDir- say v $ " * Package manager (PM): " ++ nameOfPM (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--success :: Verbosity -> String -> IO a-success v msg = do say v msg- exitSuccess--die :: String -> IO a-die msg = do putErrLn ("ERROR: " ++ msg)- exitWith (ExitFailure 1)--putErrLn :: String -> IO ()-putErrLn = hPutStrLn stderr
− Output.hs
@@ -1,53 +0,0 @@-{- |- Module : Main- Description : The haskell-updater executable- License : GPL-2 or later-- Fancy output facility.--}-module Output (- pkgListPrintLn- , printList- , say- , vsay- , Verbosity(..)- ) where--import qualified Data.Set as Set-import System.IO (hPutStrLn, stderr)--import Distribution.Gentoo.Packages---- output mode (chattiness)-data Verbosity = Quiet- | Normal- | Verbose- deriving (Eq, Ord, Show, Read)--say :: Verbosity -> String -> IO ()-say verb_l msg =- case verb_l of- Quiet -> return ()- Normal -> hPutStrLn stderr msg- Verbose -> hPutStrLn stderr msg--vsay :: Verbosity -> String -> IO ()-vsay verb_l msg =- case verb_l of- Quiet -> return ()- Normal -> return ()- Verbose -> hPutStrLn stderr msg---- Print a bullet list of values with one value per line.-printList :: Verbosity -> (a -> String) -> [a] -> IO ()-printList v f = mapM_ (say v . (++) " * " . f)---- Print a list of packages, with a description of what they are.-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 (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.1.0+version: 1.5.0.0 synopsis: Rebuild Haskell dependencies in Gentoo description: haskell-updater rebuilds Haskell packages on Gentoo@@ -38,9 +38,10 @@ , GHC ==9.0.2 , GHC ==9.2.8 , GHC ==9.4.8- , GHC ==9.6.5- , GHC ==9.8.2+ , GHC ==9.6.6+ , GHC ==9.8.4 , GHC ==9.10.1+ , GHC ==9.12.1 source-repository head type: git@@ -59,29 +60,32 @@ executable haskell-updater import: all+ hs-source-dirs: src/ main-is: Main.hs other-modules: Distribution.Gentoo.CmdLine Distribution.Gentoo.CmdLine.Types+ Distribution.Gentoo.Env Distribution.Gentoo.GHC Distribution.Gentoo.Packages Distribution.Gentoo.PkgManager Distribution.Gentoo.PkgManager.Types Distribution.Gentoo.Types- Distribution.Gentoo.Types.HUMode+ Distribution.Gentoo.Types.Mode Distribution.Gentoo.Util Output Paths_haskell_updater autogen-modules: Paths_haskell_updater build-depends:- , base >=4.12 && <5- , bytestring- , Cabal >=1.8- , containers- , directory >=1.2.5.0- , filepath- , process+ , base >=4.15.1.0 && <5+ , bytestring >=0.10.12.1 && <0.13+ , Cabal >=3.4.1.0 && <3.15+ , containers >=0.6.4.1 && <0.8+ , directory >=1.2.5.0 && <1.4+ , filepath >=1.4.2.1 && <1.6+ , mtl >=2.2.2 && <2.3.1+ , process ^>=1.6.13.2 -- Only force new bytestring on versions of GHC that come bundled with it if impl(ghc >= 9.2.1)
+ src/Distribution/Gentoo/CmdLine.hs view
@@ -0,0 +1,281 @@+{- |+ 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.Mode@).+ -}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}++module Distribution.Gentoo.CmdLine+ ( parseArgs+ , mkHUMode+ , options+ , argString+ ) where++import Control.Monad ((>=>))+import qualified Data.List.NonEmpty as NE+import Data.Monoid (Ap(..))+import Data.Maybe (fromMaybe)+import Data.Proxy+import Data.Semigroup (Last(..), sconcat)+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.Mode as Mode+import Distribution.Gentoo.Util (These(..), singletonNE)+import Output++-- | Process arguments from the command line. Returns an error string if the+-- user provided incorrect or unknown options.+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, _, _) ->+ (,raw) <$> foldr (>=>) pure fs (defCmdLineArgs defPM)++-- | Parse processed command line arguments into a 'Mode.HUMode'. Returns an+-- error string if the user supplied non-compatible option combinations.+mkHUMode :: CmdLineArgs -> RawPMArgs -> Either String Mode.HUMode+mkHUMode cmdLine raw+ | cmdLineHelp cmdLine = pure Mode.HelpMode+ | cmdLineVersion cmdLine = pure Mode.VersionMode+ | otherwise = do+ mPkgMgr <- mkPkgManager (cmdLinePkgManager cmdLine)+ pure $ Mode.RunMode runModifier mPkgMgr+ where+ mkPkgManager :: PkgManager -> Either String Mode.PkgManager+ mkPkgManager = \case+ Portage -> Mode.Portage <$> mkPortageMode (cmdLineMode cmdLine)+ PkgCore -> Mode.PkgCore <$> mkMode (cmdLineMode cmdLine)+ Paludis -> Mode.Paludis <$> mkMode (cmdLineMode cmdLine)+ CustomPM pm -> Mode.CustomPM pm <$> mkMode (cmdLineMode cmdLine)+ pm@(InvalidPM _) -> Left $+ "Invalid package manager in mkHUMode: " ++ show pm++ -- Logic for parsing modes for non-portage package managers+ mkMode :: RunMode -> Either String Mode.RunMode+ mkMode = \case+ BasicMode -> Mode.BasicMode <$> go (cmdLineTargets cmdLine)+ ListMode -> Mode.ListMode <$> go (cmdLineTargets cmdLine)+ ReinstallAtomsMode -> Left+ "reinstall-atoms mode is only supported by the portage package manager"+ where+ go = maybe (Right Mode.OnlyInvalid) (onlyLast mkTarget)++ -- Logic for parsing targets for non-portage package managers+ mkTarget :: Either CustomTarget BuildTarget -> Either String Mode.Target+ mkTarget = \case+ Right OnlyInvalid -> Right Mode.OnlyInvalid+ Right AllInstalled -> Right Mode.AllInstalled+ Right PreservedRebuild -> Left $+ "preserved-rebuild target is only supported by the portage \+ \package manager"+ Right WorldTarget -> Left+ "world target is only supported in reinstall-atoms mode"+ Left _ -> Left+ "custom targets are only supported in reinstall-atoms mode"++ -- Logic for parsing modes for portage+ mkPortageMode+ :: RunMode+ -> Either String Mode.PortageMode+ mkPortageMode = \case+ BasicMode -> Mode.PortageBasicMode+ <$> withDefTarget+ (onlyLast mkPortageBasicTarget)+ maybeTargs+ ListMode -> Mode.PortageListMode+ <$> withDefTarget+ (onlyLast mkPortageTarget)+ maybeTargs+ ReinstallAtomsMode -> Mode.ReinstallAtomsMode+ <$> withDefTarget mkPortageRATarget maybeTargs+ where+ maybeTargs = cmdLineTargets cmdLine++ -- Logic for parsing targets for portage's basic mode+ mkPortageBasicTarget+ :: Either CustomTarget BuildTarget+ -> Either String (Either Mode.PortageBasicTarget Mode.Target)+ mkPortageBasicTarget = \case+ Right PreservedRebuild -> Right $ Left Mode.PreservedRebuild+ targ -> Right <$> mkPortageTarget targ++ -- Logic for parsing targets for portage's reinstall-atoms mode+ mkPortageRATarget+ :: NE.NonEmpty (Either CustomTarget BuildTarget)+ -> Either String Mode.RATargets+ mkPortageRATarget = foldTargets $ \case+ Left ct -> Right $ Mode.RATargets $ That $ That $ singletonNE ct+ Right WorldTarget -> Right $ Mode.RATargets $ That $ This $+ if cmdLineWorldFull cmdLine+ then Mode.WorldFullTarget+ else Mode.WorldTarget+ targ -> Mode.RATargets . This <$> mkPortageTarget targ++ -- Logic for parsing targets for portage's list mode; also common logic+ -- for parsing targets, between portage's basic and reinstall-atoms modes+ mkPortageTarget+ :: Either CustomTarget BuildTarget+ -> Either String Mode.Target+ mkPortageTarget = \case+ Right OnlyInvalid -> Right Mode.OnlyInvalid+ Right AllInstalled -> Right Mode.AllInstalled+ Right PreservedRebuild -> Left+ "preserved-rebuild target is only supported in basic mode"+ Right WorldTarget -> Left+ "world target is only supported in reinstall-atoms mode"+ Left _ -> Left+ "custom targets are only supported in reinstall-atoms mode"++ 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+ }++ -- Uses the default target if none were specified on the command line+ withDefTarget+ :: (NE.NonEmpty (Either CustomTarget BuildTarget) -> a)+ -> Maybe (NE.NonEmpty (Either CustomTarget BuildTarget))+ -> a+ withDefTarget f = f . fromMaybe (NE.singleton defTarget)+ where+ defTarget = Right OnlyInvalid++ -- Uses 'Data.Semigroup.Last' to only grab the last target specified+ onlyLast+ :: Applicative f+ => (a -> f b)+ -> NE.NonEmpty a+ -> f b+ onlyLast f = fmap (getLast . sconcat . fmap Last) . traverse f++ -- Uses 'Data.Monoid.Ap' to combine RATargets inside an Applicative+ foldTargets+ :: (Applicative f, Semigroup b)+ => (a -> f b)+ -> NE.NonEmpty a+ -> f b+ foldTargets f = getAp . sconcat . fmap (Ap . f)++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 c -> pure $ c { cmdLinePkgManager = CustomPM s }) "command")+ $ "Use custom command as package manager;\n"+ ++ " ignores the --pretend and --no-deep flags."+ , Option ['p'] ["pretend"]+ (naUpdate $ \c -> c { cmdLinePretend = True } )+ "Only pretend to build packages."+ , Option [] ["no-deep"]+ (naUpdate $ \c -> c { cmdLineNoDeep = True } )+ "Don't pull deep dependencies (--deep with emerge)."+ , Option ['V'] ["version"]+ (naUpdate $ \c -> c { cmdLineVersion = True })+ "Version information."+ , Option [] ["action"]+ (ReqArg (fromCmdline (\a c -> c { cmdLineAction = a })) "action")+ (argHelp (Proxy @WithCmd))+ , Option [] ["target"]+ (ReqArg (fromCmdline (\a -> updateTarget (Right a))) "target")+ (argHelp (Proxy @BuildTarget))+ , Option ['c'] ["dep-check"]+ (naUpdate $ updateTarget (Right OnlyInvalid))+ $ "alias for --target=" ++ argString OnlyInvalid+ -- deprecated alias for 'dep-check'+ , Option ['u'] ["upgrade"]+ (naUpdate $ updateTarget (Right OnlyInvalid))+ $ "alias for --target=" ++ argString OnlyInvalid+ , Option ['a'] ["all"]+ (naUpdate $ updateTarget (Right AllInstalled))+ $ "alias for --target=" ++ argString AllInstalled+ , Option ['W'] ["world"]+ (naUpdate $ \c -> updateTarget (Right WorldTarget) c+ { cmdLinePkgManager = Portage+ , cmdLineMode = ReinstallAtomsMode+ }+ ) $ "alias for --package-manager=portage"+ ++ " \\\n --target=" ++ argString WorldTarget+ ++ " \\\n --mode=" ++ argString ReinstallAtomsMode+ , Option [] ["world-full"]+ (naUpdate $ \c -> updateTarget (Right WorldTarget) c+ { cmdLinePkgManager = Portage+ , cmdLineMode = ReinstallAtomsMode+ , cmdLineWorldFull = True+ }+ ) $ "alias for --world -- --newuse --with-bdeps=y"+ , Option [] ["preserved-rebuild"]+ (naUpdate $ updateTarget (Right PreservedRebuild))+ $ "alias for --target=" ++ argString PreservedRebuild+ , 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."+ , Option [] ["mode"]+ (ReqArg (fromCmdline (\a c -> c { cmdLineMode = a })) "mode")+ (argHelp (Proxy @RunMode))+ , Option ['l'] ["list-only"]+ (naUpdate $ \c -> c { cmdLineMode = ListMode })+ $ "alias for --mode=" ++ argString ListMode+ , Option ['R'] ["reinstall-atoms"]+ (naUpdate $ \c -> c { cmdLineMode = ReinstallAtomsMode })+ $ "alias for --mode=" ++ argString ReinstallAtomsMode+ , Option ['q'] ["quiet"]+ (naUpdate $ \c -> c { cmdLineVerbosity = Quiet })+ "Print only fatal errors (to stderr)."+ , Option ['v'] ["verbose"]+ (naUpdate $ \c -> c { cmdLineVerbosity = Verbose })+ "Be more elaborate (to stderr)."+ , Option ['h', '?'] ["help"]+ (naUpdate $ \c -> c { cmdLineHelp = True })+ "Print this help message."+ ]++ where+ naUpdate f = NoArg (pure . f)++ -- This touches some legacy code so we need a custom handler for it+ mkPM :: String -> CmdLineArgs -> Either String CmdLineArgs+ mkPM s c = case choosePM s of+ InvalidPM pm -> Left $ "Unknown package manager: " ++ pm+ 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."++ updateTarget :: Either CustomTarget BuildTarget -> CmdLineArgs -> CmdLineArgs+ updateTarget new old =+ let ne = NE.singleton new+ newT = maybe ne (<> ne) (cmdLineTargets old)+ in old { cmdLineTargets = Just newT }
+ src/Distribution/Gentoo/CmdLine/Types.hs view
@@ -0,0 +1,191 @@+{- |+ 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(..)+ , CustomTarget+ , RunMode(..)+ -- * Multiple-choice arguments+ , CmdlineOpt(..)+ -- ** getter functions+ , argString+ , argDescription+ -- ** utility functions+ , argHelp+ , fromCmdline+ ) where++import Data.Char (toLower)+import qualified Data.List as L+import qualified Data.List.NonEmpty as NE+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 -- ^ @--package-manager@ or @--custom-pm@+ , cmdLinePretend :: Bool -- ^ @--pretend@+ , cmdLineNoDeep :: Bool -- ^ @--no-deep@+ , cmdLineVersion :: Bool -- ^ @--version@+ , cmdLineAction :: WithCmd -- ^ @--action@+ , cmdLineTargets :: Maybe (NE.NonEmpty (Either CustomTarget BuildTarget)) -- ^ @--target@+ , cmdLineMode :: RunMode -- ^ @--mode@+ , cmdLineVerbosity :: Verbosity -- ^ @--verbose@ or @--quiet@+ , cmdLineHelp :: Bool -- ^ @--help@++ -- This would be better off as another BuildTarget option, but then we+ -- would lose the cool CmdlineOpt automagic+ , cmdLineWorldFull :: Bool -- ^ @--world-full@+ } deriving (Show, Eq, Ord)++defCmdLineArgs :: PkgManager -> CmdLineArgs+defCmdLineArgs defPM = CmdLineArgs+ { cmdLinePkgManager = defPM+ , cmdLinePretend = False+ , cmdLineNoDeep = False+ , cmdLineVersion = False+ , cmdLineAction = PrintAndRun+ , cmdLineTargets = Nothing+ , cmdLineMode = BasicMode+ , cmdLineVerbosity = Normal+ , cmdLineHelp = False+ , cmdLineWorldFull = False+ }++data BuildTarget+ = OnlyInvalid -- ^ Default+ | AllInstalled -- ^ Rebuild every Haskell package+ | WorldTarget -- ^ Target @@world@ portage set+ | PreservedRebuild -- ^ Append @@preserved-rebuild@ set+ deriving (Eq, Ord, Show, Read, Enum, Bounded)++type CustomTarget = String++data RunMode+ = BasicMode -- ^ @--mode=basic@+ | ListMode -- ^ @--mode=list@+ | ReinstallAtomsMode -- ^ @--mode=reinstall-atoms@ (portage only)+ 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)"+ )+ argInfo PreservedRebuild =+ ( "preserved-rebuild"+ , Just $ "Append @preserved-rebuild set (only valid with\n"+ ++ "portage package manager and basic mode)"+ )++ optName _ = "target"+ optDescription _ =+ "Choose the type of packages for the PM to target.\n\+ \May be given multiple times in reinstall-atoms mode."+ 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]
+ src/Distribution/Gentoo/Env.hs view
@@ -0,0 +1,103 @@+{- |+ Module : Distribution.Gentoo.Env+ Description : Global environment for haskell-updater++ This module contains a representation of the global environment for+ @haskell-updater@, which is parsed from the command line.+ -}++{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Distribution.Gentoo.Env+ ( EnvT(runEnvT)+ , HasRunModifier(..)+ , HasPkgManager(..)+ , askLoopType+ , askExtraRawArgs+ , HasRawPMArgs(..)+ ) where++import Control.Monad.Reader+import Control.Monad.State.Strict+import Data.Proxy+import System.IO (hPutStrLn, stderr)++import Distribution.Gentoo.Types+import Distribution.Gentoo.Types.Mode+import Output++-- | Basic environment data to be available during run time. This only makes+-- sense for normal operation (v'RunMode' vs. 'HelpMode'/'VersionMode'+-- constructors of 'HUMode').+type Env = (RunModifier, PkgManager, RawPMArgs)++-- | Make the global 'Env' available via 'MonadReader'. See also the+-- specialized methods for accessing this data:+--+-- * 'askRunModifier'+-- * 'askPkgManager'+-- * 'askLoopType'+-- * 'askExtraRawArgs'+-- * 'askRawPMArgs'+newtype EnvT m a = EnvT+ { runEnvT :: Env -> m a }+ deriving stock Functor+ deriving (Applicative, Monad, MonadIO, MonadReader Env) via ReaderT Env m+ deriving MonadTrans via ReaderT Env++instance MonadIO m => MonadSay (EnvT m) where+ outputLn = liftIO . hPutStrLn stderr+ askVerbosity = asks $ \(rm, _, _) -> verbosity rm++instance MonadExit m => MonadExit (EnvT m) where+ type ExitArg (EnvT m) = ExitArg m+ success = lift . success+ die = lift . die+ exitWith = lift . exitWith+ isSuccess (_ :: Proxy (EnvT m)) = isSuccess (Proxy :: Proxy m)++class Monad m => HasRunModifier m where+ askRunModifier :: m RunModifier++instance Monad m => HasRunModifier (EnvT m) where+ askRunModifier = asks $ \(rm, _, _) -> rm++instance HasRunModifier m => HasRunModifier (StateT s m) where+ askRunModifier = lift askRunModifier++instance HasRunModifier m => HasRunModifier (ReaderT r m) where+ askRunModifier = lift askRunModifier++class Monad m => HasPkgManager m where+ askPkgManager :: m PkgManager++instance Monad m => HasPkgManager (EnvT m) where+ askPkgManager = asks $ \(_, pm, _) -> pm++instance HasPkgManager m => HasPkgManager (StateT s m) where+ askPkgManager = lift askPkgManager++instance HasPkgManager m => HasPkgManager (ReaderT r m) where+ askPkgManager = lift askPkgManager++askLoopType :: (HasRunModifier m, HasPkgManager m) => m LoopType+askLoopType = getLoopType <$> askRunModifier <*> askPkgManager++askExtraRawArgs :: HasPkgManager m => m ExtraRawArgs+askExtraRawArgs = getExtraRawArgs <$> askPkgManager++class Monad m => HasRawPMArgs m where+ askRawPMArgs :: m RawPMArgs++instance Monad m => HasRawPMArgs (EnvT m) where+ askRawPMArgs = asks $ \(_, _, rawArgs) -> rawArgs++instance HasRawPMArgs m => HasRawPMArgs (StateT s m) where+ askRawPMArgs = lift askRawPMArgs++instance HasRawPMArgs m => HasRawPMArgs (ReaderT r m) where+ askRawPMArgs = lift askRawPMArgs
+ src/Distribution/Gentoo/GHC.hs view
@@ -0,0 +1,457 @@+{- |+ Module : Distribution.Gentoo.GHC+ Description : Find GHC-related breakages on Gentoo.+ Copyright : (c) Ivan Lazar Miljenovic 2009+ License : GPL-2 or later++ This module defines helper functions to find broken packages in+ GHC, or else find packages installed with older versions of GHC.+ -}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}++module Distribution.Gentoo.GHC+ ( -- * Misc+ CabalPV(..)+ , ghcVersion+ , ghcLoc+ , ghcLibDir+ -- * MonadPkgState+ , MonadPkgState(..)+ ) where++import Distribution.Gentoo.Env+import Distribution.Gentoo.Util+import Distribution.Gentoo.Packages++-- Cabal imports+import qualified Distribution.Simple.Utils as DSU+import Distribution.Verbosity(silent)+import Distribution.Package(mungedId)+import Distribution.InstalledPackageInfo+ (InstalledPackageInfo(sourceLibName), parseInstalledPackageInfo)+import Distribution.Text(display)+import Distribution.Types.LibraryName (LibraryName(..))++-- Other imports+import Control.Monad.Reader (ReaderT)+import Control.Monad.State.Strict (StateT, lift)+import Data.Char(isDigit)+import Data.Either(partitionEithers)+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)+import System.Directory( canonicalizePath+ , doesDirectoryExist+ , findExecutable+ , listDirectory )+import Control.Monad+import Control.Monad.IO.Class++import Output++-- -----------------------------------------------------------------------------++-- Common helper utils, etc.++-- | Get only the first line of output+rawSysStdOutLine :: FilePath -> [String] -> IO String+rawSysStdOutLine app args = do+ out <- rawCommand app args+ case lines out of+ [] -> error $ unwords+ [ "rawSysStdOutLine: Empty output from rawCommand"+ , show app, show args ]+ (s:_) -> pure s++rawCommand :: FilePath -> [String] -> IO String+rawCommand cmd args = do (out,_,_) <- DSU.rawSystemStdInOut+ silent -- verbosity+ cmd -- program loc+ args -- args+#if MIN_VERSION_Cabal(1,18,0)+ Nothing -- cabal-1.18+: new working dir+ Nothing -- cabal-1.18+: new environment+#endif /* MIN_VERSION_Cabal(1,18,0) */+ Nothing -- input text and binary mode+#if MIN_VERSION_Cabal(2,1,0)+ DSU.IODataModeBinary+#else+ False -- is output in binary mode+#endif /* MIN_VERSION_Cabal(2,1,0) */+#if MIN_VERSION_Cabal(3,2,0)+ return (BL8.unpack out)+#elif MIN_VERSION_Cabal(2,1,0)+ case out of+ ~(DSU.IODataBinary bs) -> return (BL8.unpack bs)+#else+ return out+#endif /* MIN_VERSION_Cabal(2,1,0) */++-- | Get the first line of output from calling GHC with the given+-- arguments.+ghcRawOut :: [String] -> IO String+ghcRawOut args = ghcLoc >>= flip rawSysStdOutLine args++-- | Cheat with using fromJust since we know that GHC must be in $PATH+-- somewhere, probably /usr/bin.+ghcLoc :: IO FilePath+ghcLoc = fromJust <$> findExecutable "ghc"++-- | The version of GHC installed.+ghcVersion :: IO String+ghcVersion = dropWhile (not . isDigit) <$> ghcRawOut ["--version"]++-- | The directory where GHC has all its libraries, etc.+ghcLibDir :: IO FilePath+ghcLibDir = canonicalizePath =<< ghcRawOut ["--print-libdir"]++ghcPkgRawOut :: [String] -> IO String+ghcPkgRawOut args = ghcPkgLoc >>= flip rawCommand args++-- | Cheat with using fromJust since we know that ghc-pkg must be in $PATH+-- somewhere, probably /usr/bin.+ghcPkgLoc :: IO FilePath+ghcPkgLoc = fromJust <$> findExecutable "ghc-pkg"++ghcConfsPath, gentooConfsPath :: FilePath+ghcConfsPath = "package.conf.d"+gentooConfsPath = "gentoo"++-- | Return the Gentoo .conf files found in this GHC libdir+listConfFiles :: FilePath -> IO [FilePath]+listConfFiles subdir = do+ dir <- ghcLibDir+ let gDir = dir </> subdir+ exists <- doesDirectoryExist gDir+ if exists+ then do conts <- listDirectory gDir+ return $ map (gDir </>)+ $ filter isConf conts+ else return []+ where+ isConf file = takeExtension file == ".conf"++-- | String representation of a package and version from Cabal+newtype CabalPV = CPV { unCPV :: String } -- serialized 'PackageIdentifier'+ deriving (Ord, Eq, Show)++-- | Unique (normal) or multiple (broken) mapping+type ConfMap = Map.Map CabalPV [FilePath]++-- | Fold Gentoo .conf files from the current GHC version and+-- create a Map+foldConf :: (MonadSay m, MonadIO m) => [FilePath] -> m ConfMap+foldConf = foldM addConf Map.empty++-- | cabal package text format+-- @"[InstalledPackageInfo {installedPackageId = Insta..."@+parse_as_cabal_package :: BS.ByteString -> Maybe InstalledPackageInfo+parse_as_cabal_package cont =+ case parseInstalledPackageInfo cont of+ Left _es -> Nothing+ Right (_ws, ipi) -> Just ipi++-- | ghc package text format+-- @+-- "name: zlib-conduit\n+-- version: 1.1.0\n+-- id: zlib-condui..."+-- @+parse_as_ghc_package :: BS.ByteString -> Maybe CabalPV+parse_as_ghc_package cont =+ case (map BS.words . BS.lines) cont of+ ( [name_key, bn] : [ver_key, bv] : _)+ | name_key == BS.pack "name:" && ver_key == BS.pack "version:"+ -> Just $ CPV $ BS.unpack bn ++ "-" ++ BS.unpack bv+ _ -> Nothing++-- | Add this .conf file to the Map+--+-- NOTE: It is important that the 'CabalPV's that are added to the 'ConfMap'+-- should be in their "munged form", which may be z-encoded+--+-- See:+-- * <https://hackage.haskell.org/package/Cabal-syntax-3.12.0.0/docs/Distribution-Types-MungedPackageName.html>+-- * <https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/symbol-names>+addConf :: (MonadSay m, MonadIO m) => ConfMap -> FilePath -> m ConfMap+addConf cmp conf = do+ bs <- liftIO $ BS.readFile conf+ case+ ( BS.null bs+ , parse_as_ghc_package bs+ , parse_as_cabal_package bs+ ) of+ -- empty files are created for+ -- phony packages like CABAL_CORE_LIB_GHC_PV+ -- and binary-only packages.+ (True, _ , _ ) -> pure cmp+ -- 'parse_as_ghc_package' is more efficient, so try it first+ (_ , Just dn, _ ) -> do+ vsay $ unwords [conf, "resolved as ghc package:", show dn]+ pure $ pushConf cmp dn conf+ -- 'parse_as_cabal_package' is more flexible, so use it as a fallback+ (_ , _ , Just ipi) -> do+ let cpv = toCPV ipi+ vsay $ unwords [conf, "resolved as cabal package:", show (cpv, ipi)]+ pure $ pushConf cmp cpv conf+ _ -> do+ say $ unwords+ [ "failed to parse", show conf, ":", show (BS.take 30 bs)]+ return cmp+ where+ pushConf :: ConfMap -> CabalPV -> FilePath -> ConfMap+ pushConf m k fp = Map.insertWith (++) k [fp] m++ -- 'MungedPackageId's get displayed using the z-encoded format, so are+ -- compatible with ghc-pkg. This is important for resolving broken packages+ -- (reported by ghc-pkg) to @.conf@ files!+ toCPV :: InstalledPackageInfo -> CabalPV+ toCPV = CPV . display . mungedId++checkPkgs :: (MonadSay m, MonadIO m)+ => ([CabalPV], [FilePath])+ -> m ([Package],[CabalPV],[FilePath])+checkPkgs (pns, gentoo_cnfs) = do+ files_to_pkgs <- liftIO $ resolveFiles gentoo_cnfs+ let (gentoo_files, pkgs) = unzip $ Set.toList files_to_pkgs+ orphan_gentoo_files = gentoo_cnfs L.\\ gentoo_files+ vsay $ unwords [ "checkPkgs: searching for gentoo .conf orphans"+ , show (length orphan_gentoo_files)+ , "of"+ , show (length gentoo_cnfs)+ ]+ return (pkgs, pns, orphan_gentoo_files)++-- -----------------------------------------------------------------------------++-- | Monads that can retrieve the state of Haskell packages on the+-- system (or other database).+--+-- This is primarily used with the 'Env' monad. Making this a class helps+-- with the creation of test mockups.+class Monad m => MonadPkgState m where+ -- | Finding packages installed with other versions of GHC+ oldGhcPkgs :: m (Set.Set Package)++ -- | Finding broken packages in this install of GHC.+ brokenPkgs :: m ([Package],[CabalPV],[FilePath])++ -- | All registered Haskell packages on the system+ allInstalledPkgs :: m (Set.Set Package)+++instance MonadIO m => MonadPkgState (EnvT m) where+ oldGhcPkgs =+ do thisGhc <- liftIO ghcLibDir+ vsay $ "oldGhcPkgs ghc lib: " ++ show thisGhc+ let thisGhc' = BS.pack thisGhc+ -- It would be nice to do this, but we can't assume+ -- some crazy user hasn't deleted one of these dirs+ -- libFronts' <- filterM doesDirectoryExist libFronts+ notGHC <$> checkLibDirs thisGhc' libFronts++ brokenPkgs = brokenConfs >>= checkPkgs++ allInstalledPkgs = do libDir <- liftIO ghcLibDir+ let libDir' = BS.pack libDir+ fmap notGHC $ liftIO $ pkgsHaveContent+ $ hasDirMatching (==libDir')++instance MonadPkgState m => MonadPkgState (StateT s m) where+ oldGhcPkgs = lift oldGhcPkgs+ brokenPkgs = lift brokenPkgs+ allInstalledPkgs = lift allInstalledPkgs++instance MonadPkgState m => MonadPkgState (ReaderT r m) where+ oldGhcPkgs = lift oldGhcPkgs+ brokenPkgs = lift brokenPkgs+ allInstalledPkgs = lift allInstalledPkgs++-- | Find packages installed by other versions of GHC in this possible+-- library directory.+checkLibDirs :: (MonadSay m, MonadIO m)+ => BSFilePath -> [BSFilePath] -> m (Set.Set Package)+checkLibDirs thisGhc libDirs =+ do vsay $ "checkLibDir ghc libs: " ++ show (thisGhc, libDirs)+ liftIO $ pkgsHaveContent (hasDirMatching wanted)+ where+ wanted dir = isValid dir && (not . isInvalid) dir++ isValid dir = any (`isGhcLibDir` dir) libDirs++#if MIN_VERSION_bytestring(0,11,1)+ -- Correct the path for hadrian-based installations+ -- See https://github.com/gentoo-haskell/haskell-updater/issues/20+ thisGhc' = if BS.isSuffixOf (BS.pack "/lib") thisGhc then BS.dropEnd 4 thisGhc else thisGhc++ -- Invalid if it's this GHC+ isInvalid fp = fp == thisGhc' || BS.isPrefixOf (thisGhc' `BS.snoc` pathSeparator) fp+#else+ -- Versions of GHC with old 'bytestring' can use the old behavior+ isInvalid fp = fp == thisGhc || BS.isPrefixOf (thisGhc `BS.snoc` pathSeparator) fp+#endif++-- | A valid GHC library directory starting at libdir has a name of+-- "ghc", then a hyphen and then a version number.+isGhcLibDir :: BSFilePath -> BSFilePath -> Bool+isGhcLibDir libdir dir = go ghcDirName+ where+ -- This is hacky because FilePath doesn't work on Bytestrings...+ libdir' = BS.snoc libdir pathSeparator+ ghcDirName = BS.pack "ghc"++ go dn = BS.isPrefixOf ghcDir dir+ -- Any possible version starts with a digit+ && isDigit (BS.index dir ghcDirLen)+ where+ ghcDir = flip BS.snoc '-' $ BS.append libdir' dn+ ghcDirLen = BS.length ghcDir+++-- | The possible places GHC could have installed lib directories+libFronts :: [BSFilePath]+libFronts = map BS.pack+ $ do lib <- ["lib", "lib64"]+ return $ "/" </> "usr" </> lib++-- -----------------------------------------------------------------------------++-- | .conf files from broken packages of this GHC version+-- Returns two lists:+-- * @[CabalPV]@ - list of broken cabal packages we could not resolve+-- to Gentoo's .conf files+-- * @[FilePath]@ - list of '.conf' files resolved from broken+-- CabalPV reported by 'ghc-pkg check'+brokenConfs :: (MonadSay m, MonadIO m) => m ([CabalPV], [FilePath])+brokenConfs =+ do vsay "brokenConfs: getting broken output from 'ghc-pkg'"+ ghc_pkg_brokens <- liftIO getBrokenGhcPkg+ vsay $ unwords ["brokenConfs: resolving Cabal package names to gentoo equivalents."+ , show (length ghc_pkg_brokens)+ , "Cabal packages are broken:"+ , unwords $ map unCPV ghc_pkg_brokens+ ]++ (orphan_broken, orphan_confs) <- liftIO getOrphanBroken+ vsay $ unwords [ "brokenConfs: ghc .conf orphans:"+ , show (length orphan_broken)+ , "are orphan:"+ , unwords $ map unCPV orphan_broken+ ]++ installed_but_not_registered <- getNotRegistered+ vsay $ unwords [ "brokenConfs: ghc .conf not registered:"+ , show (length installed_but_not_registered)+ , "are not registered:"+ , unwords $ map unCPV installed_but_not_registered+ ]++ registered_twice <- getRegisteredTwice+ vsay $ unwords [ "brokenConfs: ghc .conf registered twice:"+ , show (length registered_twice)+ , "are registered twice:"+ , unwords $ map unCPV registered_twice+ ]++ let all_broken = concat [ ghc_pkg_brokens+ , orphan_broken+ , installed_but_not_registered+ , registered_twice+ ]++ vsay "brokenConfs: reading '*.conf' files"+ cnfs <- liftIO (listConfFiles gentooConfsPath) >>= foldConf+ vsay $ "brokenConfs: got " ++ show (Map.size cnfs) ++ " '*.conf' files"+ let (known_broken, orphans) = partitionEithers $ map (matchConf cnfs) all_broken+ return (known_broken, orphan_confs ++ L.concat orphans)+ where+ -- Attempt to match the provided broken package to one of the+ -- installed packages.+ matchConf :: ConfMap -> CabalPV -> Either CabalPV [FilePath]+ matchConf cmp cpv =+ case Map.lookup cpv cmp of+ Just fps -> Right fps+ Nothing -> Left cpv++-- | Return the closure of all packages affected by breakage+-- in format of ["name-version", ... ]+getBrokenGhcPkg :: IO [CabalPV]+getBrokenGhcPkg = map CPV . words+ <$> ghcPkgRawOut ["check", "--simple-output"]++getOrphanBroken :: IO ([CabalPV], [FilePath])+getOrphanBroken = do+ -- Around Jan 2015 we have started to install+ -- all the .conf files in 'src_install()' phase.+ -- Here we pick orphan ones and notify user about it.+ registered_confs <- listConfFiles ghcConfsPath+ confs_to_pkgs <- resolveFiles registered_confs+ 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 $+ fmap parse_as_ghc_package . BS.readFile+ return (orphan_packages, orphan_conf_files)++-- | Return packages, that seem to have+-- been installed via emerge (have gentoo/.conf entry),+-- but are not registered in package.conf.d.+-- Usually happens on manual cleaning or+-- due to unregistration bugs in old eclass.+getNotRegistered :: (MonadSay m, MonadIO m) => m [CabalPV]+getNotRegistered = do+ installed_confs <- liftIO (listConfFiles gentooConfsPath) >>= foldConf+ registered_confs <- liftIO (listConfFiles ghcConfsPath) >>= foldConf+ return $ Map.keys installed_confs L.\\ Map.keys registered_confs++-- | Return packages, that seem to have+-- been installed more, than once.+-- It usually happens this way:+-- 1. user installs dev-lang/ghc-7.8.4-r0 (comes with bundled @transformers-3.0.0.0-ghc-7.8.4-{abi}.conf@)+-- 2. user installs dev-haskell/transformers-0.4.3.0 (registered as @transformers-0.4.3.0-{abi}.conf@)+-- 3. user upgrades up to dev-lang/ghc-7.8.4-r4 (comes with bundled @transformers-0.4.3.0-ghc-7.8.4-{abi}.conf@)+-- this way we have single package registered twice:+-- * @transformers-0.4.3.0-ghc-7.8.4-{abi}.conf@+-- * @transformers-0.4.3.0-{abi}.conf@+-- It's is easy to fix just by reinstalling transformers.+getRegisteredTwice :: (MonadSay m, MonadIO m) => m [CabalPV]+getRegisteredTwice = do+ registered_confs <- liftIO (listConfFiles ghcConfsPath) >>= foldConf+ let registered_twice = Map.filter (\fs -> length fs > 1) registered_confs++ -- Double check that all of the "duplicates" are main libraries, since+ -- a package may also have one or more sub-libraries registered as+ -- well.+ rtMainLibs <- foldM+ (\m k -> Map.alterF (liftIO . onlyMultipleMains) k m)+ registered_twice+ (Map.keys registered_twice)++ return $ Map.keys rtMainLibs+ where+ -- Filter out all but entries with multiple main libraries+ onlyMultipleMains :: Maybe [FilePath] -> IO (Maybe [FilePath])+ onlyMultipleMains (Just fps@(_:_)) = do+ fps' <- filterM filterMain fps+ -- Remove entries with one or less elements, since they are no longer+ -- relevant to the getRegisteredTwice function+ pure $ if length fps' <= 1 then Nothing else Just fps'+ onlyMultipleMains _ = pure Nothing++ -- Only keep conf files that correspond to main libraries. This runs+ -- 'parse_as_cabal_package' to get+ filterMain :: FilePath -> IO Bool+ filterMain conf = do+ bs <- BS.readFile conf+ let ipi = parse_as_cabal_package bs+ pure $ case sourceLibName <$> ipi of+ Just LMainLibName -> True+ _ -> False++-- -----------------------------------------------------------------------------
+ src/Distribution/Gentoo/Packages.hs view
@@ -0,0 +1,232 @@+{-# Language TupleSections #-}+{- |+ Module : Distribution.Gentoo.Packages+ Description : Dealing with installed packages on Gentoo.+ Copyright : (c) Ivan Lazar Miljenovic, Lennart Kolmodin 2009+ License : GPL-2 or later++ This module defines helper functions that deal with installed+ packages in Gentoo.+-}+module Distribution.Gentoo.Packages+ ( -- * Basic+ Package(..)+ , notGHC+ , printPkg+ , resolveFiles+ -- * CONTENTS files+ , Content(..)+ -- ** Searching+ , pkgsHaveContent+ -- *** Predicates+ , hasContentMatching+ , hasDirMatching+ ) where++import Data.Char(isDigit, isAlphaNum)+import Data.List(isPrefixOf)+import Data.Maybe+import qualified Data.ByteString.Char8 as BS+import Data.ByteString.Char8(ByteString)+import qualified Data.Set as S+import System.Directory( doesDirectoryExist+ , doesFileExist+ , listDirectory)+import System.FilePath((</>))+import Control.Monad++import Distribution.Gentoo.Util++-- -----------------------------------------------------------------------------++-- Representation of a cat/pkgname in Gentoo. Note that this is+-- overly simplified.++type Category = String+type Pkg = String -- ^ Package name.+type VerPkg = String -- ^ Package name with version.+type VCatPkg = (Category, VerPkg)+type Slot = String++-- | When we are (re-)building packages, we don't care about the+-- version, just the slot.+data Package = Package Category Pkg (Maybe Slot)+ deriving(Eq, Ord, Show, Read)++-- | Package equality, ignoring the Slot (i.e. same category and package+-- name).+samePackageAs :: Package -> Package -> Bool+samePackageAs (Package c1 p1 _) (Package c2 p2 _)+ = c1 == c2 && p1 == p2++ghcPkg :: Package+ghcPkg = Package "dev-lang" "ghc" Nothing++-- | Return all packages that are not a version of GHC.+notGHC :: S.Set Package -> S.Set Package+notGHC = S.filter (isNot ghcPkg)+ where+ isNot p1 = not . samePackageAs p1++-- | Pretty-print the Package name based on how PMs expect it+printPkg :: Package -> String+printPkg (Package c p s) = addS cp+ where+ addS = maybe id (flip (++) . (:) ':') s+ cp = c ++ '/' : p++-- | Determine which slot the specific version of the package is in and+-- create the appropriate Package value.+toPackage :: VCatPkg -> IO Package+toPackage cp@(c,vp) = do sl <- getSlot cp+ let p = stripVersion vp+ return $ Package c p sl++-- | Determine which slot the specific version of the package is in.+getSlot :: VCatPkg -> IO (Maybe Slot)+getSlot cp = do ex <- doesFileExist sFile+ if ex+ then parse+ else return Nothing+ where+ sFile = pkgPath cp </> "SLOT"+ -- EAPI=5 defines subslots+ split_slot_subslot = break (== '/')+ parse = do fl <- BS.unpack <$> BS.readFile sFile+ -- Don't want the trailing newline+ return $ listToMaybe $ map (fst . split_slot_subslot) $ lines fl++-- | Remove the version information from the package name.+stripVersion :: VerPkg -> Pkg+stripVersion = concat . takeUntilVer . breakAll partSep+ where+ partSep x = x `elem` ['-', '_']++ -- Only the last bit that matches isVer is the real version bit.+ -- Note that this doesn't check that the last non-version bit is+ -- not a hyphen followed by digits.+ takeUntilVer = concat . init . breakAll isVer++ isVer as = isVerFront (init as) && isAlphaNum (last as)+ isVerFront ('-':as) = all (\a -> isDigit a || a == '.') as+ isVerFront _ = False++pkgPath :: VCatPkg -> FilePath+pkgPath (c, vp) = pkgDBDir </> c </> vp++pkgDBDir :: FilePath+pkgDBDir = "/var/db/pkg"++-- -----------------------------------------------------------------------------++-- Parsing the CONTENTS file of installed packages.++-- | Representation of individual lines in a CONTENTS file.+data Content = Dir BSFilePath+ | Obj BSFilePath+ deriving (Eq, Show, Ord)++isDir :: Content -> Bool+isDir (Dir _) = True+isDir _ = False++pathOf :: Content -> BSFilePath+pathOf (Dir dir) = dir+pathOf (Obj obj) = obj++-- Searching predicates.++-- | Search a CONTENTS file for paths that match the given predicate.+hasContentMatching :: (BSFilePath -> Bool) -> [Content] -> Bool+hasContentMatching p = any (p . pathOf)++-- | Search a CONTENTS file for directory paths that match the given predicate.+hasDirMatching :: (BSFilePath -> Bool) -> [Content] -> Bool+hasDirMatching p = hasContentMatching p . filter isDir++-- | Parse the CONTENTS file.+parseContents :: VCatPkg -> IO [Content]+parseContents cp = do ex <- doesFileExist cFile+ if ex+ then parse+ else return []+ where+ cFile = pkgPath cp </> "CONTENTS"++ parse = do lns <- BS.lines <$> BS.readFile cFile+ return $ mapMaybe (parseCLine . BS.words) lns++ -- Use unwords of list rather than taking next element because of+ -- how spaces are represented in file names.+ -- This might cause a problem if there is more than a single+ -- space (or a tab) in the filename...+ -- Also require at least 3 words in case of an object, as the CONTENTS+ -- file can be corrupt (fixes actual problem reported by user).+ parseCLine :: [ByteString] -> Maybe Content+ parseCLine (tp:ln)+ | tp == dir = Just . Dir . BS.unwords $ ln+ | tp == obj && length ln >= 3 = Just . Obj . BS.unwords $ dropLastTwo ln+ | otherwise = Nothing+ parseCLine [] = Nothing++ dropLastTwo :: [a] -> [a]+ dropLastTwo = init . init++ obj = BS.pack "obj"+ dir = BS.pack "dir"++-- -----------------------------------------------------------------------------++-- | Find all the packages that contain given files.+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)+ | (pn, conts) <- pfs+ , Obj fn <- conts+ ]+ grep pn cont = Just (pn, filter (\e -> S.member e fps') cont)++-- | Run predecate 'p' for each installed package+-- and gather all 'Just' values+forPkg :: Ord a => (Package -> [Content] -> Maybe a) -> IO [a]+forPkg p = do+ categories <- installedCats+ catMaybes <$> do+ flip concatMapM categories $ \cat -> do+ maybe_pkgs <- listDirectory (pkgDBDir </> cat)+ packages <- filterM (isPackage . (cat,)) maybe_pkgs+ forM packages $ \pkg -> do+ let cp = (cat, pkg)+ cpn <- toPackage cp+ cont <- parseContents cp+ return $ p cpn cont+ where+ isPackage :: VCatPkg -> IO Bool+ isPackage vcp@(_, vp) = do+ c1 <- doesDirectoryExist $ pkgPath vcp+ let c2 = not $ "-MERGING-" `isPrefixOf` vp+ return $ c1 && c2++-- | Find which packages have Content information that matches the+-- provided predicate; to be used with the searching predicates.+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++-- | Determine if this is a valid Category (such that at least one+-- package in that category has been installed).+isCat :: String -> IO Bool+isCat fp = do isD <- doesDirectoryExist (pkgDBDir </> fp)+ return $ isD && isCat' fp+ where+ isCat' ('.':_) = False+ isCat' "world" = False+ isCat' _ = True++-- | Return all Categories known in this system.+installedCats :: IO [Category]+installedCats = filterM isCat =<< listDirectory pkgDBDir
+ src/Distribution/Gentoo/PkgManager.hs view
@@ -0,0 +1,328 @@+{- |+ Module : Distribution.Gentoo.PkgManager+ Description : Using package managers in Gentoo.+ Copyright : (c) Ivan Lazar Miljenovic, Emil Karlson 2010+ License : GPL-2 or later++ This module defines ways to use different Gentoo package managers. Much of+ the module is historical in nature.+ -}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Distribution.Gentoo.PkgManager+ ( -- * Basic functions+ definedPMs+ , choosePM+ , stringToCustomPM+ , isValidPM+ , defaultPM+ , defaultPMName+ , nameOfPM+ , toPkgManager+ -- * BuildPkgs+ , BuildPkgs(..)+ , buildPkgsTargets+ , buildPkgsPending+ -- * MonadWritePkgState+ , MonadWritePkgState(..)+ ) where++import Distribution.Gentoo.Env+import Distribution.Gentoo.Packages+import Distribution.Gentoo.PkgManager.Types+import Distribution.Gentoo.Types+import qualified Distribution.Gentoo.Types.Mode as Mode++import Control.Monad.Reader+import Control.Monad.State.Strict+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)+import System.Exit (ExitCode (..), exitSuccess)+import System.Process (rawSystem)++-- -----------------------------------------------------------------------------++-- | The default package manager. If the environment variable+-- @PACKAGE_MANAGER@ exists, use that; otherwise default to+-- "portage". Note that even if that environment variable is+-- defined, if it is unknown then it won't be used.+defaultPM :: IO PkgManager+defaultPM = do eDPM <- lookup "PACKAGE_MANAGER" `fmap` getEnvironment+ let dPM = fromMaybe defaultPMName eDPM+ mPM = dPM `M.lookup` pmNameMap+ return $ fromMaybe knownDef mPM+ where+ knownDef = pmNameMap M.! defaultPMName++-- | The default package manager (currently @"portage"@)+defaultPMName :: String+defaultPMName = "portage"++-- | The names of known package managers.+definedPMs :: [String]+definedPMs = M.keys pmNameMap++-- | Returns @Left pmname@ if the input is 'InvalidPM', or @Right pm@ otherwise+isValidPM :: PkgManager -> Either String PkgManager+isValidPM (InvalidPM pmname) = Left pmname+isValidPM pm = Right pm++-- | Map from string representations of package managers to their 'PkgManager'+-- representation, e.g. @"portage"@ to @v'Portage'@.+pmNameMap :: Map String PkgManager+pmNameMap = M.fromList [ ("portage", Portage)+ , ("pkgcore", PkgCore)+ , ("paludis", Paludis)+ ]++-- | Inverted version of 'pmNameMap'+pmNameMap' :: Map PkgManager String+pmNameMap' = M.fromList . map (\(nm,pm) -> (pm,nm)) $ M.toList pmNameMap++-- | Human-readable name or description of a package manager+nameOfPM :: PkgManager -> String+nameOfPM (CustomPM pmname) = "custom package manager command: " ++ pmname+nameOfPM (InvalidPM pmname) = "invalid package manager: " ++ pmname+nameOfPM pm = pmNameMap' M.! pm++-- | Choose the appropriate PM from the textual representation; throws+-- an error if that PM isn't known.+choosePM :: String -> PkgManager+choosePM pm = fromMaybe (InvalidPM pm) $ pm' `M.lookup` pmNameMap+ where+ pm' = map toLower pm++-- | Create a v'CustomPM' from a 'String'+stringToCustomPM :: String -> PkgManager+stringToCustomPM = CustomPM++-- | Command-line compatible name for a 'PkgManager'+pmCommand :: PkgManager -> String+pmCommand Portage = "emerge"+pmCommand PkgCore = "pmerge"+pmCommand Paludis = "cave"+pmCommand (CustomPM cmd) = cmd+pmCommand (InvalidPM _) = undefined++-- | Default command line flags for the given package manager+defaultPMFlags :: PkgManager -> [String]+defaultPMFlags Portage = [ "--oneshot"+ , "--keep-going"+ , "--complete-graph"+ ]+defaultPMFlags PkgCore = [ "--deep"+ , "--oneshot"+ , "--ignore-failures"+ ]+defaultPMFlags Paludis = [ "resolve"+ , "--execute"+ , "--preserve-world"+ , "--continue-on-failure", "if-independent"+ ]+defaultPMFlags CustomPM{} = []+defaultPMFlags (InvalidPM _) = undefined++-- | Convert from a "Distributions.Gentoo.Types.Mode" 'Mode.PkgManager' to a+-- 'PkgManager' as defined in "Distribution.Gentoo.PkgManager.Types".+toPkgManager :: Mode.PkgManager -> PkgManager+toPkgManager (Mode.Portage _) = Portage+toPkgManager (Mode.PkgCore _) = PkgCore+toPkgManager (Mode.Paludis _) = Paludis+toPkgManager (Mode.CustomPM s _) = CustomPM s++-- | A data type containing the information needed to pass to the package+-- manager, such as targets. The constructor determines which function+-- 'buildPkgs' will run.+data BuildPkgs+ -- | Default mode+ = BuildNormal+ -- | the package manager that will be used+ Mode.PkgManager+ -- | Packages that will be rebuilt, passed to the PM as targets+ PendingPackages+ -- | Extra targets+ (Set.Set Target)+ -- | @--mode=reinstall-atoms@+ | BuildRAMode+ -- | Packages that will be marked for rebuild via --reinstall-atoms+ PendingPackages+ -- | atoms/sets that the PM will be targeting+ (Set.Set Target)+ -- | All installed Haskell packages (for use with @--usepkg-exclude@)+ AllPkgs++-- | The set of targets that will be passed to the package manager. This mostly+-- matters for 'BuildNormal', since there are two sets that must be merged+-- for the final target set.+buildPkgsTargets :: BuildPkgs -> Set.Set Target+buildPkgsTargets = \case+ BuildNormal _ pps extraTargs ->+ let pts = Set.singleton $ case pps of+ InvalidPending ps -> TargetInvalid ps+ AllPending as -> TargetAll as+ in pts <> extraTargs+ BuildRAMode _ targs _ -> targs++-- | Get the 'PendingPackages' from a 'BuildPkgs' constructor.+--+-- This is examined by the different looping strategies in order to monitor+-- progress and make choices about when to continue looping.+buildPkgsPending :: BuildPkgs -> PendingPackages+buildPkgsPending = \case+ BuildNormal _ pps _ -> pps+ BuildRAMode pps _ _ -> pps++-- | Write to the global package state. This is generally used with its+-- 'IO' instance (using 'buildCmd'/'buildRACmd' to modify the global state),+-- but it is left open as a class for testing purposes.+class MonadExit m => MonadWritePkgState m where+ buildPkgs+ :: BuildPkgs+ -> m (ExitArg m)++instance (ExitArg m ~ ExitCode, MonadExit m, MonadIO m)+ => MonadWritePkgState (EnvT m) where+ buildPkgs bp = do+ rm <- askRunModifier+ rawArgs <- Mode.getExtraRawArgs <$> askPkgManager++ let (cmd, args) = case bp of+ BuildNormal pkgMgr _ _ ->+ let targs = buildPkgsTargets bp+ in buildCmd pkgMgr (flags rm) rawArgs (rawPMArgs rm) targs+ BuildRAMode pps targs allPkgs ->+ buildRACmd (flags rm) rawArgs (rawPMArgs rm) pps targs allPkgs++ liftIO $ putStrLn ""+ liftIO $ runCmd (withCmd rm) cmd args++instance MonadWritePkgState m => MonadWritePkgState (StateT s m) where+ buildPkgs = lift . buildPkgs++instance MonadWritePkgState m => MonadWritePkgState (ReaderT r m) where+ buildPkgs = lift . buildPkgs++-- | Depending on the 'WithCmd' passed, print or execute (or both) a given+-- command. @stdout@ and @stderr@ are discarded.+runCmd :: WithCmd -> String -> [String] -> IO ExitCode+runCmd m cmd args = case m of+ RunOnly -> rawSystem cmd args+ PrintOnly -> putStrLn cmd_line >> exitSuccess+ PrintAndRun -> putStrLn cmd_line >> rawSystem cmd args+ where+ cmd_line = unwords (cmd : (showArg <$> args))+ showArg s+ | words s == [s] = s+ | otherwise = show s -- Put quotes around args with spaces in them++-- | Create a command for invoking the given 'Mode.PkgManager'.+buildCmd+ :: Mode.PkgManager+ -> [PMFlag] -- ^ Basic flags+ -> ExtraRawArgs -- ^ hard-coded extra flags+ -> RawPMArgs -- ^ User-supplied flags+ -> Set.Set Target -- ^ Packages to be rebuilt, and extra targets+ -> (String, [String])+buildCmd mpm fs (ExtraRawArgs rawArgs) userArgs targs =+ ( pmCommand pm+ , defaultPMFlags pm+ ++ mapMaybe (flagRep pm) fs+ ++ rawArgs+ ++ userArgs+ ++ printTargets targs+ )+ where+ pm = toPkgManager mpm++-- | Alternative version of 'buildCmd' which uses experimental @emerge@+-- invocation (using @--reinstall-atoms@). This is only to be used with the+-- 'Portage' package manager.+--+-- The rationale is that by marking broken packages by using+-- @--reinstall-atoms@, portage will pretend that they are not yet+-- installed, thus forcing their reinstallation. @--update@ is+-- used and all installed Haskell packages are targeted so that the entire+-- Haskell environment is examined. This has a side-effect of skipping+-- packages that are masked or otherwise unavailable while still rebuilding+-- needed dependencies that have been broken.+buildRACmd+ :: [PMFlag] -- ^ Basic flags+ -> ExtraRawArgs -- ^ hard-coded extra flags+ -> RawPMArgs -- ^ User-supplied flags+ -> PendingPackages -- ^ Packages to be rebuilt+ -> Set.Set Target -- ^ emerge targets+ -> AllPkgs -- ^ for use with 'usepkgExclude'+ -> (String, [String])+buildRACmd fs (ExtraRawArgs rawArgs) userArgs pending targets allPs =+ ( pmCommand Portage+ , defaultPMFlags Portage+ ++ mapMaybe (flagRep Portage) fs+ ++ ["--update"]+ ++ rawArgs+ ++ userArgs+ ++ usepkgExclude allPs+ ++ reinst+ ++ printTargets targets+ )+ where+ reinst =+ let raArgs ps+ | Set.null ps = []+ | otherwise = ["--reinstall-atoms", unwords (printPkg <$> Set.toList ps)]+ in raArgs (getPkgs pending)++-- | Print a set of targets, suitable for passing to a package manager+printTargets :: Set.Set Target -> [String]+printTargets targets = Set.toList $ foldr go Set.empty targets+ where+ go targ set = case targ of+ TargetInvalid (InvalidPkgs p) -> foldr (Set.insert . printPkg) set p+ TargetAll (AllPkgs p) -> foldr (Set.insert . printPkg) set p+ CustomTarget t -> Set.insert t set++-- | 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++-- -----------------------------------------------------------------------------++flagRep :: PkgManager -> PMFlag -> Maybe String+flagRep Portage = portagePMFlag+flagRep PkgCore = pkgcorePMFlag+flagRep Paludis = cavePMFlag+flagRep CustomPM{} = const Nothing -- Can't tell how flags would work.+flagRep (InvalidPM _) = undefined++portagePMFlag :: PMFlag -> Maybe String+portagePMFlag PretendBuild = Just "--pretend"+portagePMFlag UpdateDeep = Just "--deep"+portagePMFlag UpdateAsNeeded = Nothing++pkgcorePMFlag :: PMFlag -> Maybe String+pkgcorePMFlag = portagePMFlag -- The options are the same for the 3+ -- current flags.++cavePMFlag :: PMFlag -> Maybe String+cavePMFlag PretendBuild = Just "--no-execute"+cavePMFlag UpdateDeep = Just "--complete"+cavePMFlag UpdateAsNeeded = Just "--lazy"
+ src/Distribution/Gentoo/PkgManager/Types.hs view
@@ -0,0 +1,28 @@+{- |+ Module : Distribution.Gentoo.PkgManager.Types++ Types relating to package managers supported by haskell-updater. Much of+ the module is historical in nature (including the 'PkgManager' type which+ shares the same name as 'Mode.PkgManager' from "Distribution.Gentoo.Types.Mode").+ -}++module Distribution.Gentoo.PkgManager.Types+ ( PkgManager(..)+ , PMFlag(..)+ ) where++-- | Defines the available Gentoo package managers.+data PkgManager = Portage+ | PkgCore+ | Paludis+ | InvalidPM String+ | CustomPM String+ deriving (Eq, Ord, Show, Read)++-- | Different optional flags to be passed to the PM. This is intended to be+-- a unified interface for command line options that have different names in+-- different package managers.+data PMFlag = PretendBuild -- ^ @--pretend@ for portage, @--no-execute@ for paludis+ | UpdateDeep -- ^ @--deep@ for portage, @--complete@ for paludis+ | UpdateAsNeeded -- ^ Default for portage, @--lazy@ for paludis+ deriving (Eq, Ord, Show, Read)
+ src/Distribution/Gentoo/Types.hs view
@@ -0,0 +1,231 @@+{- |+ Module : Distribution.Gentoo.Types++ General types needed for haskell-updater functionality+ -}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Distribution.Gentoo.Types+ ( RunModifier(..)+ , RawPMArgs+ , WithCmd(..)+ , PendingPackages(..)+ , Target(..)+ , RunHistory(..)+ , isInHistory+ , HistoryState(..)+ , historyState+ , isEmptyHistory+ , latestPending+ , LoopType(..)+ , ExtraRawArgs(..)+ , InvalidPkgs(..)+ , AllPkgs(..)+ , PackageSet(..)+ , MonadExit(..)+ ) where++import Control.Monad.Reader+import Control.Monad.State.Strict+import Data.Proxy+import qualified Data.Set as Set+import qualified Data.Sequence as Seq+import Data.Sequence (ViewR(EmptyR, (:>)), viewr)+import System.Exit (ExitCode(..), exitSuccess)+import qualified System.Exit as Exit+import System.IO (hPutStrLn, stderr)++import Distribution.Gentoo.Packages+import Distribution.Gentoo.PkgManager.Types+import Output++-- | Run-mode haskell-updater state+data RunModifier = RM { flags :: [PMFlag]+ , withCmd :: WithCmd+ , rawPMArgs :: RawPMArgs+ , verbosity :: Verbosity+ }+ deriving (Eq, Ord, Show)++-- | Arguments to be passed when calling the package manager+type RawPMArgs = [String]++-- | How to handle the command for calling the package manager.+data WithCmd = PrintAndRun -- ^ Print the command /and/ run it (default)+ | PrintOnly -- ^ Only print the command+ | RunOnly -- ^ Only run the command+ deriving (Eq, Ord, Show, Read, Enum, Bounded)++-- | The set of packages that are currently broken and need to be rebuilt,+-- as reported by @ghc-pkg check@. These may or may not equate to the+-- 'Target', depending on which mode @haskell-updater@ is running in.+data PendingPackages+ = InvalidPending InvalidPkgs -- ^ invalid (broken) installed Haskell packages+ | AllPending AllPkgs -- ^ all installed Haskell packages+ deriving (Show, Eq, Ord)++-- | The "targets" passed to the package manager, for instance package atoms+-- or set strings.+data Target+ = TargetInvalid InvalidPkgs -- ^ @--target=invalid@+ | TargetAll AllPkgs -- ^ @--target=all@+ | CustomTarget String -- ^ @--custom-target=...@+ deriving (Show, Eq, Ord)++-- | The history of every rebuild run that has been attempted, including the+-- state of pending packages /before/ any runs have been attempted.+data RunHistory m = RunHistory+ { initialState :: PendingPackages+ , runHistory :: Seq.Seq (PendingPackages, ExitArg m)+ }++deriving instance Show (ExitArg m) => Show (RunHistory m)+deriving instance Eq (ExitArg m) => Eq (RunHistory m)+deriving instance Ord (ExitArg m) => Ord (RunHistory m)++-- | Is the package set in the history somewhere?+isInHistory :: PackageSet s => RunHistory m -> s -> Bool+isInHistory (RunHistory pending0 runSeq) ps+ = getPkgs pending0 == pkgSet || pkgSet `elem` (getPkgs . fst <$> runSeq)+ where pkgSet = getPkgs ps++-- | The current state of the history, processed in a way that is useful+-- for looping algorithms.+data HistoryState m+ -- | Carries the initial pending packages state+ = NoRunsTried PendingPackages+ -- | Carries the initial pending packages state and the first history+ -- entry+ | OneRunTried PendingPackages (PendingPackages, ExitArg m)+ -- | Carries the last two history entries (oldest first)+ | MultipleRunsTried (PendingPackages, ExitArg m) (PendingPackages, ExitArg m)++deriving instance Show (ExitArg m) => Show (HistoryState m)+deriving instance Eq (ExitArg m) => Eq (HistoryState m)+deriving instance Ord (ExitArg m) => Ord (HistoryState m)++-- | Returns 'Nothing' if the first update run hasn't been carried out+historyState :: RunHistory m -> HistoryState m+historyState (RunHistory initialPending runSeq) = case viewr runSeq of+ EmptyR -> NoRunsTried initialPending+ (hs :> lastH) -> case viewr hs of+ EmptyR -> OneRunTried initialPending lastH+ (_ :> earlierH) -> MultipleRunsTried earlierH lastH++-- | Returns 'True' if the first update run hasn't been carried out+isEmptyHistory :: RunHistory m -> Bool+isEmptyHistory h = case historyState h of+ NoRunsTried _ -> True+ _ -> False++latestPending :: RunHistory m -> PendingPackages+latestPending h = case historyState h of+ NoRunsTried initialPending -> initialPending+ OneRunTried _ (lastPending, _) -> lastPending+ MultipleRunsTried _ (lastPending, _) -> lastPending++data LoopType+ -- | Loop until there are no pending packages left. Fails if the current+ -- 'PendingPackages' matches any in the history, as this means one or+ -- more packages are failing due to reasons other than broken+ -- dependencies.+ --+ -- This is the default "classic" behavior of @haskell-updater@+ = UntilNoPending++ -- | Loop until there is no change in the current pending packages+ -- compared to the last run. Succeeds or fails based on the 'ExitCode'+ -- of the last run and the current run. This is useful for modes where+ -- it is possible to start out with no 'PendingPackages', but some may+ -- appear later as packages are updated and break their dependencies.+ --+ -- Used by e.g. @--mode=reinstall-atoms@.+ | UntilNoChange++ -- | Run once and do not loop. This is useful for modes where no+ -- valuable information can be gleaned by comparing 'PendingPackages'+ -- of separate runs.+ --+ -- Used by e.g. @--target=all@.+ | NoLoop+ deriving (Show, Eq, Ord, Enum, Bounded)++-- | Any hard-coded extra raw arguments to pass to the package manager, which+-- are needed for some @haskell-updater@ modes.+newtype ExtraRawArgs = ExtraRawArgs [String]+ deriving (Show, Eq, Ord)++newtype InvalidPkgs = InvalidPkgs (Set.Set Package)+ deriving (Show, Eq, Ord, Semigroup, Monoid)++newtype AllPkgs = AllPkgs (Set.Set Package)+ deriving (Show, Eq, Ord, Semigroup, Monoid)++class PackageSet t where+ getPkgs :: t -> Set.Set Package++instance PackageSet InvalidPkgs where+ getPkgs (InvalidPkgs ps) = ps++instance PackageSet AllPkgs where+ getPkgs (AllPkgs ps) = ps++instance PackageSet () where+ getPkgs () = Set.empty++instance PackageSet PendingPackages where+ getPkgs (InvalidPending p) = getPkgs p+ getPkgs (AllPending p) = getPkgs p++instance PackageSet (Set.Set Package) where+ getPkgs = id++-- | A class for monads that have some sort of exit feature. It must terminate+-- execution within the monad, optionally display a message, and return an+-- 'ExitArg'. The most obvious example is @IO@ which has 'exitSuccess' and+-- more broadly, 'Exit.exitWith'. The 'ExitArg' for @IO@ is 'ExitCode'.+--+-- This is left open as a class for testing purposes.+class Monad m => MonadExit m where+ type ExitArg m+ success :: String -> m a+ die :: String -> m a+ exitWith :: ExitArg m -> m a+ isSuccess :: Proxy m -> ExitArg m -> Bool++instance MonadExit IO where+ type ExitArg IO = ExitCode+ success msg = do+ hPutStrLn stderr msg+ liftIO exitSuccess+ die msg = do+ hPutStrLn stderr ("ERROR: " ++ msg)+ exitWith (ExitFailure 1)+ exitWith = Exit.exitWith+ isSuccess _ = \case+ ExitSuccess -> True+ ExitFailure _ -> False++instance MonadExit m => MonadExit (StateT r m) where+ type ExitArg (StateT r m) = ExitArg m+ success = lift . success+ die = lift . die+ exitWith = lift . exitWith+ isSuccess (_ :: Proxy (StateT r m)) = isSuccess (Proxy :: Proxy m)++instance MonadExit m => MonadExit (ReaderT r m) where+ type ExitArg (ReaderT r m) = ExitArg m+ success = lift . success+ die = lift . die+ exitWith = lift . exitWith+ isSuccess (_ :: Proxy (ReaderT r m)) = isSuccess (Proxy :: Proxy m)++deriving instance MonadExit SayIO
+ src/Distribution/Gentoo/Types/Mode.hs view
@@ -0,0 +1,193 @@+{- |+ Module : Distribution.Gentoo.Types.Mode+ 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.+ -}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}++module Distribution.Gentoo.Types.Mode+ ( HUMode(..)+ , PkgManager(..)+ , RunMode(..)+ , runMode+ , Target(..)+ , getTarget+ , PortageMode(..)+ , PortageBasicTarget(..)+ , ReinstallAtomsTarget(..)+ , RATargets(..)+ , getLoopType+ , getExtraRawArgs+ ) where++import Data.Bifoldable (bifoldMap)+import Data.Monoid (Last(..))++import Distribution.Gentoo.Types hiding (Target)+import Distribution.Gentoo.Util (These(..), NESet(..))+import Distribution.Gentoo.PkgManager.Types (PMFlag(..))++-- | Top level run modes for @haskell-updater@ including @--help@ and+-- @--version@, which do not run the @runUpdater@ function in "Main".+-- v'RunMode' is used during normal use of the utility.+data HUMode+ = HelpMode+ | VersionMode+ | RunMode RunModifier PkgManager+ deriving (Eq, Ord, Show)++-- | Choice of supported package managers. Currently, portage has more modes+-- available, such as @--mode=reinstall-atoms@, which are encoded in+-- 'PortageMode'.+data PkgManager+ = Portage PortageMode+ | PkgCore RunMode+ | Paludis RunMode+ | CustomPM String RunMode+ deriving (Eq, Ord, Show)++-- | Basic run modes that are available for all package managers.+data RunMode+ = BasicMode Target+ | ListMode Target+ deriving (Eq, Ord, Show)++-- | Basic targets that are available for all package managers.+data Target+ = OnlyInvalid+ | AllInstalled+ deriving (Eq, Ord, Show)++-- | Custom target to be passed to the package manager.+type CustomTarget = String++-- | Encodes valid target combinations for 'ReinstallAtomsMode' (portage only).+newtype RATargets = RATargets+ { unRATargets :: These Target+ (These ReinstallAtomsTarget (NESet CustomTarget)) }+ deriving (Show, Eq, Ord)++-- | No Monoid instance since there is intentionally no empty element+instance Semigroup RATargets where+ sel1 <> sel2 = RATargets $ case conv (toMonoidTriple sel1 <> toMonoidTriple sel2) of+ (Just t, Just r, Just s) -> These t (These r s)+ (Just t, Just r, Nothing) -> These t (This r)+ (Just t, Nothing, Just s) -> These t (That s)+ (Just t, Nothing, Nothing) -> This t+ (Nothing, Just r, Just s) -> That (These r s)+ (Nothing, Just r, Nothing) -> That (This r)+ (Nothing, Nothing, Just s) -> That (That s)+ -- If there was an option for no targets, it would go here+ (Nothing, Nothing, Nothing) -> undefined+ where+ conv (Last mt, Last mr, ms) = (mt,mr,ms)++ -- | Convenience function to turn RATargets into a triple of monoids, which helps+ -- in the Semigroup definition.+ toMonoidTriple+ :: RATargets+ -> (Last Target, Last ReinstallAtomsTarget, Maybe (NESet CustomTarget))+ toMonoidTriple = bifoldMap+ (\t -> (pure t, mempty, mempty))+ (bifoldMap+ (\r -> (mempty, pure r, mempty))+ (\s -> (mempty, mempty, pure s))+ ) . unRATargets++-- | Modes that are available for portage. This includes the basic+-- 'PortageBasicMode' and 'PortageListMode' (which correspond to+-- 'BasicMode' and 'ListMode' respectively), but also 'ReinstallAtomsMode',+-- which is specific to portage.+data PortageMode+ = PortageBasicMode (Either PortageBasicTarget Target)+ | PortageListMode Target+ | ReinstallAtomsMode RATargets+ deriving (Eq, Ord, Show)++-- | Extra targets that are available for portage in @--mode=basic@. Currently,+-- this only includes @@preserved-rebuild@.+data PortageBasicTarget = PreservedRebuild+ deriving (Eq, Ord, Show)++-- | Targets that are availble only for @--mode=reinstall-atoms' (portage+-- only). This includes 'WorldTarget' (@@world@) and 'WorldFullTarget', a+-- special convenience target which adds @@world@ to the target list and+-- also passes @--newuse --with-bdeps=y@ to portage for convenience.+-- (See 'getExtraRawArgs').+data ReinstallAtomsTarget+ = WorldTarget+ | WorldFullTarget+ deriving (Eq, Ord, Show)++-- | Extract the t'RunMode' (or 'PortageMode') from the 'HUMode' ADT.+--+-- Like other functions in this module, it takes a 'PkgManager' (as opposed+-- to 'HUMode'), since only the v'RunMode' constructor of 'HUMode' is+-- relevant.+runMode :: PkgManager -> Either RunMode PortageMode+runMode (Portage rm) = Right rm+runMode (PkgCore rm) = Left rm+runMode (Paludis rm) = Left rm+runMode (CustomPM _ rm) = Left rm++-- | Extract the 'Target' from a t'RunMode' constructor.+getTarget :: RunMode -> Target+getTarget (BasicMode t) = t+getTarget (ListMode t) = t++-- | Convert from the @haskell-updater@ ADT to 'LoopMode', which encodes+-- how the looping mechanism of @haskell-updater@ should funciton.+--+-- Like other functions in this module, it takes a 'PkgManager' (as opposed+-- to 'HUMode'), since only the v'RunMode' constructor of 'HUMode' is+-- relevant.+getLoopType :: RunModifier -> PkgManager -> LoopType+getLoopType rm+ -- Always use NoLoop if --pretend is passed on the command line+ | any (== PretendBuild) (flags rm) = const NoLoop+ | otherwise = \case+ -- ReinstallAtomsMode should always use UntilNoChange+ Portage (ReinstallAtomsMode _) -> UntilNoChange++ -- @--target=preserved-rebuild@ should use UntilNoChange+ Portage (PortageBasicMode (Left PreservedRebuild)) -> UntilNoChange++ -- The rest follow a standard pattern+ Portage (PortageBasicMode (Right t)) -> fromTarget t+ Portage (PortageListMode _) -> NoLoop+ PkgCore mode -> fromRunMode mode+ Paludis mode -> fromRunMode mode+ CustomPM _ mode -> fromRunMode mode+ where+ fromRunMode :: RunMode -> LoopType+ fromRunMode = \case+ BasicMode t -> fromTarget t+ ListMode _ -> NoLoop++ fromTarget :: Target -> LoopType+ fromTarget = \case+ OnlyInvalid -> UntilNoPending+ AllInstalled -> NoLoop++-- | Convert from the 'HUMode' ADT to 'ExtraRawArgs', hard-coded extra+-- arguments that will be passed to the package manager.+--+-- Like other functions in this module, it takes a 'PkgManager' (as opposed+-- to 'HUMode'), since only the v'RunMode' constructor of 'HUMode' is+-- relevant.+getExtraRawArgs :: PkgManager -> ExtraRawArgs+getExtraRawArgs = ExtraRawArgs . \case+ Portage (ReinstallAtomsMode (RATargets t)) ->+ bifoldMap (const []) (bifoldMap fromRAT (const [])) t+ Portage (PortageBasicMode _) -> ["--usepkg-exclude=*/*"]+ _ -> []+ where+ fromRAT = \case+ WorldFullTarget -> ["--newuse", "--with-bdeps=y"]+ WorldTarget -> []
+ src/Distribution/Gentoo/Util.hs view
@@ -0,0 +1,103 @@+{- |+ Module : Distribution.Gentoo.Util+ Description : Utility functions+ Copyright : (c) Ivan Lazar Miljenovic 2009+ License : GPL-2 or later++ Common utility functions.+ -}++{-# LANGUAGE DeriveTraversable #-}++module Distribution.Gentoo.Util+ ( -- * Misc+ BSFilePath+ , concatMapM+ , breakAll+ -- * These+ , These(..)+ , these+ -- * NESet+ , NESet(..)+ , singletonNE+ , insertNE+ , memberNE+ , toListNE+ ) where++import Data.Bifoldable+import Data.Bifunctor+import Data.Bitraversable+import qualified Data.List as L+import qualified Data.Set as S+import Data.ByteString.Char8(ByteString)++-- | Alias used to indicate that this ByteString represents a FilePath+type BSFilePath = ByteString++-- | @concatMapM f = fmap concat . traverse f@+concatMapM :: (a -> IO [b]) -> [a] -> IO [b]+concatMapM f = fmap concat . traverse f++-- | @breakAll p = L.groupBy (const (not . p))@+breakAll :: (a -> Bool) -> [a] -> [[a]]+breakAll p = L.groupBy (const (not . p))++-- | Taken from the [these](https://hackage.haskell.org/package/these) package,+-- the t'These' type represents values with two non-exclusive possibilities.+--+-- This can be useful to represent combinations of two values, where the+-- combination is defined if either input is.+data These a b+ = These a b+ | This a+ | That b+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable)++instance Bifunctor These where+ bimap f g (These a b) = These (f a) (g b)+ bimap f _ (This a) = This (f a)+ bimap _ g (That b) = That (g b)++instance Bifoldable These where+ bifoldMap f g (These a b) = f a <> g b+ bifoldMap f _ (This a) = f a+ bifoldMap _ g (That b) = g b++instance Bitraversable These where+ bitraverse f g (These a b) = These <$> f a <*> g b+ bitraverse f _ (This a) = This <$> f a+ bitraverse _ g (That b) = That <$> g b++-- | Case analysis for the t'These' type.+these :: (a -> b -> c) -> (a -> c) -> (b -> c) -> These a b -> c+these f _ _ (These a b) = f a b+these _ g _ (This a) = g a+these _ _ h (That b) = h b++-- | A 'S.Set' which can never be empty.+data NESet a = a :~ S.Set a+ deriving (Show, Eq, Ord, Foldable)++instance Ord a => Semigroup (NESet a) where+ (x1 :~ s1) <> (x2 :~ s2) =+ x1 :~ (if x1 == x2 then id else (S.insert x2)) (s1 <> s2)++-- | Create a 'NESet' from a single value.+singletonNE :: a -> NESet a+singletonNE x = x :~ S.empty++-- | Insert a value into a 'NESet'.+insertNE :: Ord a => a -> NESet a -> NESet a+insertNE x n@(y :~ s)+ | x == y = n+ | otherwise = y :~ S.insert x s++-- | Check if a value exists in a 'NESet'.+memberNE :: Ord a => a -> NESet a -> Bool+memberNE x (y :~ s) = x == y || S.member x s++-- | Convert a 'NESet' to a list. The ordering is defined by 'S.toList' of+-- 'S.Set'.+toListNE :: Ord a => NESet a -> [a]+toListNE (x :~ s) = S.toList (S.insert x s)
+ src/Main.hs view
@@ -0,0 +1,501 @@+{- |+ Module : Main+ Description : The haskell-updater executable+ Copyright : (c) Ivan Lazar Miljenovic, Stephan Friedrichs, Emil Karlson 2010+ License : GPL-2 or later++ The executable module of haskell-updater, which finds Haskell+ packages to rebuild after a dep upgrade or a GHC upgrade.+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Main+ ( -- * Main mode+ UpdaterLoop+ , UpdateState+ , IOEnv(..)+ , runIOEnv+ , runUpdater+ , getPackageState+ -- * Help mode+ , help+ -- * Version mode+ , version+ -- * @main@+ , main+ ) where++import Distribution.Gentoo.CmdLine+import qualified Distribution.Gentoo.CmdLine.Types as CmdLine -- (CmdLineArgs, BuildTarget)+import Distribution.Gentoo.Env+import Distribution.Gentoo.GHC+ ( MonadPkgState (oldGhcPkgs, brokenPkgs, allInstalledPkgs)+ , ghcVersion, ghcLibDir, ghcLoc, unCPV+ )+import Distribution.Gentoo.Packages+import Distribution.Gentoo.PkgManager+import Distribution.Gentoo.Types as Types+import Distribution.Gentoo.Types.Mode as Mode+import Distribution.Gentoo.Util (These(..), toListNE)++import Control.Monad (unless, when)+import qualified Control.Monad as CM+import Control.Monad.State.Strict+ (MonadState, StateT, evalStateT, get, put, MonadIO, liftIO)+import Data.Bifoldable (bifoldMap)+import Data.Foldable (toList)+import qualified Data.List as L+import Data.Proxy+import Data.Sequence ((|>))+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import Data.Version (showVersion)+import qualified Paths_haskell_updater as Paths (version)+import System.Console.GetOpt+import System.Environment (getArgs, getProgName)++import Output++main :: IO ()+main = do args <- getArgs+ defPM <- defaultPM+ case parseArgs defPM args of+ Left err -> die err+ Right (cmdArgs, rawArgs) -> runAction cmdArgs rawArgs++runAction :: CmdLine.CmdLineArgs -> RawPMArgs -> IO ()+runAction cmdArgs rawArgs = do++ mode <- either die pure $ mkHUMode cmdArgs rawArgs+ case mode of+ HelpMode -> help+ VersionMode -> version+ RunMode rm pm -> flip runEnvT (rm, pm, rawArgs) $ do++ vsay "Command line args:"+ liftIO getArgs >>= vsay . show+ vsay $ show cmdArgs+ vsay ""+ vsay "Internal representation for haskell-updater mode:"+ vsay $ show (RunMode rm pm)+ vsay ""+ vsay "Looping strategy:"+ vsay $ show (getLoopType rm pm)+ vsay ""++ systemInfo pm rawArgs++ bps <- getPackageState+ let ps = buildPkgsPending bps++ case runMode pm of+ Left (ListMode _) -> listPkgs ps+ Right (PortageListMode _) -> listPkgs ps+ _ -> runIOEnv runUpdater+ (bps, RunHistory ps Seq.empty)+ where+ listPkgs ps = do+ mapM_ (liftIO . putStrLn . printPkg) (getPkgs ps)+ success "done!"++dumpHistory :: forall m. (MonadSay m, Show (ExitArg m))+ => RunHistory m -> m ()+dumpHistory (RunHistory pkgSet0 historySeq) = do+ say "Updater's past history:"+ say $ unwords+ [ "Initial state:"+ , show $ printPkg <$> Set.toList (getPkgs pkgSet0)+ ]+ CM.forM_ historyList $ \(n, entry, ec) -> say $ unwords+ [ "Pass"+ , show n ++ ":"+ , show $ printPkg <$> Set.toList (getPkgs entry)+ , show ec+ ]+ say ""+ where historyList :: [(Int, PendingPackages, ExitArg m)]+ historyList =+ [ (n, entry, ec)+ | ((entry, ec), n) <- zip (toList historySeq) [1..]+ ]++-- | An action that controls the looping mechanism inside 'runUpdater'. This+-- holds the logic for what action to take after running the package manager+-- (e.g. exit with success/error or continue to the next iteration).+type UpdaterLoop m+ = m () -- ^ The next iteration of the loop+ -> m ()++-- | State between each run of an 'UpdaterLoop'+type UpdateState m =+ ( BuildPkgs -- ^ Current targets and other info needed to run the PM+ , RunHistory m+ )++-- | The default run environment with 'IO' at its base.+newtype IOEnv a+ = IOEnv (StateT (UpdateState IOEnv) (EnvT IO) a)+ deriving ( Functor, Applicative, Monad, MonadSay, MonadPkgState+ , MonadWritePkgState, MonadState (UpdateState IOEnv)+ , HasRunModifier, HasPkgManager, HasRawPMArgs )++instance MonadExit IOEnv where+ type ExitArg IOEnv = ExitArg (StateT (UpdateState IOEnv) (EnvT IO))+ success = IOEnv . success+ die = IOEnv . die+ exitWith = IOEnv . exitWith+ isSuccess (_ :: Proxy IOEnv)+ = isSuccess (Proxy :: Proxy (StateT (UpdateState IOEnv) (EnvT IO)))++runIOEnv :: IOEnv a -> UpdateState IOEnv -> EnvT IO a+runIOEnv (IOEnv s) = evalStateT s++-- | Run the main part of @haskell-updater@ (e.g. not @--help@ or @--version@).+-- This expects the initial 'UpdateState' to reflect the initial state of the+-- system.+runUpdater+ :: forall m.+ ( MonadSay m+ , MonadPkgState m+ , MonadWritePkgState m+ , MonadState (UpdateState m) m+ , MonadExit m+ , Show (ExitArg m)+ , HasRunModifier m+ , HasPkgManager m+ , HasRawPMArgs m+ )+ => m ()+runUpdater = do+ (bps, _) <- get+ askLoopType >>= \case+ UntilNoPending -> runLoop loopUntilNoPending+ UntilNoChange -> runLoop loopUntilNoChange+ NoLoop -> buildPkgs bps >>= exitWith+ success "done!"+ where+ -- | Only abort the loop when there are no broken packages reported+ -- on the system, or if a loop is detected by comparing the state to+ -- previous runs.+ loopUntilNoPending :: UpdaterLoop m+ loopUntilNoPending continue = do+ (bps, hist) <- get++ let ps = buildPkgsPending bps++ -- Stop when there are no more pending packages+ if | Set.null (getPkgs ps) -> alertDone Nothing++ -- Look to see if the current set of broken haskell packages matches+ -- any in the history. If it does, this means we're in a loop.+ -- (Ignore this if the first run has not been completed yet.)+ | not (isEmptyHistory hist) && isInHistory hist (getPkgs ps)+ -> alertStuck Nothing++ -- Otherwise, keep going+ | otherwise -> continue++ -- | Compare the /last two/ runs to see if any broken packages were fixed.+ -- If the state of broken packages stays the same between runs, it means+ -- emerge is either hitting an error that @haskell-updater@ cannot fix,+ -- or emerge has nothing to do.+ loopUntilNoChange :: UpdaterLoop m+ loopUntilNoChange continue = do+ (bps, hist) <- get++ if noTargets bps+ then done+ else case historyState hist of+ -- If there is no history, the first update still needs to be run+ NoRunsTried _ -> continue++ OneRunTried initialPending (lastPending, lastEC)+ -> go initialPending lastPending lastEC True++ MultipleRunsTried (earlierPending, _) (lastPending, lastEC)+ -> go earlierPending lastPending lastEC False++ where+ go :: PendingPackages -> PendingPackages -> ExitArg m -> Bool -> m ()+ go earlierPending lastPending lastEC isFirstRun = do+ let nothingChanged, cmdSuccess :: Bool++ -- Is the broken package set identical to what it was+ -- before the update?+ nothingChanged = lastPending == earlierPending++ -- Did the update command succeed?+ cmdSuccess = isSuccess (Proxy :: Proxy m) lastEC++ -- Alert that we're stuck, but add a note if it failed on its+ -- first run+ stuck = alertStuck $ if isFirstRun+ then Just stuckOnePass+ else Nothing++ case (nothingChanged, cmdSuccess) of+ -- The success state: The update completed and nothing changed+ (True, True) -> done++ -- Stuck state: The update failed and nothing changed+ (True, False) -> stuck++ -- A change happened and we have targets still: continue+ (False, _) -> continue++ -- Alert that we're finished, but add a warning if there are+ -- still broken packages on the system+ done = do+ (_, hist) <- get+ let lastPending = latestPending hist+ alertDone $ if Set.null (getPkgs lastPending)+ then Nothing+ else Just successIncomplete++ -- Are there no targets for the package manager?+ noTargets = emptyTargets . buildPkgsTargets++ -- This mostly comes up with the 'UntilNoChange' loop type, so we'll limit+ -- it to that for now.+ stuckOnePass =+ [ "NOTE: The updater loop failed after one pass, with no changes to the state of"+ , "broken Haskell packages on the system. This is often caused by the package"+ , "manager failing during dependency resolution. Check the output to be sure."+ ]++ successIncomplete =+ [ "WARNING: The updater loop appears to have completed, but there are still"+ , "broken Haskell packages detected on the system!"+ ]++ -- Rebuild the packages then retrieve fresh package state+ updateAndContinue :: UpdaterLoop m -> m ()+ updateAndContinue loop = do+ (bps, hist) <- get++ -- Exit with failure if there are no targets for the package manager+ when (emptyTargets (buildPkgsTargets bps)) alertNoTargets++ exitCode <- buildPkgs bps++ bps' <- getPackageState+ let ps = buildPkgsPending bps'+ hist' = hist+ { runHistory = runHistory hist |> (ps, exitCode) }++ put (bps', hist')++ runLoop loop++ runLoop :: UpdaterLoop m -> m ()+ runLoop loop = loop (updateAndContinue loop)++ emptyTargets :: Set.Set Types.Target -> Bool+ emptyTargets = all $ \case+ TargetInvalid ps -> Set.null (getPkgs ps)+ TargetAll ps -> Set.null (getPkgs ps)+ CustomTarget _ -> False++ alertDone maybeMsg = success $ unlines+ $ "Nothing to build!"+ : maybe [] ("":) maybeMsg++ alertStuck maybeMsg = do+ (_,hist) <- get+ dumpHistory hist+ die $ unlines+ $ "Updater stuck in the loop and can't progress"+ : maybe [] ("":) maybeMsg++ alertNoTargets = die "No targets to pass to the package manager!"++-- | As needed, query @ghc-pkg check@ for broken packages, scan the filesystem+-- for installed packages, and look for misc breakages. Return the results+-- summarized for use with 'buildPkgs'.+getPackageState+ :: (MonadSay m, MonadPkgState m, HasPkgManager m)+ => m BuildPkgs+getPackageState = askPkgManager >>= \pkgMgr ->+ case runMode pkgMgr of+ Left mode -> fromRunMode mode+ Right (PortageBasicMode (Left PreservedRebuild)) -> do+ ps <- InvalidPending <$> getInvalid+ let ct = CustomTarget "@preserved-rebuild"+ pure $ BuildNormal pkgMgr ps (Set.singleton ct)+ Right (PortageBasicMode (Right targ)) -> fromRunMode (BasicMode targ)+ Right (PortageListMode targ) -> fromRunMode (ListMode targ)+ Right (ReinstallAtomsMode targ) -> flip evalStateT Nothing $ do+ aps <- getAll+ -- Only use InvalidPending with ReinstallAtomsMode+ let pending _ = withIPCache InvalidPending+ normalTarg = \case+ OnlyInvalid -> withIPCache TargetInvalid+ AllInstalled -> pure $ TargetAll aps+ extraTargs = bifoldMap+ (Set.singleton . \case+ WorldTarget -> CustomTarget "@world"+ WorldFullTarget -> CustomTarget "@world"+ )+ (Set.fromList . map CustomTarget . toListNE)+ (p,ts) <- case unRATargets targ of+ These ta th -> do+ p <- pending ta+ nt <- normalTarg ta+ pure (p, Set.insert nt (extraTargs th))+ This ta -> do+ p <- pending ta+ nt <- normalTarg ta+ pure (p, Set.singleton nt)+ That th -> do+ p <- InvalidPending <$> getInvalid+ pure (p, extraTargs th)+ pure $ BuildRAMode p ts aps+ where+ fromRunMode+ :: (MonadSay m, MonadPkgState m, HasPkgManager m)+ => RunMode+ -> m BuildPkgs+ fromRunMode mode = askPkgManager >>= \pkgMgr -> do+ ps <- case getTarget mode of+ OnlyInvalid -> InvalidPending <$> getInvalid+ AllInstalled -> AllPending <$> getAll+ pure $ BuildNormal pkgMgr ps Set.empty++ getInvalid :: (MonadSay m, MonadPkgState m) => m InvalidPkgs+ getInvalid = do+ say "Searching for packages installed with a different version of GHC."+ say ""+ old <- oldGhcPkgs+ pkgListPrintLn "old" old++ say "Searching for Haskell libraries with broken dependencies."+ say ""+ (broken, unknown_packages, unknown_files) <- brokenPkgs+ let broken' = Set.fromList broken+ printUnknownPackagesLn (map unCPV unknown_packages)+ printUnknownFilesLn unknown_files+ pkgListPrintLn "broken" (notGHC broken')++ return $ InvalidPkgs $ old <> broken'++ getAll :: (MonadSay m, MonadPkgState m) => m AllPkgs+ getAll = do+ say "Searching for packages installed with the current version of GHC."+ say ""+ pkgs <- allInstalledPkgs+ pkgListPrintLn "installed" pkgs+ return $ AllPkgs pkgs++ printUnknownPackagesLn [] = return ()+ printUnknownPackagesLn ps = do+ say "The following packages are orphan (not installed by your package manager):"+ printList id ps+ say ""+ printUnknownFilesLn [] = return ()+ printUnknownFilesLn fs = do+ say "The following files are orphan (not installed by your package manager):"+ printList id fs+ say "It is strongly advised to remove orphans:"+ say " One of known sources of orphans is packages installed before 01 Jan 2015."+ say " If you know it's your case you can easily remove such files:"+ say " # rm -v -- `qfile -o $(ghc --print-libdir)/package.conf.d/*.conf $(ghc --print-libdir)/gentoo/*.conf`"+ say " # ghc-pkg recache"+ say " It will likely need one more 'haskell-updater' run."+ say ""++ withIPCache+ :: (MonadSay m, MonadPkgState m)+ => (InvalidPkgs -> a)+ -> StateT (Maybe InvalidPkgs) m a+ withIPCache f = fmap f $ get >>= \case+ Nothing -> do+ ips <- getInvalid+ put (Just ips)+ pure ips+ Just ips -> pure ips++-- -----------------------------------------------------------------------------+-- Printing information.++help :: IO a+help = progInfo >>= sayIO . success++version :: IO a+version = fmap (++ '-' : showVersion Paths.version) getProgName >>= sayIO . success++progInfo :: IO String+progInfo = do pName <- getProgName+ return $ usageInfo (header pName) options+ where+ header pName = unlines [ pName ++ " -- Find and rebuild packages broken due to any of:"+ , " * GHC upgrade"+ , " * Haskell dependency upgrade"+ , ""+ , "Usage: " ++ pName ++ " [Options [-- [PM options]]"+ , ""+ , ""+ , "Options:"]++systemInfo+ :: (MonadSay m, MonadIO m)+ => PkgManager+ -> RawPMArgs+ -> m ()+systemInfo pkgMgr rawArgs = do+ ver <- liftIO ghcVersion+ pName <- liftIO getProgName+ let pVer = showVersion Paths.version+ pLoc <- liftIO ghcLoc+ libDir <- liftIO ghcLibDir+ say $ "Running " ++ pName ++ "-" ++ pVer ++ " using GHC " ++ ver+ say $ " * Executable: " ++ pLoc+ say $ " * Library directory: " ++ libDir+ say $ " * Package manager (PM): " ++ nameOfPM (toPkgManager pkgMgr)+ unless (null rawArgs) $+ say $ " * PM auxiliary arguments: " ++ unwords rawArgs+ say $ " * Targets: " ++ L.intercalate ", " ts+ say $ " * Mode: " ++ argString m+ say ""+ where+ (m, ts) = case runMode pkgMgr of+ Left mode -> (:[]) <$> printRunMode mode+ Right (PortageBasicMode (Left PreservedRebuild)) ->+ (CmdLine.BasicMode, [argString CmdLine.PreservedRebuild])+ Right (PortageBasicMode (Right targ)) ->+ (:[]) <$> printRunMode (BasicMode targ)+ Right (PortageListMode targ) ->+ (:[]) <$> printRunMode (ListMode targ)+ Right (ReinstallAtomsMode (RATargets targ)) ->+ let strs = bifoldMap+ ((:[]) . \case+ OnlyInvalid -> argString CmdLine.OnlyInvalid+ AllInstalled -> argString CmdLine.AllInstalled+ )+ (bifoldMap+ ((:[]) . \case+ WorldTarget -> argString CmdLine.WorldTarget+ WorldFullTarget -> unwords+ [argString CmdLine.WorldTarget, "(full)"]+ )+ toListNE+ )+ targ+ in (CmdLine.ReinstallAtomsMode, strs)++ printRunMode :: RunMode -> (CmdLine.RunMode, String)+ printRunMode = \case+ 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)
+ src/Output.hs view
@@ -0,0 +1,102 @@+{- |+ Module : Main+ Description : The haskell-updater executable+ License : GPL-2 or later++ Fancy output facility.+-}++{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}++module Output ( -- * Verbosity+ Verbosity(..)+ -- * MonadSay+ , MonadSay(..)+ , say+ , vsay+ , pkgListPrintLn+ , printList+ -- * SayIO+ , SayIO(..)+ ) where++import Control.Monad.Reader+import Control.Monad.State.Strict+import qualified Data.Set as Set+import System.IO (hPutStrLn, stderr)++import Distribution.Gentoo.Packages++-- | output mode (chattiness)+data Verbosity = Quiet -- ^ Minimal information is printed (@--quiet@)+ | Normal -- ^ Some information is printed (default)+ | Verbose -- ^ Extra information is printed (@--verbose@)+ deriving (Eq, Ord, Show, Read)++-- | Monads that have an environment that stores the specified verbosity level,+-- and can output messages+class Monad m => MonadSay m where+ outputLn :: String -> m () -- ^ Output a line+ askVerbosity :: m Verbosity++-- | Print a message that will show up if verbosity is set to 'Normal' or+-- 'Verbose'.+say :: MonadSay m => String -> m ()+say msg = askVerbosity >>= \case+ Quiet -> return ()+ Normal -> outputLn msg+ Verbose -> outputLn msg++-- | Print a message that will only show up if verbosity is set to 'Verbose'+vsay :: MonadSay m => String -> m ()+vsay msg = askVerbosity >>= \case+ Quiet -> return ()+ Normal -> return ()+ Verbose -> outputLn msg++-- | Print a bullet list of values with one value per line.+printList :: MonadSay m => (a -> String) -> [a] -> m ()+printList f = mapM_ (say . (++) " * " . f)++-- | Print a list of packages, with a description of what they are.+pkgListPrintLn :: MonadSay m => String -> Set.Set Package -> m ()+pkgListPrintLn desc pkgs+ | null pkgs = do+ say $ unwords ["No", desc, "packages found!"]+ say ""+ | otherwise = askVerbosity >>= \case+ Quiet -> pure ()+ Normal -> do+ outputLn $ unwords+ ["Found", show (Set.size pkgs), desc, "packages."]+ outputLn ""+ Verbose -> do+ outputLn $ unwords+ ["Found the following", desc, "packages:"]+ printList printPkg (Set.toList pkgs)+ outputLn ""++-- | A simple wrapper for adding a basic 'MonadSay' instance to 'IO'.+-- This always uses 'Normal' verbosity.+--+-- Note that we avoid directly adding a 'MonadSay' instance for 'IO', since+-- this can cause the type-checker to miss certain mistakes (such as using+-- @'liftIO' . 'vsay'@, which would choose the 'IO' instance, thus always+-- using 'Normal' verbosity and ignoring the 'Verbosity' given via the+-- command line).+newtype SayIO a = SayIO { sayIO :: IO a }+ deriving (Functor, Applicative, Monad, MonadIO)++instance MonadSay SayIO where+ outputLn = SayIO . hPutStrLn stderr+ askVerbosity = pure Normal++instance MonadSay m => MonadSay (StateT s m) where+ outputLn = lift . outputLn+ askVerbosity = lift askVerbosity++instance MonadSay m => MonadSay (ReaderT r m) where+ outputLn = lift . outputLn+ askVerbosity = lift askVerbosity