diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Distribution/Gentoo/CmdLine.hs b/Distribution/Gentoo/CmdLine.hs deleted file mode 100644 --- a/Distribution/Gentoo/CmdLine.hs +++ /dev/null @@ -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 } - - - diff --git a/Distribution/Gentoo/CmdLine/Types.hs b/Distribution/Gentoo/CmdLine/Types.hs deleted file mode 100644 --- a/Distribution/Gentoo/CmdLine/Types.hs +++ /dev/null @@ -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] diff --git a/Distribution/Gentoo/GHC.hs b/Distribution/Gentoo/GHC.hs deleted file mode 100644 --- a/Distribution/Gentoo/GHC.hs +++ /dev/null @@ -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: --- * --- * -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') diff --git a/Distribution/Gentoo/Packages.hs b/Distribution/Gentoo/Packages.hs deleted file mode 100644 --- a/Distribution/Gentoo/Packages.hs +++ /dev/null @@ -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 diff --git a/Distribution/Gentoo/PkgManager.hs b/Distribution/Gentoo/PkgManager.hs deleted file mode 100644 --- a/Distribution/Gentoo/PkgManager.hs +++ /dev/null @@ -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" diff --git a/Distribution/Gentoo/PkgManager/Types.hs b/Distribution/Gentoo/PkgManager/Types.hs deleted file mode 100644 --- a/Distribution/Gentoo/PkgManager/Types.hs +++ /dev/null @@ -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) diff --git a/Distribution/Gentoo/Types.hs b/Distribution/Gentoo/Types.hs deleted file mode 100644 --- a/Distribution/Gentoo/Types.hs +++ /dev/null @@ -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 diff --git a/Distribution/Gentoo/Types/HUMode.hs b/Distribution/Gentoo/Types/HUMode.hs deleted file mode 100644 --- a/Distribution/Gentoo/Types/HUMode.hs +++ /dev/null @@ -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 diff --git a/Distribution/Gentoo/Util.hs b/Distribution/Gentoo/Util.hs deleted file mode 100644 --- a/Distribution/Gentoo/Util.hs +++ /dev/null @@ -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)) diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -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 diff --git a/Output.hs b/Output.hs deleted file mode 100644 --- a/Output.hs +++ /dev/null @@ -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 "" diff --git a/haskell-updater.cabal b/haskell-updater.cabal --- a/haskell-updater.cabal +++ b/haskell-updater.cabal @@ -2,7 +2,7 @@ name: haskell-updater homepage: https://github.com/gentoo-haskell/haskell-updater#readme bug-reports: https://github.com/gentoo-haskell/haskell-updater/issues -version: 1.4.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) diff --git a/src/Distribution/Gentoo/CmdLine.hs b/src/Distribution/Gentoo/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Gentoo/CmdLine.hs @@ -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 } diff --git a/src/Distribution/Gentoo/CmdLine/Types.hs b/src/Distribution/Gentoo/CmdLine/Types.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Gentoo/CmdLine/Types.hs @@ -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] diff --git a/src/Distribution/Gentoo/Env.hs b/src/Distribution/Gentoo/Env.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Gentoo/Env.hs @@ -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 diff --git a/src/Distribution/Gentoo/GHC.hs b/src/Distribution/Gentoo/GHC.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Gentoo/GHC.hs @@ -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: +-- * +-- * +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 + +-- ----------------------------------------------------------------------------- diff --git a/src/Distribution/Gentoo/Packages.hs b/src/Distribution/Gentoo/Packages.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Gentoo/Packages.hs @@ -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 diff --git a/src/Distribution/Gentoo/PkgManager.hs b/src/Distribution/Gentoo/PkgManager.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Gentoo/PkgManager.hs @@ -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" diff --git a/src/Distribution/Gentoo/PkgManager/Types.hs b/src/Distribution/Gentoo/PkgManager/Types.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Gentoo/PkgManager/Types.hs @@ -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) diff --git a/src/Distribution/Gentoo/Types.hs b/src/Distribution/Gentoo/Types.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Gentoo/Types.hs @@ -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 diff --git a/src/Distribution/Gentoo/Types/Mode.hs b/src/Distribution/Gentoo/Types/Mode.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Gentoo/Types/Mode.hs @@ -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 -> [] diff --git a/src/Distribution/Gentoo/Util.hs b/src/Distribution/Gentoo/Util.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Gentoo/Util.hs @@ -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) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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) diff --git a/src/Output.hs b/src/Output.hs new file mode 100644 --- /dev/null +++ b/src/Output.hs @@ -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