hackager 1.0.1 → 1.2.0.0
raw patch · 12 files changed
+260/−194 lines, 12 filesdep ~Cabaldep ~basedep ~mtl
Dependency ranges changed: Cabal, base, mtl
Files
- HACKING.md +28/−0
- README.md +16/−1
- hackager.cabal +6/−5
- src/Build.hs +53/−32
- src/BuildManager.hs +24/−8
- src/BuildTools.hs +6/−70
- src/HackageMonad.hs +70/−53
- src/Parallel.hs +28/−0
- src/Record.hs +2/−3
- src/RecordOptions.hs +16/−11
- src/Report.hs +4/−4
- src/Utils.hs +7/−7
+ HACKING.md view
@@ -0,0 +1,28 @@+# 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+# Hackager [](https://hackage.haskell.org/package/hackager) [](https://travis-ci.org/dterei/hackager) Hackager is a tool to compile all of the Haskell Hackage package repository. This is useful for testing Haskell compilers.@@ -76,3 +76,18 @@ * 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.
hackager.cabal view
@@ -1,12 +1,12 @@ Name: hackager-Version: 1.0.1+Version: 1.2.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 <dave.terei@gmail.com>-Maintainer: David Terei <dave.terei@gmail.com>+Author: The GHC Team, David Terei <code@davidterei.com>+Maintainer: David Terei <code@davidterei.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+Extra-Source-Files: README.md, TODO.md, HACKING.md Cabal-Version: >= 1.6 Source-Repository head@@ -27,12 +27,13 @@ BuildManager BuildTools HackageMonad+ Parallel Record RecordOptions Report Utils HS-Source-Dirs: src- Ghc-Options: -threaded+ Ghc-Options: -threaded -Wall Build-Depends: base >= 2 && < 5, Cabal, containers,
src/Build.hs view
@@ -6,16 +6,28 @@ ) 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 () @@ -31,13 +43,17 @@ scratchDir <- getScratchDir p liftIO . ignoreException $ removeDirectoryRecursive scratchDir - name <- getName- depFlags <- getDepFlags- pkgFlags <- getPkgFlags- basicFlags <- getBasicCabalFlags+ rpath <- getRunPath+ depFlags <- getDepFlags+ pkgFlags <- getPkgFlags+ basicFlags <- getBasicCabalFlags - let cabalLog = name </> "logs.build" </> p <.> "cabal.log"- deplog = name </> "logs.build" </> p <.> "depends.log"+ 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@@ -55,12 +71,16 @@ , "--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 = name </> "logs.build" </> p <.> "summary"- logName = name </> "logs.build" </> p <.> "log"+ let summaryName = pkgPath <.> "summary"+ logName = pkgPath <.> "log" pkgArgs = [ "install", p , "--build-summary=" ++ summaryName , "--build-log=" ++ logName@@ -81,7 +101,7 @@ rmScratchDir p where- toFile f strs = liftIO $ appendFile f (concat strs)+ 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:@@ -94,18 +114,20 @@ statPkg npkgs i pkg = do info $ "===> Getting stats for: " ++ pkg ++ " (" ++ show i ++ " of " ++ show npkgs ++ ")"- name <- getName++ rpath <- getRunPath basicFlags <- getBasicCabalFlags- fs <- getPkgFlags- let summaryName = name </> "logs.stats" </> pkg <.> "summary"- logName = name </> "logs.stats" </> pkg <.> "log"- resultName = name </> "logs.stats" </> pkg <.> "result"- args = basicFlags ++ fs ++- [ "install", "--dry-run", pkg- , "--build-summary=" ++ summaryName- , "--build-log=" ++ logName- ]+ 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@@ -119,7 +141,7 @@ addNotInstallablePackage pkg info $ "===> " ++ pkg ++ " is not installable, skipping!" when (notUpdated resultsLines) $- die ("===> Errror: You need to run 'cabal update' first!")+ die "===> Errror: You need to run 'cabal update' first!" Right ls -> do let resultsLines = "SUCCEEDED" : ls@@ -128,7 +150,7 @@ (_, _ : ls1) -> do ls2 <- mapM mangleLine ls1 case reverse ls2 of- thisP : otherPs | thisP == pkg -> do+ thisP : otherPs | toU thisP == toU pkg -> do addInstallablePackage pkg mapM_ addInstall otherPs @@ -143,14 +165,12 @@ addFailPackage pkg where- notUpdated [] = False- notUpdated (x : xs) = if "Stderr: Run 'cabal update'" `isPrefixOf` x- then True- else notUpdated xs+ 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 l of+ mangleLine l = case simpleParse . takeWhile (/= ' ') $ l of Nothing -> die ("Unparseable line: " ++ show l) Just (PackageIdentifier (PackageName pn) _) ->@@ -159,11 +179,12 @@ -- | Get the default cabal flags to use. getBasicCabalFlags :: Hkg [String] getBasicCabalFlags = do- ghc <- getGhc+ ghc <- getGhc ghcPkg <- getGhcPkg- return [ "--remote-build-reporting=none"- , "--ghc"- , "--with-ghc=" ++ ghc- , "--with-ghc-pkg=" ++ ghcPkg- ]+ cFlags <- getCabalFlags+ return $ [ "--remote-build-reporting=none"+ , "--ghc"+ , "--with-ghc=" ++ ghc+ , "--with-ghc-pkg=" ++ ghcPkg+ ] ++ cFlags
src/BuildManager.hs view
@@ -1,21 +1,37 @@ -- | Handle building a set of packages (usually all of Hackage) module BuildManager (- getPackages,+ 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.-getPackages :: Hkg [PkgName]-getPackages = do+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@@ -23,9 +39,9 @@ -- dff 0.1.2 -- ... case m of- Left (_, out) -> die $ "Failed to get package list: " ++ concat out+ Left (_, out) -> die $ "Failed to get package list: " ++ unlines out Right xs ->- let ls = map (takeWhile (' ' /=)) $ xs+ let ls = map (takeWhile (' ' /=)) xs ps = uniq $ filter (not . null) ls in return ps @@ -37,10 +53,10 @@ info $ "===> Testing against " ++ show n ++ " packages..." runOnAllPkgs ps statPkg dumpStats n- psAll <- getInstallablePackages+ psAll <- getInstallablePackages runOnAllPkgs psAll buildPkg dumpResults- rmTempDir+ rmAllScratch info $ "===> Hackager finished! (" ++ show n ++ " packages tested)" -- | Run in parallel a PkgProcessor function over the given list@@ -63,7 +79,7 @@ go = do pkgs <- liftIO $ takeMVar mpkgs case pkgs of- [] -> liftIO (putMVar mpkgs []) >> return ()+ [] -> liftIO $ putMVar mpkgs [] ((i, p) : ps) -> do liftIO $ putMVar mpkgs ps pkgFun n i p
src/BuildTools.hs view
@@ -1,85 +1,23 @@--- | Various tools and utility functions to do wtih building.+-- | Wrappers to run various build tools needed. module BuildTools (- die, info, warn,- Child, forkChild, waitForChildren,- setupDir, initialisePackageConf, runCabal, runCabalResults, runGhcPkg ) where import Control.Concurrent import Control.Monad.State import Control.Exception-import System.Directory-import System.Exit-import System.FilePath+import System.Exit (ExitCode(..)) import System.IO import System.Process import HackageMonad import Utils --- | Print message to stdout.-info :: String -> Hkg ()-info msg = getIOLock >> liftIO (putStrLn msg) >> releaseIOLock---- | Print message to stderr.-warn :: String -> Hkg ()-warn msg = getIOLock >> liftIO (hPutStrLn stderr msg) >> releaseIOLock---- | Exit with error message.-die :: String -> Hkg a-die err = do- getIOLock- liftIO $ hPutStrLn stderr err- releaseIOLock- liftIO $ exitWith (ExitFailure 1)---- | Children process signal-type Child = MVar ()---- | Fork a child and return an MVar that singals 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---- | Setup the needed directory structure-setupDir:: Hkg ()-setupDir = do- name <- getName- exists <- liftIO $ doesDirectoryExist name- if exists- then die (show name ++ " already exists, not overwriting")- else liftIO $ do- createDirectory name- createDirectory (name </> "logs.stats")- createDirectory (name </> "logs.build")---- | 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")- -- | Run cabal. runCabal :: [String] -> Hkg ExitCode runCabal args = do cabal <- getCabal- x <- liftIO $ rawSystem cabal args- return x+ liftIO $ rawSystem cabal args -- | Run cabal returning the resulting output or error code -- * Bool: Treat any stderr output as evidence that cabal failed@@ -87,15 +25,13 @@ runCabalResults :: Bool -> [String] -> Hkg (Either (ExitCode, [String]) [String]) runCabalResults errFail args = do cabal <- getCabal- r <- runCmdGetResults errFail cabal args- return r+ runCmdGetResults errFail cabal args -- | Run ghc-pkg. runGhcPkg :: [String] -> Hkg ExitCode runGhcPkg args = do ghcPkg <- getGhcPkg- x <- liftIO $ rawSystem ghcPkg args- return x+ liftIO $ rawSystem ghcPkg args data StdLine = Stdout String | Stderr String @@ -136,7 +72,7 @@ ec <- waitForProcess ph ls <- takeMVar linesMVar- return $ case (ec, errFail && (any isStderr ls)) of+ return $ case (ec, errFail && any isStderr ls) of (ExitSuccess, False) -> Right $ map stripResultLine ls _ -> Left (ec, map mkResultLine ls)
src/HackageMonad.hs view
@@ -3,20 +3,21 @@ module HackageMonad ( PkgName, Hkg, HkgState, startState, - getTempPackageConf, getScratchDir, rmScratchDir, rmTempDir,+ getTempPackageConf, getScratchDir, rmScratchDir, rmAllScratch, - setName, getName,- getCabal, setCabal, getGhc, setGhc, getGhcPkg, setGhcPkg,- getDepFlags, setDepFlags, getPkgFlags, setPkgFlags, addPkg, getPkgs,+ 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, - getIOLock, releaseIOLock,+ dumpStats, dumpResults, - dumpStats, dumpResults+ info, warn, die ) where import Control.Concurrent (MVar, newMVar)@@ -30,6 +31,8 @@ import qualified Data.Set as Set import System.Directory import System.FilePath+import System.Exit (exitWith, ExitCode(..))+import System.IO import Utils @@ -40,11 +43,11 @@ -- | The state of Hackager data HkgState = HkgState { -- These are set based on the command line flags- st_name :: FilePath, st_dir :: FilePath, st_cabal :: FilePath, st_ghc :: FilePath, st_ghcPkg :: FilePath,+ st_cabFlags :: [String], st_depFlags :: [String], st_pkgFlags :: [String], st_threads :: Int,@@ -77,12 +80,12 @@ bfpkgs <- newMVar Set.empty bdpkgs <- newMVar Set.empty iolock <- newMVar ()- return $ HkgState {- st_name = "",+ return HkgState { st_dir = "", st_cabal = "", st_ghc = "", st_ghcPkg = "",+ st_cabFlags = [], st_depFlags = [], st_pkgFlags = [], st_threads = 1,@@ -101,78 +104,78 @@ ------------------------------------------------ -- Helpers -setName :: FilePath -> Hkg ()-setName name = do+setRunPath :: FilePath -> Hkg ()+setRunPath name = do dir <- liftIO getCurrentDirectory- modify $ \st -> st { st_name = name, st_dir = dir </> name }--getName :: Hkg FilePath-getName = get >>= \st -> return $ st_name st+ modify $ \st -> st { st_dir = dir </> name } -getDir :: Hkg FilePath-getDir = get >>= \st -> return $ st_dir st+getRunPath :: Hkg FilePath+getRunPath = gets st_dir getTempPackageConf :: PkgName -> Hkg FilePath-getTempPackageConf p = getDir >>= \dir -> return- $ dir </> "scratch" </> p <.> "package.conf"+getTempPackageConf p = (<.> "package.conf") <$> getScratchDir p getScratchDir :: PkgName -> Hkg FilePath-getScratchDir p = getDir >>= \dir -> return $ dir </> "scratch" </> p+getScratchDir p = (</> "scratch" </> p) <$> getRunPath rmScratchDir :: PkgName -> Hkg () rmScratchDir p = do- dir <- getDir+ dir <- getRunPath liftIO . ignoreException $ removeDirectoryRecursive (dir </> "scratch" </> p) -rmTempDir :: Hkg ()-rmTempDir = do- dir <- getDir+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 = get >>= \st -> return $ st_cabal st+getCabal = gets st_cabal setGhc :: FilePath -> Hkg () setGhc ghc = modify $ \st -> st { st_ghc = ghc } getGhc :: Hkg FilePath-getGhc = get >>= \st -> return $ st_ghc st+getGhc = gets st_ghc setGhcPkg :: FilePath -> Hkg ()-setGhcPkg ghcPkg = modify $ \st -> st {st_ghcPkg = ghcPkg }+setGhcPkg ghcPkg = modify $ \st -> st { st_ghcPkg = ghcPkg } getGhcPkg :: Hkg FilePath-getGhcPkg = get >>= \st -> return $ st_ghcPkg st+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 = get >>= \st -> return $ st_depFlags st+getDepFlags = gets st_depFlags setPkgFlags :: String -> Hkg () setPkgFlags pkgFlags = modify $ \st -> st { st_pkgFlags = parseFlags pkgFlags } getPkgFlags :: Hkg [String]-getPkgFlags = get >>= \st -> return $ st_pkgFlags st+getPkgFlags = gets st_pkgFlags addPkg :: String -> Hkg ()-addPkg p = modify $ \st -> st {st_pkgs = Set.insert p (st_pkgs st) }+addPkg p = modify $ \st -> st { st_pkgs = Set.insert p (st_pkgs st) } getPkgs :: Hkg [String]-getPkgs = do- st <- get- return $ Set.toList (st_pkgs st)+getPkgs = gets $ Set.toList . st_pkgs setThreads :: Int -> Hkg () setThreads n = modify $ \st -> st { st_threads = n } getThreads :: Hkg Int-getThreads = get >>= \st -> return $ st_threads st+getThreads = gets st_threads parseFlags :: String -> [String] parseFlags str =@@ -235,17 +238,6 @@ s <- takeMVar $ st_buildDepFailurePackages st putMVar (st_buildDepFailurePackages st) $ Set.insert pkg s -getIOLock :: Hkg ()-getIOLock = do- st <- get- _ <- takeMVar $ st_iolock st- return ()--releaseIOLock :: Hkg ()-releaseIOLock = do- st <- get- putMVar (st_iolock st) ()- dumpStats :: Int -> Hkg () dumpStats n = do st <- get@@ -255,11 +247,10 @@ fpkgs <- readMVar $ st_failPackages st count <- readMVar $ st_installCounts st - let fullHistogram = reverse $ sort $ map swap- $ Map.assocs count+ 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] + summaryTable = [ ["Num packages" , show n] , ["Installed packages" , show $ Set.size ipkgs] , ["Installable packages" , show $ Set.size apkgs] , ["Uninstallable packages" , show $ Set.size npkgs]@@ -267,7 +258,7 @@ , ["Total reinstallations" , show total] ] - name <- getName+ name <- getRunPath liftIO $ do writeFile (name </> "stats.full") (unlines $ showCompleteHistogram fullHistogram)@@ -308,12 +299,13 @@ bpkgs <- readMVar $ st_buildablePackages st fpkgs <- readMVar $ st_buildFailurePackages st dpkgs <- readMVar $ st_buildDepFailurePackages st+ rpath <- getRunPath - liftIO $ writeFile (st_name st </> "buildable")+ liftIO $ writeFile (rpath </> "buildable") (unlines $ Set.toList bpkgs)- liftIO $ writeFile (st_name st </> "buildFailed")+ liftIO $ writeFile (rpath </> "buildFailed") (unlines $ Set.toList fpkgs)- liftIO $ writeFile (st_name st </> "buildDepsFailed")+ liftIO $ writeFile (rpath </> "buildDepsFailed") (unlines $ Set.toList dpkgs) takeMVar :: MVar a -> Hkg a@@ -324,4 +316,29 @@ 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 view
@@ -0,0 +1,28 @@+-- | 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 view
@@ -9,7 +9,6 @@ import System.IO import BuildManager-import BuildTools import HackageMonad import RecordOptions @@ -29,9 +28,9 @@ _ -> do processArgs args ps <- getPkgs- setupDir+ setupBuildDir ps' <- case ps of- [] -> getPackages+ [] -> getAllHackage _ -> return ps tryBuildingPackages ps'
src/RecordOptions.hs view
@@ -7,10 +7,9 @@ import Control.Monad.State import Data.Char (isDigit) import System.Directory-import System.Exit+import System.Exit (exitWith, ExitCode(..)) import System.IO -import BuildTools import HackageMonad -- | Print usage information and exit@@ -21,18 +20,20 @@ ExitFailure 1 -> putStrLn ExitFailure _ -> hPutStrLn stderr mapM_ out- [ "usage: hackager record -o NAME [-c CABAL] [-g GHC] [-p GHC-PKG] [-d DEP-FLAGS]"- , " [-f PKG-FLAGS] [-n THREADS] [PKGS...]"+ [ "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. \"--ghc-option=-XFoo\""+ , " e.g. -d [\"--ghc-option=-XFoo\",\"--ghc-option=-XBar\"]" , " PKG-FLAGS The flags to use when compiling a package"- , " e.g. \"--ghc-option=-XBar\""+ , " 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"@@ -48,11 +49,11 @@ -- | Parse an individual option flag processOpt :: String -> String -> Hkg () processOpt "o" name = do- checkNotSet getName "output directory is already set"+ 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"- setName name+ setRunPath name processOpt "c" cabal = do checkNotSet getCabal "cabal program is already set"@@ -66,6 +67,10 @@ 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"@@ -99,7 +104,7 @@ -- | Validate all the flags needed have been set and are valid validateFlags :: Hkg () validateFlags = do- n <- getName+ n <- getRunPath when (n == "") $ badflag "output directory not set" setExecutable getCabal setCabal "cabal" setExecutable getGhc setGhc "ghc"@@ -119,9 +124,9 @@ checkExecutable :: String -> String -> Hkg () checkExecutable f prog = do b <- liftIO $ doesFileExist f- when (not b) $ badflag $ prog ++ " executable doesn't exist"+ unless b $ badflag $ prog ++ " executable doesn't exist" p <- liftIO $ getPermissions f- when (not $ executable p) $ badflag $ prog ++ " file is not executable"+ unless (executable p) $ badflag $ prog ++ " file is not executable" -- | Make sure a flag hasn't been set before checkNotSet :: Hkg [a] -> String -> Hkg ()
src/Report.hs view
@@ -8,7 +8,7 @@ import Data.Set (Set) import qualified Data.Set as Set import System.Directory-import System.Exit+import System.Exit (exitWith, ExitCode(..)) import System.FilePath import System.IO @@ -17,7 +17,7 @@ -- | Run the reporting tool. report :: [String] -> IO ()-report args = do+report args = case args of [name1, name2] -> generate name1 name2 ["--help" ] -> reportHelp ExitSuccess@@ -45,9 +45,9 @@ -- check valid input and outputs n1exists <- doesDirectoryExist name1- when (not n1exists) $ die ("'" ++ name1 ++ "' doesn't exists")+ unless n1exists $ die ("'" ++ name1 ++ "' doesn't exists") n2exists <- doesDirectoryExist name2- when (not n2exists) $ die ("'" ++ name2 ++ "' doesn't exists")+ unless n2exists $ die ("'" ++ name2 ++ "' doesn't exists") exists <- doesDirectoryExist compName when exists $ die ("The directoy '" ++ compName ++ "' already exists, won't overwrite")
src/Utils.hs view
@@ -4,14 +4,14 @@ showTable, uniq, swap, lpad, rpad ) where -import Control.Exception+import qualified Control.Exception as E import Data.List-import Prelude hiding (catch)-import System.IO.Error hiding (catch)+import Prelude+import System.IO.Error -- | Handle an IO exception.-catchIO :: IO a -> (IOException -> IO a) -> IO a-catchIO = catch+catchIO :: IO a -> (E.IOException -> IO a) -> IO a+catchIO = E.catch -- | Ignore any IO exception that arises. ignoreException :: IO () -> IO ()@@ -20,7 +20,7 @@ -- | Perform some IO and execute the second argument on an EOF exception. onEndOfFile :: IO a -> IO a -> IO a onEndOfFile io io' =- io `catch` \e -> if isEOFError e then io' else throwIO e+ io `E.catch` \e -> if isEOFError e then io' else E.throwIO e -- | Filter out adjacent duplicate elements. uniq :: Eq a => [a] -> [a]@@ -37,7 +37,7 @@ showTable :: [Int -> String -> String] -> [[String]] -> [String] showTable padders xss = let lengths = map (maximum . map length) $ transpose xss- in map (concat . intersperse " " . zipWith3 id padders lengths) xss+ in map (unwords . zipWith3 id padders lengths) xss -- | Pad the string with spaces before it. lpad :: Int -> String -> String