{- |
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.
-}
module Main (main) where
import Distribution.Gentoo.GHC
import Distribution.Gentoo.Packages
import Distribution.Gentoo.PkgManager
import Distribution.Gentoo.Util
import Control.Monad (liftM, unless)
import Data.Char (toLower)
import Data.Either (partitionEithers)
import Data.List (foldl1', nub)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromJust)
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
-- -----------------------------------------------------------------------------
-- The overall program.
main :: IO ()
main = do args <- getArgs
defPM <- defaultPM
case parseArgs defPM args of
Left err -> die err
Right a -> uncurry runAction a
-- -----------------------------------------------------------------------------
-- The possible actions that haskell-updater can perform.
data Action = Help
| Version
| Build { targets :: Set.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
Help -> Help
Version -> Version
Build{} -> Build $ targets a1 `Set.union` targets a2
runAction :: RunModifier -> Action -> IO a
runAction rm action =
case action of
Help -> help
Version -> version
Build ts -> do systemInfo v rm
ps <- allGetPackages v ts
if listOnly rm
then mapM_ (putStrLn . printPkg) ps
else buildPkgs rm ps
success v "done!"
where v = verbosity rm
-- -----------------------------------------------------------------------------
-- The possible things to build.
data BuildTarget = GhcUpgrade
| DepCheck
| AllInstalled
deriving (Eq, Ord, Show, Read)
getPackages :: Verbosity -> BuildTarget -> IO [Package]
getPackages v target =
case target of
GhcUpgrade -> do say v "Searching for packages installed with a different version of GHC."
say v ""
pkgs <- oldGhcPkgs v
pkgListPrintLn v "old" pkgs
return pkgs
AllInstalled -> do say v "Searching for packages installed with the current version of GHC."
say v ""
pkgs <- allInstalledPackages
pkgListPrintLn v "installed" pkgs
return pkgs
DepCheck -> do say v "Searching for Haskell libraries with broken dependencies."
say v ""
(pkgs, unknown_packages, unknown_files) <- brokenPkgs v
printUnknownPackagesLn (map unCPV unknown_packages)
printUnknownFilesLn unknown_files
pkgListPrintLn v "broken" (notGHC pkgs)
return pkgs
where 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`"
say v $ " # ghc-pkg recache"
say v $ " It will likely need one more 'haskell-updater' run."
say v ""
allGetPackages :: Verbosity -> Set.Set BuildTarget -> IO [Package]
allGetPackages v = liftM nub
. concatMapM (getPackages v)
. Set.toList
-- -----------------------------------------------------------------------------
-- How to build packages.
data RunModifier = RM { pkgmgr :: PkgManager
, flags :: [PMFlag]
, withCmd :: WithCmd
, rawPMArgs :: [String]
, verbosity :: Verbosity
, listOnly :: Bool
}
deriving (Eq, Ord, Show, Read)
-- At the moment, PrintAndRun is the only option available.
data WithCmd = RunOnly
| PrintOnly
| PrintAndRun
deriving (Eq, Ord, Show, Read)
type WithUserCmd = Either String WithCmd
withCmdMap :: Map String WithCmd
withCmdMap = M.fromList [ ("print", PrintOnly)
, ("run", RunOnly)
, ("print-and-run", PrintAndRun)
]
defaultWithCmd :: String
defaultWithCmd = "print-and-run"
runCmd :: WithCmd -> String -> [String] -> IO a
runCmd mode cmd args = case mode of
RunOnly -> runCommand cmd args
PrintOnly -> putStrLn cmd_line >> exitSuccess
PrintAndRun -> putStrLn cmd_line >> runCommand cmd args
where cmd_line = unwords (cmd:args)
runCommand :: String -> [String] -> IO a
runCommand cmd args = rawSystem cmd args >>= exitWith
buildPkgs :: RunModifier -> [Package] -> IO a
buildPkgs rm [] = success (verbosity rm) "\nNothing to build!"
buildPkgs rm ps = runCmd (withCmd rm) cmd args
where
(cmd, args) = buildCmd (pkgmgr rm) (flags rm) (rawPMArgs rm) ps
-- -----------------------------------------------------------------------------
-- Command-line flags
data Flag = HelpFlag
| VersionFlag
| PM String
| CustomPMFlag String
| Check
| Upgrade
| RebuildAll
| Pretend
| NoDeep
| QuietFlag
| VerboseFlag
| ListOnlyFlag
| Cmd String
deriving (Eq, Ord, Show, Read)
parseArgs :: PkgManager -> [String] -> Either String (RunModifier, Action)
parseArgs defPM args = argParser defPM $ getOpt' Permute options args
argParser :: PkgManager
-> ([Flag], [String], [String], [String])
-> Either String (RunModifier, Action)
argParser dPM (fls, nonoptions, unrecognized, errs)
| (not . null) errs = Left $ unwords $ "Errors in arguments:" : errs
| (not . null) unrecognized = Left $ unwords $ "Unknown options:" : unrecognized
| (not . null) bPms = Left $ unwords $ "Unknown package managers:" : bPms
| (not . null) bCmds = Left $ unwords $ "Unknown action:" : bCmds
| otherwise = Right (rm, a)
where
(fls', as) = partitionBy flagToAction fls
a = combineAllActions as
(fls'', pms) = partitionBy flagToPM fls'
(bPms, pms') = partitionBy isValidPM pms
(opts, cmds') = partitionBy flagToCmd fls''
(bCmds, cmds) = partitionBy isValidCmd cmds'
pm = emptyElse dPM last pms'
opts' = Set.fromList opts
cmd = emptyElse (fromJust $ M.lookup defaultWithCmd withCmdMap) last cmds
hasFlag = flip Set.member opts'
pmFlags = bool (PMQuiet:) id (hasFlag QuietFlag)
. bool id (PretendBuild:) (hasFlag Pretend)
. return $ bool UpdateDeep UpdateAsNeeded (hasFlag NoDeep)
rm = RM { pkgmgr = pm
, flags = pmFlags
, withCmd = cmd
, rawPMArgs = nonoptions
, verbosity = case () of
_ | hasFlag VerboseFlag -> Verbose
_ | hasFlag QuietFlag -> Quiet
_ -> Normal
, listOnly = hasFlag ListOnlyFlag
}
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 RebuildAll = Right . Build $ Set.singleton AllInstalled
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
flagToCmd :: Flag -> Either Flag WithUserCmd
flagToCmd (Cmd cmd) = Right $ chooseCmd cmd
flagToCmd f = Left f
chooseCmd :: String -> WithUserCmd
chooseCmd cmd = chooseCmd' $ map toLower cmd
where
chooseCmd' :: String -> WithUserCmd
chooseCmd' "run" = Right RunOnly
chooseCmd' "print" = Right PrintOnly
chooseCmd' "print-and-run" = Right PrintAndRun
chooseCmd' c = Left c
isValidCmd :: WithUserCmd -> Either String WithCmd
isValidCmd = id
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 ['a'] ["all"] (NoArg RebuildAll)
"Rebuild all Haskell libraries built with current GHC."
, 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 ['l'] ["list-only"] (NoArg ListOnlyFlag)
"Output only list of packages for rebuild. One package per line."
, Option ['V'] ["version"] (NoArg VersionFlag)
"Version information."
, Option [] ["action"] (ReqArg Cmd "action")
$ "Specify whether to run the PM command or just print it\n"
++ actionList ++ defAction
, Option ['q'] ["quiet"] (NoArg QuietFlag)
"Print only fatal errors (to stderr)."
, Option ['v'] ["verbose"] (NoArg VerboseFlag)
"Be more elaborate (to stderr)."
, 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."
actionList = unlines . map (" * " ++) $ M.keys withCmdMap
defAction = "The last specified action is chosen.\n\
\The default action is: " ++ defaultWithCmd
-- -----------------------------------------------------------------------------
-- 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 either:"
, " * GHC upgrade"
, " * Haskell dependency upgrade"
, " Default action is to do both."
, ""
, "Usage: " ++ pName ++ " [Options [-- [PM options]]"
, ""
, ""
, "Options:"]
systemInfo :: Verbosity -> RunModifier -> IO ()
systemInfo v rm = 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 (pkgmgr rm)
unless (null (rawPMArgs rm)) $
say v $ " * PM auxiliary arguments: " ++ unwords (rawPMArgs rm)
say v ""
-- -----------------------------------------------------------------------------
-- 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
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