hackager 0.2.0.0 → 1.0.0
raw patch · 13 files changed
+6/−1164 lines, 13 filesdep ~Cabaldep ~basedep ~mtl
Dependency ranges changed: Cabal, base, mtl
Files
- HACKING.md +0/−28
- README.md +1/−16
- TODO.md +0/−1
- hackager.cabal +5/−14
- src/Build.hs +0/−190
- src/BuildManager.hs +0/−87
- src/BuildTools.hs +0/−88
- src/HackageMonad.hs +0/−344
- src/Parallel.hs +0/−28
- src/Record.hs +0/−36
- src/RecordOptions.hs +0/−154
- src/Report.hs +0/−129
- src/Utils.hs +0/−49
− HACKING.md
@@ -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.-
README.md view
@@ -1,4 +1,4 @@-# Hackager [](https://hackage.haskell.org/package/hackager) [](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.
TODO.md view
@@ -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...
hackager.cabal view
@@ -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 <code@davidterei.com>-Maintainer: David Terei <code@davidterei.com>+Author: The GHC Team, David Terei <dave.terei@gmail.com>+Maintainer: David Terei <dave.terei@gmail.com> 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,
− src/Build.hs
@@ -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-
− src/BuildManager.hs
@@ -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-
− src/BuildTools.hs
@@ -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-
− src/HackageMonad.hs
@@ -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)-
− src/Parallel.hs
@@ -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
− src/Record.hs
@@ -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'-
− src/RecordOptions.hs
@@ -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)-
− src/Report.hs
@@ -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> <name2>"- , ""- , " 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---<name1>---<name2>'"- ]- 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)-
− src/Utils.hs
@@ -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) ' '-