diff --git a/HACKING.md b/HACKING.md deleted file mode 100644 --- a/HACKING.md +++ /dev/null @@ -1,28 +0,0 @@ -# Hacking on Hackager - -Source files: - - * `Hackager.hs` -- Main entry point, parses command line arguments. - * `Record.hs` -- Entry point for record (build) mode. - * `HackageMonad.hs` -- Monad and support for build mode. Monad is `Hkg`, a - state monad with state `HkgState`. - * `RecordOptions.hs` -- Parses command line flags for record mode. - * `BuildManager.hs` -- Orchestrates building all packages. - * `Build.hs` -- Handles building a single package. - * `BuildTools.hs` -- Wrappers to run various external build tools. - - * `Report.hs` -- Entry point for report mode. - - * `Parallel.hs` -- Handles parallelizing Hackager. - * `Utils.hs` -- Misc functions. - -Building Process: - - 1) Parse command line flags - 2) Get list of packages to build, either from command line or all of hackage. - 3) Create the needed build directory structure. - 4) Run `cabal install --dry-run` on each package first to see if installable. - 5) Run `cabal install` for each installable package. Do so in a new and - temporary package configuration. - 6) Dump all results. - diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# Hackager [![Hackage version](https://img.shields.io/hackage/v/hackager.svg?style=flat)](https://hackage.haskell.org/package/hackager) [![Build Status](https://img.shields.io/travis/dterei/hackager.svg?style=flat)](https://travis-ci.org/dterei/hackager) +# Hackager Hackager is a tool to compile all of the Haskell Hackage package repository. This is useful for testing Haskell compilers. @@ -76,18 +76,3 @@ * Package configure scripts will be run * Custom Setup.hs programs will be run -## Get involved! - -We are happy to receive bug reports, fixes, documentation -enhancements, and other improvements. - -Please report bugs via the -[github issue tracker](http://github.com/dterei/Hackager/issues). - -Master [git repository](http://github.com/dterei/Hackager): - -* `git clone git://github.com/dterei/Hackager.git` - -## Licensing - -This library is BSD-licensed. diff --git a/TODO.md b/TODO.md --- a/TODO.md +++ b/TODO.md @@ -2,5 +2,4 @@ * Improve error handling when cabal fails (especially 'cabal list') * Move to another method than 'cabal list' to get package list -* Ability to kill when running... diff --git a/hackager.cabal b/hackager.cabal --- a/hackager.cabal +++ b/hackager.cabal @@ -1,12 +1,12 @@ Name: hackager -Version: 0.2.0.0 +Version: 1.0.0 Synopsis: Hackage testing tool Description: Hackager is a program for compiling the entirety of Hackage as a way of testing a Haskell compiler. Category: Compiler, GHC, Testing -Author: The GHC Team, David Terei -Maintainer: David Terei +Author: The GHC Team, David Terei +Maintainer: David Terei Homepage: https://github.com/dterei/Hackager Bug-Reports: https://github.com/dterei/Hackager/issues License: BSD3 @@ -14,7 +14,7 @@ Stability: Stable Build-Type: Simple -Extra-Source-Files: README.md, TODO.md, HACKING.md +Extra-Source-Files: README.md, TODO.md Cabal-Version: >= 1.6 Source-Repository head @@ -23,17 +23,8 @@ Executable hackager Main-Is: Hackager.hs - Other-Modules: Build - BuildManager - BuildTools - HackageMonad - Parallel - Record - RecordOptions - Report - Utils HS-Source-Dirs: src - Ghc-Options: -threaded -Wall + Ghc-Options: -threaded Build-Depends: base >= 2 && < 5, Cabal, containers, diff --git a/src/Build.hs b/src/Build.hs deleted file mode 100644 --- a/src/Build.hs +++ /dev/null @@ -1,190 +0,0 @@ --- | Operations on a single package. -module Build ( - PkgProcessor, - buildPkg, - statPkg - ) where - -import Control.Monad.State -import Data.Char (toUpper) -import Data.List -import Distribution.Package -import Distribution.Text -import System.Directory -import System.FilePath -import System.Exit (ExitCode(..)) - -import BuildTools -import HackageMonad -import Utils - --- | Setup a package database. -initialisePackageConf :: FilePath -> Hkg () -initialisePackageConf fp = do - liftIO . ignoreException $ removeFile fp - liftIO . ignoreException $ removeDirectoryRecursive fp - x <- runGhcPkg ["init", fp] - case x of - ExitSuccess -> return () - _ -> die ("Initialising package database in " ++ show fp ++ " failed") - --- | Type of a function that processes packages (and can be parallelized) -type PkgProcessor = Int -> Int -> PkgName -> Hkg () - --- | Build a single package. -buildPkg :: PkgProcessor -buildPkg npkgs i p = do - info $ "===> Building package " ++ p ++ " (" ++ show i ++ " of " - ++ show npkgs ++ ")" - - tmpPackageConf <- getTempPackageConf p - initialisePackageConf tmpPackageConf - - scratchDir <- getScratchDir p - liftIO . ignoreException $ removeDirectoryRecursive scratchDir - - rpath <- getRunPath - depFlags <- getDepFlags - pkgFlags <- getPkgFlags - basicFlags <- getBasicCabalFlags - - let -- we may generate thousands of files, so group by package first letter - -- for easier browsing. - groupDir = rpath "logs.build" [toUpper $ head p] - pkgPath = groupDir p - cabalLog = pkgPath <.> "cabal.log" - deplog = pkgPath "$pkgid.depends.log" - comFlags = basicFlags ++ - [ "--prefix=" ++ scratchDir - -- This is the package database that we - -- want cabal to register into: - , "--package-db=" ++ tmpPackageConf - -- But cabal can't be trusted to put its - -- --package-conf flag after ours, so we need - -- to repeat the package.conf we want to - -- register into again: - , "--ghc-pkg-option=--package-conf=" ++ tmpPackageConf - -- Only we want to display info to the user - ] - depArgs = [ "install", p - , "--only-dependencies" - , "--build-log=" ++ deplog - ] ++ comFlags ++ depFlags - - -- create directory structure - liftIO $ ignoreException $ createDirectory groupDir - liftIO $ createDirectory pkgPath - - -- try installing package dependencies - xDeps <- runCabalResults False depArgs - case xDeps of - Right _ -> do - let summaryName = pkgPath <.> "summary" - logName = pkgPath <.> "log" - pkgArgs = [ "install", p - , "--build-summary=" ++ summaryName - , "--build-log=" ++ logName - ] - ++ comFlags ++ pkgFlags - - -- try installing package - xPkg <- runCabalResults False pkgArgs - case xPkg of - Right _ -> buildSucceeded p - Left (_, out) -> toFile cabalLog out >> - buildFailed p - - Left (_, out) -> toFile cabalLog out >> - buildDepsFailed p - - -- clean up - rmScratchDir p - - where - toFile f strs = liftIO $ appendFile f (unlines strs) - --- | Find out what would happen if we installed the package. Running --- cabal-install in dry-run mode may tell us: --- * The package is uninstallable --- * The package is already installed --- * The package is installable, and which other packages we would have to --- install in order to install it --- * Something we don't understand -statPkg :: PkgProcessor -statPkg npkgs i pkg = do - info $ "===> Getting stats for: " ++ pkg ++ " (" ++ show i ++ " of " - ++ show npkgs ++ ")" - - rpath <- getRunPath - basicFlags <- getBasicCabalFlags - pkgFlags <- getPkgFlags - - let resultDir = rpath "logs.stats" [toUpper $ head pkg] - resultName = resultDir pkg <.> "result" - args = basicFlags ++ pkgFlags ++ - [ "install", "--dry-run", "--reinstall", "--global" - , pkg ] - - -- create directory structure - liftIO $ ignoreException $ createDirectory resultDir - - -- Ideally cabal would have written out some - -- sort of log, but it seems not to do so in dry-run - -- mode, so we do so ourselves - e <- runCabalResults True args - case e of - Left (ec, ls) -> do - let resultsLines = "FAILED" - : ("Exit code: " ++ show ec) - : ls - liftIO $ writeFile resultName $ unlines resultsLines - addNotInstallablePackage pkg - info $ "===> " ++ pkg ++ " is not installable, skipping!" - when (notUpdated resultsLines) $ - die "===> Errror: You need to run 'cabal update' first!" - - Right ls -> do - let resultsLines = "SUCCEEDED" : ls - liftIO $ writeFile resultName $ unlines resultsLines - case break (listHeaderPrefix `isPrefixOf`) ls of - (_, _ : ls1) -> do - ls2 <- mapM mangleLine ls1 - case reverse ls2 of - thisP : otherPs | toU thisP == toU pkg -> do - addInstallablePackage pkg - mapM_ addInstall otherPs - - _ -> die ("Installing " ++ show pkg ++ - " doesn't end by installing it") - - _ | any (noPackagesPrefix `isPrefixOf`) ls - -> addInstalledPackage pkg - - | otherwise - -> do warn $ "Don't understand result for " ++ show pkg - addFailPackage pkg - - where - toU = map toUpper - notUpdated = any (isPrefixOf "Stderr: Run 'cabal update'") - - listHeaderPrefix = "In order, the following would be installed" - noPackagesPrefix = "No packages to be installed." - mangleLine l = case simpleParse . takeWhile (/= ' ') $ l of - Nothing -> - die ("Unparseable line: " ++ show l) - Just (PackageIdentifier (PackageName pn) _) -> - return pn - --- | Get the default cabal flags to use. -getBasicCabalFlags :: Hkg [String] -getBasicCabalFlags = do - ghc <- getGhc - ghcPkg <- getGhcPkg - cFlags <- getCabalFlags - return $ [ "--remote-build-reporting=none" - , "--ghc" - , "--with-ghc=" ++ ghc - , "--with-ghc-pkg=" ++ ghcPkg - ] ++ cFlags - diff --git a/src/BuildManager.hs b/src/BuildManager.hs deleted file mode 100644 --- a/src/BuildManager.hs +++ /dev/null @@ -1,87 +0,0 @@ --- | Handle building a set of packages (usually all of Hackage) -module BuildManager ( - setupBuildDir, - getAllHackage, - tryBuildingPackages - ) where - -import Control.Concurrent -import Control.Monad -import Control.Monad.State -import System.Directory -import System.FilePath - -import Build -import BuildTools -import HackageMonad -import Parallel -import Utils - --- | Setup the needed directory structure. -setupBuildDir:: Hkg () -setupBuildDir = do - rpath <- getRunPath - exists <- liftIO $ doesDirectoryExist rpath - if exists - then die (show rpath ++ " already exists, not overwriting") - else liftIO $ do - createDirectory rpath - createDirectory (rpath "logs.stats") - createDirectory (rpath "logs.build") - --- | Get a list of all packages on hackage. -getAllHackage :: Hkg [PkgName] -getAllHackage = do - info "===> Grabbing a list of all packages on hackage..." - m <- runCabalResults False ["list", "--simple-output", "-v0"] - -- m: abc 0.0.1 - -- abc 0.0.2 - -- dff 0.1.2 - -- ... - case m of - Left (_, out) -> die $ "Failed to get package list: " ++ unlines out - Right xs -> - let ls = map (takeWhile (' ' /=)) xs - ps = uniq $ filter (not . null) ls - in return ps - --- | Loop over given packages and try to build each of them, recording the --- results. -tryBuildingPackages :: [PkgName] -> Hkg () -tryBuildingPackages ps = do - let n = length ps - info $ "===> Testing against " ++ show n ++ " packages..." - runOnAllPkgs ps statPkg - dumpStats n - psAll <- getInstallablePackages - runOnAllPkgs psAll buildPkg - dumpResults - rmAllScratch - info $ "===> Hackager finished! (" ++ show n ++ " packages tested)" - --- | Run in parallel a PkgProcessor function over the given list --- of packages with the specified number of threads. -runOnAllPkgs :: [PkgName] -> PkgProcessor -> Hkg () -runOnAllPkgs pkgs pkgFun = do - nthreads <- getThreads - mpkgs <- liftIO . newMVar $ zip [1..] pkgs - let runner = builder pkgFun (length pkgs) mpkgs - children <- replicateM nthreads $ forkChild runner - waitForChildren children - info "" - info "" - --- | Function to go through a package list and build them. Thread safe so can --- be forked as child processes. -builder :: PkgProcessor -> Int -> MVar [(Int, PkgName)] -> Hkg () -builder pkgFun n mpkgs = go - where - go = do - pkgs <- liftIO $ takeMVar mpkgs - case pkgs of - [] -> liftIO $ putMVar mpkgs [] - ((i, p) : ps) -> do - liftIO $ putMVar mpkgs ps - pkgFun n i p - go - diff --git a/src/BuildTools.hs b/src/BuildTools.hs deleted file mode 100644 --- a/src/BuildTools.hs +++ /dev/null @@ -1,88 +0,0 @@ --- | Wrappers to run various build tools needed. -module BuildTools ( - runCabal, runCabalResults, runGhcPkg - ) where - -import Control.Concurrent -import Control.Monad.State -import Control.Exception -import System.Exit (ExitCode(..)) -import System.IO -import System.Process - -import HackageMonad -import Utils - --- | Run cabal. -runCabal :: [String] -> Hkg ExitCode -runCabal args = do - cabal <- getCabal - liftIO $ rawSystem cabal args - --- | Run cabal returning the resulting output or error code --- * Bool: Treat any stderr output as evidence that cabal failed --- * [String]: The cabal arguments -runCabalResults :: Bool -> [String] -> Hkg (Either (ExitCode, [String]) [String]) -runCabalResults errFail args = do - cabal <- getCabal - runCmdGetResults errFail cabal args - --- | Run ghc-pkg. -runGhcPkg :: [String] -> Hkg ExitCode -runGhcPkg args = do - ghcPkg <- getGhcPkg - liftIO $ rawSystem ghcPkg args - -data StdLine = Stdout String | Stderr String - --- | Run a cmd returning the fullresults. --- * Bool: Treat any stderr output as evidence the cmd failed --- * FilePath: The program to run --- * [String]: The program arguments -runCmdGetResults :: Bool -> FilePath -> [String] - -> Hkg (Either (ExitCode, [String]) [String]) -runCmdGetResults errFail prog args = liftIO $ do - (hIn, hOut, hErr, ph) <- runInteractiveProcess prog args Nothing Nothing - hClose hIn - linesMVar <- newEmptyMVar - lineMVar <- newEmptyMVar - let getLines h c = do l <- hGetLine h - putMVar lineMVar (Just (c l)) - getLines h c - - writeLines :: Int -- how many of stdout and stderr are till open - -> [StdLine] -> IO () - writeLines 0 ls = putMVar linesMVar (reverse ls) - writeLines n ls = do mLine <- takeMVar lineMVar - case mLine of - Just line -> writeLines n (line : ls) - Nothing -> writeLines (n - 1) ls - - _ <- forkIO $ (hSetBuffering hOut LineBuffering >> - getLines hOut Stdout `onEndOfFile` return ()) - `finally` - putMVar lineMVar Nothing - - _ <- forkIO $ (hSetBuffering hErr LineBuffering >> - getLines hErr Stderr `onEndOfFile` return ()) - `finally` - putMVar lineMVar Nothing - - _ <- forkIO $ writeLines 2 [] - - ec <- waitForProcess ph - ls <- takeMVar linesMVar - return $ case (ec, errFail && any isStderr ls) of - (ExitSuccess, False) -> Right $ map stripResultLine ls - _ -> Left (ec, map mkResultLine ls) - - where - isStderr (Stdout _) = False - isStderr (Stderr _) = True - - stripResultLine (Stdout l) = l - stripResultLine (Stderr l) = l - - mkResultLine (Stdout l) = "Stdout: " ++ l - mkResultLine (Stderr l) = "Stderr: " ++ l - diff --git a/src/HackageMonad.hs b/src/HackageMonad.hs deleted file mode 100644 --- a/src/HackageMonad.hs +++ /dev/null @@ -1,344 +0,0 @@ --- | Monad for Hackage Test. Just a simple state passing monad with appropriate --- getter and setters. -module HackageMonad ( - PkgName, Hkg, HkgState, startState, - - getTempPackageConf, getScratchDir, rmScratchDir, rmAllScratch, - - setRunPath, getRunPath, getCabal, setCabal, getGhc, setGhc, getGhcPkg, - setGhcPkg, getCabalFlags, setCabalFlags, getDepFlags, setDepFlags, - getPkgFlags, setPkgFlags, addPkg, getPkgs, - - setThreads, getThreads, - - addInstall, addInstalledPackage, addInstallablePackage, - addNotInstallablePackage, addFailPackage, getInstallablePackages, - buildSucceeded, buildFailed, buildDepsFailed, - - dumpStats, dumpResults, - - info, warn, die - ) where - -import Control.Concurrent (MVar, newMVar) -import qualified Control.Concurrent as C -import Control.Monad.State -import Data.Function -import Data.List -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import System.Directory -import System.FilePath -import System.Exit (exitWith, ExitCode(..)) -import System.IO - -import Utils - -type PkgName = String - -type Hkg = StateT HkgState IO - --- | The state of Hackager -data HkgState = HkgState { - -- These are set based on the command line flags - st_dir :: FilePath, - st_cabal :: FilePath, - st_ghc :: FilePath, - st_ghcPkg :: FilePath, - st_cabFlags :: [String], - st_depFlags :: [String], - st_pkgFlags :: [String], - st_threads :: Int, - st_pkgs :: Set PkgName, - - -- These are set by the stats-collection pass: - st_installedPackages :: MVar (Set PkgName), - st_installablePackages :: MVar (Set PkgName), - st_notInstallablePackages :: MVar (Set PkgName), - st_failPackages :: MVar (Set PkgName), - st_installCounts :: MVar (Map PkgName Int), - - -- These are set by the installation pass: - st_buildablePackages :: MVar (Set PkgName), - st_buildFailurePackages :: MVar (Set PkgName), - st_buildDepFailurePackages :: MVar (Set PkgName), - - -- internal locks for making stdout thread safe - st_iolock :: MVar () - } - -startState :: IO HkgState -startState = do - ipkgs <- newMVar Set.empty - apkgs <- newMVar Set.empty - npkgs <- newMVar Set.empty - fpkgs <- newMVar Set.empty - count <- newMVar Map.empty - bbpkgs <- newMVar Set.empty - bfpkgs <- newMVar Set.empty - bdpkgs <- newMVar Set.empty - iolock <- newMVar () - return HkgState { - st_dir = "", - st_cabal = "", - st_ghc = "", - st_ghcPkg = "", - st_cabFlags = [], - st_depFlags = [], - st_pkgFlags = [], - st_threads = 1, - st_pkgs = Set.empty, - st_installedPackages = ipkgs, - st_installablePackages = apkgs, - st_notInstallablePackages = npkgs, - st_failPackages = fpkgs, - st_installCounts = count, - st_buildablePackages = bbpkgs, - st_buildFailurePackages = bfpkgs, - st_buildDepFailurePackages = bdpkgs, - st_iolock = iolock - } - ------------------------------------------------- --- Helpers - -setRunPath :: FilePath -> Hkg () -setRunPath name = do - dir <- liftIO getCurrentDirectory - modify $ \st -> st { st_dir = dir name } - -getRunPath :: Hkg FilePath -getRunPath = gets st_dir - -getTempPackageConf :: PkgName -> Hkg FilePath -getTempPackageConf p = (<.> "package.conf") <$> getScratchDir p - -getScratchDir :: PkgName -> Hkg FilePath -getScratchDir p = ( "scratch" p) <$> getRunPath - -rmScratchDir :: PkgName -> Hkg () -rmScratchDir p = do - dir <- getRunPath - liftIO . ignoreException $ - removeDirectoryRecursive (dir "scratch" p) - -rmAllScratch :: Hkg () -rmAllScratch = do - dir <- getRunPath - liftIO . ignoreException $ removeDirectoryRecursive (dir "scratch") - -setCabal :: FilePath -> Hkg () -setCabal ci = modify $ \st -> st { st_cabal = ci } - -getCabal :: Hkg FilePath -getCabal = gets st_cabal - -setGhc :: FilePath -> Hkg () -setGhc ghc = modify $ \st -> st { st_ghc = ghc } - -getGhc :: Hkg FilePath -getGhc = gets st_ghc - -setGhcPkg :: FilePath -> Hkg () -setGhcPkg ghcPkg = modify $ \st -> st { st_ghcPkg = ghcPkg } - -getGhcPkg :: Hkg FilePath -getGhcPkg = gets st_ghcPkg - -setCabalFlags :: String -> Hkg () -setCabalFlags cf = modify $ \st -> st { st_cabFlags = parseFlags cf } - -getCabalFlags :: Hkg [String] -getCabalFlags = gets st_cabFlags - -setDepFlags :: String -> Hkg () -setDepFlags depFlags = modify $ \st -> st { st_depFlags = parseFlags depFlags } - -getDepFlags :: Hkg [String] -getDepFlags = gets st_depFlags - -setPkgFlags :: String -> Hkg () -setPkgFlags pkgFlags = modify $ \st -> st { st_pkgFlags = parseFlags pkgFlags } - -getPkgFlags :: Hkg [String] -getPkgFlags = gets st_pkgFlags - -addPkg :: String -> Hkg () -addPkg p = modify $ \st -> st { st_pkgs = Set.insert p (st_pkgs st) } - -getPkgs :: Hkg [String] -getPkgs = gets $ Set.toList . st_pkgs - -setThreads :: Int -> Hkg () -setThreads n = modify $ \st -> st { st_threads = n } - -getThreads :: Hkg Int -getThreads = gets st_threads - -parseFlags :: String -> [String] -parseFlags str = - case reads str of - [(flags, "")] -> flags - _ -> words str - -addInstall :: PkgName -> Hkg () -addInstall pn = do - st <- get - ics <- takeMVar $ st_installCounts st - let ics' = Map.insertWith (+) pn 1 ics - putMVar (st_installCounts st) ics' - -addInstalledPackage :: PkgName -> Hkg () -addInstalledPackage pkg = do - st <- get - s <- takeMVar $ st_installedPackages st - putMVar (st_installedPackages st) $ Set.insert pkg s - -addInstallablePackage :: PkgName -> Hkg () -addInstallablePackage pkg = do - st <- get - s <- takeMVar $ st_installablePackages st - putMVar (st_installablePackages st) $ Set.insert pkg s - -getInstallablePackages :: Hkg [PkgName] -getInstallablePackages = do - st <- get - s <- takeMVar $ st_installablePackages st - return $ Set.toList s - -addNotInstallablePackage :: PkgName -> Hkg () -addNotInstallablePackage pkg = do - st <- get - s <- takeMVar $ st_notInstallablePackages st - putMVar (st_notInstallablePackages st) $ Set.insert pkg s - -addFailPackage :: PkgName -> Hkg () -addFailPackage pkg = do - st <- get - s <- takeMVar $ st_failPackages st - putMVar (st_failPackages st) $ Set.insert pkg s - -buildSucceeded :: PkgName -> Hkg () -buildSucceeded pkg = do - st <- get - s <- takeMVar $ st_buildablePackages st - putMVar (st_buildablePackages st) $ Set.insert pkg s - -buildFailed :: PkgName -> Hkg () -buildFailed pkg = do - st <- get - s <- takeMVar $ st_buildFailurePackages st - putMVar (st_buildFailurePackages st) $ Set.insert pkg s - -buildDepsFailed :: PkgName -> Hkg () -buildDepsFailed pkg = do - st <- get - s <- takeMVar $ st_buildDepFailurePackages st - putMVar (st_buildDepFailurePackages st) $ Set.insert pkg s - -dumpStats :: Int -> Hkg () -dumpStats n = do - st <- get - ipkgs <- readMVar $ st_installedPackages st - apkgs <- readMVar $ st_installablePackages st - npkgs <- readMVar $ st_notInstallablePackages st - fpkgs <- readMVar $ st_failPackages st - count <- readMVar $ st_installCounts st - - let fullHistogram = sortBy (flip compare) (map swap $ Map.assocs count) - (manyHistogram, fewHistogram) = span ((>= 10) . fst) fullHistogram - total = sum $ map fst fullHistogram - summaryTable = [ ["Num packages" , show n] - , ["Installed packages" , show $ Set.size ipkgs] - , ["Installable packages" , show $ Set.size apkgs] - , ["Uninstallable packages" , show $ Set.size npkgs] - , ["Failed packages" , show $ Set.size fpkgs] - , ["Total reinstallations" , show total] - ] - - name <- getRunPath - liftIO $ do - writeFile (name "stats.full") - (unlines $ showCompleteHistogram fullHistogram) - writeFile (name "stats.many") - (unlines $ showCompleteHistogram manyHistogram) - writeFile (name "stats.few") - (unlines $ showSummaryHistogram fewHistogram) - writeFile (name "stats.summary") - (unlines $ showTable [rpad, rpad] summaryTable) - writeFile (name "installed-packages") - (unlines $ Set.toList ipkgs) - writeFile (name "installable-packages") - (unlines $ Set.toList apkgs) - writeFile (name "uninstallable-packages") - (unlines $ Set.toList npkgs) - writeFile (name "fail-packages") - (unlines $ Set.toList fpkgs) - writeFile (name "install-counts") - (unlines $ map show $ Map.assocs count) - - where - showCompleteHistogram hist = showTable [rpad, rpad] - [ [show count, pkg] - | (count, pkg) <- hist ] - showSummaryHistogram hist = - let hist' = groupBy (on (==) fst) hist - hist'' = [ [show $ fst $ head histogramRow, - show $ length histogramRow] - | histogramRow <- hist' ] - in showTable [rpad, rpad] - (["Number of reinstallations", - "Number of packages"] : - hist'') - -dumpResults :: Hkg () -dumpResults = do - st <- get - bpkgs <- readMVar $ st_buildablePackages st - fpkgs <- readMVar $ st_buildFailurePackages st - dpkgs <- readMVar $ st_buildDepFailurePackages st - rpath <- getRunPath - - liftIO $ writeFile (rpath "buildable") - (unlines $ Set.toList bpkgs) - liftIO $ writeFile (rpath "buildFailed") - (unlines $ Set.toList fpkgs) - liftIO $ writeFile (rpath "buildDepsFailed") - (unlines $ Set.toList dpkgs) - -takeMVar :: MVar a -> Hkg a -takeMVar m = liftIO $ C.takeMVar m - -putMVar :: MVar a -> a -> Hkg () -putMVar m v = liftIO $ C.putMVar m v - -readMVar :: MVar a -> Hkg a -readMVar m = liftIO $ C.readMVar m - --- | Print message to stdout. -info :: String -> Hkg () -info msg = do - l <- st_iolock <$> get - void $ takeMVar l - liftIO (putStrLn msg) - putMVar l () - --- | Print message to stderr. -warn :: String -> Hkg () -warn msg = do - l <- st_iolock <$> get - void $ takeMVar l - liftIO $ hPutStrLn stderr msg - putMVar l () - --- | Exit with error message. -die :: String -> Hkg a -die err = do - l <- st_iolock <$> get - void $ takeMVar l - liftIO $ hPutStrLn stderr err - putMVar l () - liftIO $ exitWith (ExitFailure 1) - diff --git a/src/Parallel.hs b/src/Parallel.hs deleted file mode 100644 --- a/src/Parallel.hs +++ /dev/null @@ -1,28 +0,0 @@ --- | Tools for running hackager on many cores. -module Parallel ( - Child, forkChild, waitForChildren, - ) where - -import Control.Concurrent -import Control.Monad.State -import Control.Exception - -import HackageMonad - --- | Children process signal -type Child = MVar () - --- | Fork a child and return an MVar that signals when the child is done. -forkChild :: Hkg () -> Hkg Child -forkChild hkg = do - mvar <- liftIO newEmptyMVar - st <- get - _ <- liftIO $ forkIO (evalStateT hkg st `finally` putMVar mvar ()) - return mvar - --- | Wait on a list of children to finish processing -waitForChildren :: [Child] -> Hkg () -waitForChildren [] = return () -waitForChildren (child : children) = do - liftIO $ takeMVar child - waitForChildren children diff --git a/src/Record.hs b/src/Record.hs deleted file mode 100644 --- a/src/Record.hs +++ /dev/null @@ -1,36 +0,0 @@ --- | Record tool. Build all of hackage. -module Record ( - record, - recordHelp - ) where - -import Control.Monad.State -import System.Exit -import System.IO - -import BuildManager -import HackageMonad -import RecordOptions - --- | Run the recording tool. -record :: [String] -> IO () -record args = do - st <- startState - evalStateT (recordST args) st - --- | Hackage Test (Monad). -recordST :: [String] -> Hkg () -recordST args = do - liftIO $ hSetBuffering stdout NoBuffering - case args of - [ ] -> liftIO $ recordHelp (ExitFailure 1) - ["--help"] -> liftIO $ recordHelp ExitSuccess - _ -> do - processArgs args - ps <- getPkgs - setupBuildDir - ps' <- case ps of - [] -> getAllHackage - _ -> return ps - tryBuildingPackages ps' - diff --git a/src/RecordOptions.hs b/src/RecordOptions.hs deleted file mode 100644 --- a/src/RecordOptions.hs +++ /dev/null @@ -1,154 +0,0 @@ --- | Parse all the option flags for the record command. -module RecordOptions ( - recordHelp, - processArgs - ) where - -import Control.Monad.State -import Data.Char (isDigit) -import System.Directory -import System.Exit (exitWith, ExitCode(..)) -import System.IO - -import HackageMonad - --- | Print usage information and exit -recordHelp :: ExitCode -> IO () -recordHelp exitCode = do - let out = case exitCode of - ExitSuccess -> putStrLn - ExitFailure 1 -> putStrLn - ExitFailure _ -> hPutStrLn stderr - mapM_ out - [ "usage: hackager record -o NAME [-c CABAL] [-g GHC] [-p GHC-PKG] [-a CABAL-FLAGS]" - , " [-d DEP-FLAGS] [-f PKG-FLAGS] [-n THREADS] [PKGS...]" - , "" - , " NAME A name by which the results of this hackager run will" - , " be referred, e.g. \"ghc-6.12.1\"" - , " CABAL The path to the cabal program to use" - , " GHC The path to the ghc program to use" - , " GHC-PKG The path to the ghc-pkg program to use" - , " CABAL-FLAGS Flags to pass to cabal during building" - , " e.g. -a [\"--ghc-option=-XFoo\",\"--ghc-option=-XBar\"]" - , " DEP-FLAGS The flags to use when compiling dependencies of a package" - , " e.g. -d [\"--ghc-option=-XFoo\",\"--ghc-option=-XBar\"]" - , " PKG-FLAGS The flags to use when compiling a package" - , " e.g. -f [\"--ghc-option=-XFoo\",\"--ghc-option=-XBar\"]" - , " THREADS Number of threads to use to build in parallel" - , " PKGS A list of packages to build. If not specified all of" - , " hackage is built" - ] - exitWith exitCode - --- | Parse all the option flags for the record command. -processArgs :: [String] -> Hkg () -processArgs [] = validateFlags -processArgs (('-':x):y:args) = processOpt x y >> processArgs args -processArgs args = parsePackages args >> validateFlags - --- | Parse an individual option flag -processOpt :: String -> String -> Hkg () -processOpt "o" name = do - checkNotSet getRunPath "output directory is already set" - checkNotOption name "the output directory is invalid" - exists <- liftIO $ doesDirectoryExist name - when exists $ die "The specified output directory already exists" - setRunPath name - -processOpt "c" cabal = do - checkNotSet getCabal "cabal program is already set" - checkNotOption cabal "cabal program is invalid" - checkExecutable cabal "cabal" - setCabal cabal - -processOpt "g" ghc = do - checkNotSet getGhc "ghc program is already set" - checkNotOption ghc "ghc program is invalid" - checkExecutable ghc "ghc" - setGhc ghc - -processOpt "a" cflags = do - checkNotSet getCabalFlags "cabal flags already set" - setCabalFlags cflags - -processOpt "p" ghcpkg = do - checkNotSet getGhcPkg "ghc-pkg program is already set" - checkNotOption ghcpkg "ghc-pkg is invalid" - checkExecutable ghcpkg "ghc-pkg" - setGhcPkg ghcpkg - -processOpt "d" depflags = do - checkNotSet getDepFlags "dependency flags already set" - setDepFlags depflags - -processOpt "f" pkgflags = do - checkNotSet getPkgFlags "package flags already set" - setPkgFlags pkgflags - -processOpt "n" threads = do - let n = toInt threads - case n of - Just n' -> setThreads n' - Nothing -> badflag "invalid thread number" - -processOpt o _ = badflag $ "Unknown option '-" ++ o ++ "'" - --- | Parse the package list at the end -parsePackages :: [String] -> Hkg () -parsePackages [] = return () -parsePackages (x:xs) = do - checkNotOption x $ "package '" ++ x ++ "' is not a valid package name" - addPkg x - parsePackages xs - --- | Validate all the flags needed have been set and are valid -validateFlags :: Hkg () -validateFlags = do - n <- getRunPath - when (n == "") $ badflag "output directory not set" - setExecutable getCabal setCabal "cabal" - setExecutable getGhc setGhc "ghc" - setExecutable getGhcPkg setGhcPkg "ghc-pkg" - --- | Set the executable to what's on the PATH if not set -setExecutable :: Hkg FilePath -> (FilePath -> Hkg ()) -> String -> Hkg () -setExecutable getx setx name = do - x <- getx - when (x == "") $ do - ci <- liftIO $ findExecutable name - case ci of - Nothing -> badflag $ "can't find " ++ name ++ " executable" - Just ci' -> setx ci' - --- | Make sure a file exists and is executable -checkExecutable :: String -> String -> Hkg () -checkExecutable f prog = do - b <- liftIO $ doesFileExist f - unless b $ badflag $ prog ++ " executable doesn't exist" - p <- liftIO $ getPermissions f - unless (executable p) $ badflag $ prog ++ " file is not executable" - --- | Make sure a flag hasn't been set before -checkNotSet :: Hkg [a] -> String -> Hkg () -checkNotSet getter errmsg = do - val <- getter - case val of - [] -> return () - _ -> badflag errmsg - --- | Check that a value isn't an option -checkNotOption :: String -> String -> Hkg () -checkNotOption ('-':_) errmsg = badflag errmsg -checkNotOption _ _ = return () - --- | Parse a string to an int -toInt :: String -> Maybe Int -toInt str | all isDigit str = Just $ read str - | otherwise = Nothing - --- | Throw an error message in the face of a bad flag -badflag :: String -> Hkg () -badflag errmsg = liftIO $ do - hPutStrLn stderr errmsg - recordHelp (ExitFailure 129) - diff --git a/src/Report.hs b/src/Report.hs deleted file mode 100644 --- a/src/Report.hs +++ /dev/null @@ -1,129 +0,0 @@ --- | Reporting tool. Perform a comparision of two Hackage Test runs. -module Report ( - report, - reportHelp - ) where - -import Control.Monad -import Data.Set (Set) -import qualified Data.Set as Set -import System.Directory -import System.Exit (exitWith, ExitCode(..)) -import System.FilePath -import System.IO - -import HackageMonad (PkgName) -import Utils - --- | Run the reporting tool. -report :: [String] -> IO () -report args = - case args of - [name1, name2] -> generate name1 name2 - ["--help" ] -> reportHelp ExitSuccess - [ ] -> reportHelp (ExitFailure 1) - _ -> reportHelp (ExitFailure 1) - --- | Print usage information and exit -reportHelp :: ExitCode -> IO () -reportHelp exitCode = do - mapM_ putStrLn - [ "usage: hackager report " - , "" - , " name1 The name of the first result" - , " name2 The name of the second result" - , "" - , "The two results are then compared with each other, the output" - , "is placed in the folder 'compare------'" - ] - exitWith exitCode - --- | Generate a Hackager comparison report -generate :: String -> String -> IO () -generate name1 name2 = do - let compName = "compare---" ++ name1 ++ "---" ++ name2 - - -- check valid input and outputs - n1exists <- doesDirectoryExist name1 - unless n1exists $ die ("'" ++ name1 ++ "' doesn't exists") - n2exists <- doesDirectoryExist name2 - unless n2exists $ die ("'" ++ name2 ++ "' doesn't exists") - exists <- doesDirectoryExist compName - when exists $ die ("The directoy '" ++ compName ++ - "' already exists, won't overwrite") - - ba1 <- readPkgList (name1 "buildable") - ba2 <- readPkgList (name2 "buildable") - bF1 <- readPkgList (name1 "buildFailed") - bF2 <- readPkgList (name2 "buildFailed") - dF1 <- readPkgList (name1 "buildDepsFailed") - dF2 <- readPkgList (name2 "buildDepsFailed") - - let all1 = ba1 `Set.union` bF1 `Set.union` dF1 - all2 = ba2 `Set.union` bF2 `Set.union` dF2 - -- Work out what was not tried by one build or the other - nt1 = all2 `Set.difference` all1 - nt2 = all1 `Set.difference` all2 - - ba1_ba2 = ba1 `Set.intersection` ba2 - ba1_bF2 = ba1 `Set.intersection` bF2 - ba1_dF2 = ba1 `Set.intersection` dF2 - ba1_nt2 = ba1 `Set.intersection` nt2 - bF1_ba2 = bF1 `Set.intersection` ba2 - bF1_bF2 = bF1 `Set.intersection` bF2 - bF1_dF2 = bF1 `Set.intersection` dF2 - bF1_nt2 = bF1 `Set.intersection` nt2 - dF1_ba2 = dF1 `Set.intersection` ba2 - dF1_bF2 = dF1 `Set.intersection` bF2 - dF1_dF2 = dF1 `Set.intersection` dF2 - dF1_nt2 = dF1 `Set.intersection` nt2 - nt1_ba2 = nt1 `Set.intersection` ba2 - nt1_bF2 = nt1 `Set.intersection` bF2 - nt1_dF2 = nt1 `Set.intersection` dF2 - nt1_nt2 = nt1 `Set.intersection` nt2 - - num s = show (Set.size s) - padders = [rpad, rpad, lpad, lpad, lpad, lpad] - table = [["", "", name1, "", "", ""], - ["", "", "Buildable", "Build failed", "Deps failed", "Not tried"], - [name2, "Buildable", num ba1_ba2, num bF1_ba2, num dF1_ba2, num nt1_ba2], - ["", "Build failed", num ba1_bF2, num bF1_bF2, num dF1_bF2, num nt1_bF2], - ["", "Deps failed", num ba1_dF2, num bF1_dF2, num dF1_dF2, num nt1_dF2], - ["", "Not tried", num ba1_nt2, num bF1_nt2, num dF1_nt2, num nt1_nt2]] - - createDirectory compName - mapM_ (writeResultFile compName) - [ ("buildable-buildable" , ba1_ba2) - , ("buildable-buildFailed" , ba1_bF2) - , ("buildable-depsFailed" , ba1_dF2) - , ("buildable-notTried" , ba1_nt2) - , ("buildFailed-buildable" , bF1_ba2) - , ("buildFailed-buildFailed" , bF1_bF2) - , ("buildFailed-depsFailed" , bF1_dF2) - , ("buildFailed-notTried" , bF1_nt2) - , ("depsFailed-buildable" , dF1_ba2) - , ("depsFailed-buildFailed" , dF1_bF2) - , ("depsFailed-depsFailed" , dF1_dF2) - , ("depsFailed-notTried" , dF1_nt2) - , ("notTried-buildable" , nt1_ba2) - , ("notTried-buildFailed" , nt1_bF2) - , ("notTried-depsFailed" , nt1_dF2) - , ("notTried-notTried" , nt1_nt2) - ] - writeFile (compName "summary") (unlines $ showTable padders table) - mapM_ putStrLn $ showTable padders table - --- | Write results to a file -writeResultFile :: FilePath -> (FilePath, Set PkgName) -> IO () -writeResultFile dir (f, set) = writeFile (dir f) (unlines $ Set.toList set) - --- | Read a list of packages from the file specified -readPkgList :: FilePath -> IO (Set PkgName) -readPkgList fp = do xs <- readFile fp - return $ Set.fromList $ lines xs - --- | Exit with an error -die :: String -> IO a -die err = do hPutStrLn stderr err - exitWith (ExitFailure 1) - diff --git a/src/Utils.hs b/src/Utils.hs deleted file mode 100644 --- a/src/Utils.hs +++ /dev/null @@ -1,49 +0,0 @@ --- | Utility functions. -module Utils ( - catchIO, ignoreException, onEndOfFile, - showTable, uniq, swap, lpad, rpad - ) where - -import qualified Control.Exception as E -import Data.List -import Prelude -import System.IO.Error - --- | Handle an IO exception. -catchIO :: IO a -> (E.IOException -> IO a) -> IO a -catchIO = E.catch - --- | Ignore any IO exception that arises. -ignoreException :: IO () -> IO () -ignoreException io = io `catchIO` \_ -> return () - --- | Perform some IO and execute the second argument on an EOF exception. -onEndOfFile :: IO a -> IO a -> IO a -onEndOfFile io io' = - io `E.catch` \e -> if isEOFError e then io' else E.throwIO e - --- | Filter out adjacent duplicate elements. -uniq :: Eq a => [a] -> [a] -uniq (x : y : xs) - | x == y = uniq (x : xs) -uniq (x : xs) = x : uniq xs -uniq [] = [] - --- | Swap elements of a tuple. -swap :: (a, b) -> (b, a) -swap (x, y) = (y, x) - --- | Show output in a tabular format. -showTable :: [Int -> String -> String] -> [[String]] -> [String] -showTable padders xss = - let lengths = map (maximum . map length) $ transpose xss - in map (unwords . zipWith3 id padders lengths) xss - --- | Pad the string with spaces before it. -lpad :: Int -> String -> String -lpad n s = replicate (n - length s) ' ' ++ s - --- | Pad the string with spaces after it. -rpad :: Int -> String -> String -rpad n s = s ++ replicate (n - length s) ' ' -