diff --git a/Distribution/Gentoo/GHC.hs b/Distribution/Gentoo/GHC.hs --- a/Distribution/Gentoo/GHC.hs +++ b/Distribution/Gentoo/GHC.hs @@ -37,8 +37,8 @@ -- Other imports import Data.Char(isDigit) -import Data.Either(Either(..), partitionEithers) -import Data.Maybe(Maybe(..), maybe, fromJust) +import Data.Either(partitionEithers) +import Data.Maybe(fromJust) import qualified Data.Map as Map import Data.Map(Map) import qualified Data.ByteString.Char8 as BS diff --git a/Distribution/Gentoo/PkgManager.hs b/Distribution/Gentoo/PkgManager.hs --- a/Distribution/Gentoo/PkgManager.hs +++ b/Distribution/Gentoo/PkgManager.hs @@ -1,7 +1,7 @@ {- | Module : Distribution.Gentoo.PkgManager Description : Using package managers in Gentoo. - Copyright : (c) Ivan Lazar Miljenovic 2009 + Copyright : (c) Ivan Lazar Miljenovic, Emil Karlson 2010 License : GPL-2 or later Maintainer : Ivan.Miljenovic@gmail.com @@ -11,8 +11,11 @@ ( PkgManager , definedPMs , choosePM + , stringToCustomPM + , isValidPM , defaultPM , defaultPMName + , nameOfPM , dummy , PMFlag(..) , buildCmd @@ -21,9 +24,11 @@ import Distribution.Gentoo.Packages import Data.Char(toLower) -import Data.Maybe(mapMaybe) +import Data.Maybe(mapMaybe, fromMaybe) import qualified Data.Map as M import Data.Map(Map) +import System.IO.Error(try) +import System.Environment(getEnv) -- ----------------------------------------------------------------------------- @@ -31,6 +36,7 @@ data PkgManager = Portage | PkgCore | Paludis + | InvalidPM String | CustomPM String deriving (Eq, Ord, Show, Read) @@ -38,9 +44,17 @@ dummy :: PkgManager dummy = CustomPM "echo" --- | The default package manager. -defaultPM :: PkgManager -defaultPM = pmNameMap M.! defaultPMName +-- | 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 <- try $ getEnv "PACKAGE_MANAGER" + let dPM = either (const defaultPMName) id eDPM + mPM = dPM `M.lookup` pmNameMap + return $ fromMaybe knownDef mPM + where + knownDef = pmNameMap M.! defaultPMName defaultPMName :: String defaultPMName = "portage" @@ -49,31 +63,48 @@ 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 -> Either String PkgManager -choosePM pm = maybe (Left pm) Right $ pm' `M.lookup` pmNameMap +choosePM :: String -> PkgManager +choosePM pm = maybe (InvalidPM pm) id $ 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 = "paludis" pmCommand (CustomPM cmd) = cmd +pmCommand (InvalidPM _) = undefined -defaultPMFlags :: PkgManager -> [String] -defaultPMFlags Portage = ["--oneshot", "--keep-going"] -defaultPMFlags PkgCore = ["--deep", "--oneshot", "--ignore-failures"] -defaultPMFlags Paludis = [ "--install", "--preserve-world" - , "--continue-on-failure if-independent"] -defaultPMFlags CustomPM{} = [] +defaultPMFlags :: PkgManager -> [String] +defaultPMFlags Portage = ["--oneshot", "--keep-going"] +defaultPMFlags PkgCore = ["--deep", "--oneshot", "--ignore-failures"] +defaultPMFlags Paludis = [ "--install", "--preserve-world" + , "--continue-on-failure if-independent"] +defaultPMFlags CustomPM{} = [] +defaultPMFlags (InvalidPM _) = undefined buildCmd :: PkgManager -> [PMFlag] -> [Package] -> String buildCmd pm fs ps = unwords $ pmCommand pm : fs' ++ ps' @@ -89,11 +120,12 @@ | UpdateAsNeeded deriving (Eq, Ord, Show, Read) -flagRep :: PkgManager -> PMFlag -> Maybe String -flagRep Portage = portagePMFlag -flagRep PkgCore = pkgcorePMFlag -flagRep Paludis = paludisPMFlag -flagRep CustomPM{} = const Nothing -- Can't tell how flags would work. +flagRep :: PkgManager -> PMFlag -> Maybe String +flagRep Portage = portagePMFlag +flagRep PkgCore = pkgcorePMFlag +flagRep Paludis = paludisPMFlag +flagRep CustomPM{} = const Nothing -- Can't tell how flags would work. +flagRep (InvalidPM _) = undefined portagePMFlag :: PMFlag -> Maybe String portagePMFlag PretendBuild = Just "--pretend" @@ -107,4 +139,4 @@ paludisPMFlag :: PMFlag -> Maybe String paludisPMFlag PretendBuild = Just "--pretend" paludisPMFlag UpdateDeep = Just "--dl-upgrade always" -paludisPMFlag UpdateAsNeeded = Just "--dl-upgrade as-needed" +paludisPMFlag UpdateAsNeeded = Just "--dl-upgrade as-needed --dl-new-slots as-needed" diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,7 +1,7 @@ {- | Module : Main Description : The haskell-updater executable - Copyright : (c) Ivan Lazar Miljenovic, Stephan Friedrichs 2009 + Copyright : (c) Ivan Lazar Miljenovic, Stephan Friedrichs, Emil Karlson 2010 License : GPL-2 or later Maintainer : Ivan.Miljenovic@gmail.com @@ -63,7 +63,7 @@ runAction :: RunModifier -> Action -> IO a runAction _ Help = help runAction _ Version = version -runAction rm (Build ts) = do systemInfo +runAction rm (Build ts) = do systemInfo rm ps <- allGetPackages ts buildPkgs rm ps @@ -121,6 +121,7 @@ data Flag = HelpFlag | VersionFlag | PM String + | CustomPMFlag String | Check | Upgrade | Pretend @@ -129,23 +130,24 @@ parseArgs :: IO (RunModifier, Action) parseArgs = do args <- getArgs - argParser $ getOpt Permute options args + defPM <- defaultPM + argParser defPM $ getOpt Permute options args -argParser :: ([Flag], [String], [String]) - -> IO (RunModifier, Action) -argParser (fls, oth, []) = do unless (null oth) - $ putErrLn - $ unwords $ "Unknown options:" : oth - unless (null bPms) - $ putErrLn - $ unwords $ "Unknown package managers:" : bPms - return (rm, a) +argParser :: PkgManager -> ([Flag], [String], [String]) + -> IO (RunModifier, Action) +argParser dPM (fls, oth, []) = do unless (null oth) + $ putErrLn + $ unwords $ "Unknown options:" : oth + unless (null bPms) + $ putErrLn + $ unwords $ "Unknown package managers:" : bPms + return (rm, a) where (fls', as) = partitionBy flagToAction fls a = combineAllActions as (opts, pms) = partitionBy flagToPM fls' - (bPms, pms') = partitionBy choosePM pms - pm = emptyElse defaultPM last pms' + (bPms, pms') = partitionBy isValidPM pms + pm = emptyElse dPM last pms' opts' = Set.fromList opts hasFlag = flip Set.member opts' pmFlags = bool id (PretendBuild:) (hasFlag Pretend) @@ -156,7 +158,7 @@ , withCmd = PrintAndRun } -argParser (_, _, errs) = die $ unwords $ "Errors in arguments:" : errs +argParser _ (_, _, errs) = die $ unwords $ "Errors in arguments:" : errs flagToAction :: Flag -> Either Flag Action flagToAction HelpFlag = Right Help @@ -165,9 +167,10 @@ flagToAction Upgrade = Right . Build $ Set.singleton GhcUpgrade flagToAction f = Left f -flagToPM :: Flag -> Either Flag String -flagToPM (PM pm) = Right pm -flagToPM f = Left f +flagToPM :: Flag -> Either Flag PkgManager +flagToPM (CustomPMFlag pm) = Right $ stringToCustomPM pm +flagToPM (PM pm) = Right $ choosePM pm +flagToPM f = Left f options :: [OptDescr Flag] options = @@ -178,6 +181,9 @@ , Option ['P'] ["package-manager"] (ReqArg PM "PM") $ "Use package manager PM, where PM can be one of:\n" ++ pmList ++ defPM + , Option ['C'] ["--custom-pm"] (ReqArg CustomPMFlag "command") + "Use custom command as package manager;\n\ + \ignores the --pretend and --no-deep flags." , Option ['p'] ["pretend"] (NoArg Pretend) "Only pretend to build packages." , Option [] ["no-deep"] (NoArg NoDeep) @@ -190,7 +196,9 @@ where pmList = unlines . map ((++) " * ") $ definedPMs defPM = "The last valid value of PM specified is chosen.\n\ - \The default package manager is: " ++ defaultPMName + \The default package manager is: " ++ defaultPMName ++ ",\n\ + \which can be overriden with the \"PACKAGE_MANAGER\"\n\ + \environment variable." -- ----------------------------------------------------------------------------- -- Printing information. @@ -220,15 +228,16 @@ \\n\ \Options:" -systemInfo :: IO () -systemInfo = do ver <- ghcVersion - pName <- getProgName - pLoc <- ghcLoc - libDir <- ghcLibDir - putStrLn $ "Running " ++ pName ++ " using GHC " ++ ver - putStrLn $ " * Executable: " ++ pLoc - putStrLn $ " * Library directory: " ++ libDir - putStrLn "" +systemInfo :: RunModifier -> IO () +systemInfo rm = do ver <- ghcVersion + pName <- getProgName + pLoc <- ghcLoc + libDir <- ghcLibDir + putStrLn $ "Running " ++ pName ++ " using GHC " ++ ver + putStrLn $ " * Executable: " ++ pLoc + putStrLn $ " * Library directory: " ++ libDir + putStrLn $ " * Package manager: " ++ nameOfPM (pkgmgr rm) + putStrLn "" -- ----------------------------------------------------------------------------- -- Utility functions diff --git a/haskell-updater.cabal b/haskell-updater.cabal --- a/haskell-updater.cabal +++ b/haskell-updater.cabal @@ -1,6 +1,6 @@ Name: haskell-updater Homepage: http://haskell.org/haskellwiki/Gentoo#haskell-updater -Version: 1.0.0.0 +Version: 1.1.0.0 Synopsis: Rebuild Haskell dependencies in Gentoo Description: haskell-updater rebuilds Haskell packages on Gentoo after a GHC upgrade or a dependency upgrade. @@ -16,14 +16,20 @@ Copyright: (c) Ivan Lazar Miljenovic, Lennart Kolmodin, Stephan Friedrichs + Emil Karlson Author: Ivan Lazar Miljenovic, Lennart Kolmodin, Stephan Friedrichs + Emil Karlson Maintainer: Ivan.Miljenovic@gmail.com -Cabal-Version: >= 1.2 +Cabal-Version: >= 1.6 Build-Type: Simple Extra-Source-Files: TODO +Source-Repository head + Type: darcs + Location: http://code.haskell.org/gentoo/haskell-updater/ + Executable haskell-updater { Main-Is: Main.hs @@ -35,8 +41,8 @@ Ghc-Options: -Wall Ghc-Prof-Options: -auto-all - Build-Depends: base >= 3 && < 5, - Cabal >= 1.8 && < 1.9, + Build-Depends: base == 4.*, + Cabal == 1.8.*, containers < 0.4, filepath < 1.2, directory < 1.1,