{- |
Module : Main
Description : The haskell-updater executable
Copyright : (c) Ivan Lazar Miljenovic, Stephan Friedrichs, Emil Karlson 2010
License : GPL-2 or later
Maintainer : Ivan.Miljenovic@gmail.com
The executable module of haskell-updater, which finds Haskell
packages to rebuild after a dep upgrade or a GHC upgrade.
-}
module Main where
import Distribution.Gentoo.GHC
import Distribution.Gentoo.Packages
import Distribution.Gentoo.PkgManager
import Data.Either(partitionEithers)
import Data.List(foldl1')
import Data.Version(showVersion)
import qualified Data.Set as Set
import Data.Set(Set)
import qualified Paths_haskell_updater as Paths(version)
import System.Console.GetOpt
import System.Environment(getArgs, getProgName)
import System.Exit(ExitCode(..), exitWith)
import System.IO(hPutStrLn, stderr)
import Control.Monad(liftM, liftM2, unless)
import System.Process(system)
-- -----------------------------------------------------------------------------
-- The overall program.
main :: IO ()
main = uncurry runAction =<< parseArgs
-- -----------------------------------------------------------------------------
-- The possible actions that haskell-updater can perform.
data Action = Help
| Version
| Build { targets :: Set BuildTarget }
-- If anything is added here after Build, MAKE SURE YOU
-- UPDATE combineActions or it won't always work!
deriving (Eq, Ord, Show, Read)
defaultAction :: Action
defaultAction = Build $ Set.fromList [GhcUpgrade, DepCheck]
-- Combine all the actions together. If the list is empty, use the
-- defaultAction.
combineAllActions :: [Action] -> Action
combineAllActions = emptyElse defaultAction (foldl1' combineActions)
-- Combine two actions together. If they're both Build blah, merge
-- them; otherwise, pick the lower of the two (i.e. more important).
-- Note that it's safe (at the moment at least) to assume that when
-- the lower of one is a Build that they're both build.
combineActions :: Action -> Action -> Action
combineActions a1 a2 = case (a1 `min` a2) of
Build{} -> Build $ targets a1 `Set.union` targets a2
a -> a
runAction :: RunModifier -> Action -> IO a
runAction _ Help = help
runAction _ Version = version
runAction rm (Build ts) = do systemInfo rm
ps <- allGetPackages ts
buildPkgs rm ps
-- -----------------------------------------------------------------------------
-- The possible things to build.
data BuildTarget = GhcUpgrade
| DepCheck
deriving (Eq, Ord, Show, Read)
getPackages :: BuildTarget -> IO [Package]
getPackages GhcUpgrade = oldGhcPkgs
getPackages DepCheck = brokenPkgs
getPackages' :: BuildTarget -> IO (Set Package)
getPackages' = liftM Set.fromList . getPackages
allGetPackages :: Set BuildTarget -> IO [Package]
allGetPackages = liftM (Set.toList . Set.unions)
. mapM getPackages'
. Set.toList
-- -----------------------------------------------------------------------------
-- How to build packages.
data RunModifier = RM { pkgmgr :: PkgManager
, flags :: [PMFlag]
, withCmd :: WithCmd
}
deriving (Eq, Ord, Show, Read)
-- At the moment, PrintAndRun is the only option available.
data WithCmd = RunOnly
| PrintOnly
| PrintAndRun
deriving (Eq, Ord, Show, Read)
runCmd :: WithCmd -> String -> IO a
runCmd RunOnly = runCommand
runCmd PrintOnly = success
runCmd PrintAndRun = liftM2 (>>) putStrLn runCommand
runCommand :: String -> IO a
runCommand cmd = system cmd >>= exitWith
buildPkgs :: RunModifier -> [Package] -> IO a
buildPkgs _ [] = success "\nNothing to build!"
buildPkgs rm ps = runCmd (withCmd rm) cmd
where
cmd = buildCmd (pkgmgr rm) (flags rm) ps
-- -----------------------------------------------------------------------------
-- Command-line flags
data Flag = HelpFlag
| VersionFlag
| PM String
| CustomPMFlag String
| Check
| Upgrade
| Pretend
| NoDeep
deriving (Eq, Ord, Show, Read)
parseArgs :: IO (RunModifier, Action)
parseArgs = do args <- getArgs
defPM <- defaultPM
argParser defPM $ getOpt Permute options args
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 isValidPM pms
pm = emptyElse dPM last pms'
opts' = Set.fromList opts
hasFlag = flip Set.member opts'
pmFlags = bool id (PretendBuild:) (hasFlag Pretend)
. return $ bool UpdateDeep UpdateAsNeeded (hasFlag NoDeep)
rm = RM { pkgmgr = pm
, flags = pmFlags
-- We need to get Flags that represent this as well.
, withCmd = PrintAndRun
}
argParser _ (_, _, errs) = die $ unwords $ "Errors in arguments:" : errs
flagToAction :: Flag -> Either Flag Action
flagToAction HelpFlag = Right Help
flagToAction VersionFlag = Right Version
flagToAction Check = Right . Build $ Set.singleton DepCheck
flagToAction Upgrade = Right . Build $ Set.singleton GhcUpgrade
flagToAction 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 =
[ Option ['c'] ["dep-check"] (NoArg Check)
"Check dependencies of Haskell packages."
, Option ['u'] ["upgrade"] (NoArg Upgrade)
"Rebuild Haskell packages after a GHC upgrade."
, 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)
"Don't pull deep dependencies (--deep with emerge)."
, Option ['v'] ["version"] (NoArg VersionFlag)
"Version information."
, Option ['h', '?'] ["help"] (NoArg HelpFlag)
"Print this help message."
]
where
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."
-- -----------------------------------------------------------------------------
-- Printing information.
help :: IO a
help = progInfo >>= success
version :: IO a
version = fmap (++ '-' : showVersion Paths.version) getProgName >>= success
err :: String -> IO a
err msg = liftM addMsg progInfo >>= die
where
addMsg str = msg ++ "\n\n"++ str
progInfo :: IO String
progInfo = do pName <- getProgName
return $ usageInfo (header pName) options
where
header pName = pName ++ " -- Find and rebuild packages broken due to either:\n\
\ * GHC upgrade\n\
\ * Haskell dependency upgrade\n\
\ Default action is to do both.\n\
\\n\
\Usage: " ++ pName ++ " [Option]\n\
\\n\
\\n\
\Options:"
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
success :: String -> IO a
success msg = do putStrLn msg
exitWith ExitSuccess
die :: String -> IO a
die msg = do putErrLn msg
exitWith (ExitFailure 1)
putErrLn :: String -> IO ()
putErrLn = hPutStrLn stderr
bool :: a -> a -> Bool -> a
bool f t b = if b then t else f
partitionBy :: (a -> Either l r) -> [a] -> ([l], [r])
partitionBy f = partitionEithers . map f
-- If the list is empty, return the provided value; otherwise use the function.
emptyElse :: b -> ([a] -> b) -> [a] -> b
emptyElse e _ [] = e
emptyElse _ f as = f as