diff --git a/HACKING.md b/HACKING.md new file mode 100644 --- /dev/null +++ b/HACKING.md @@ -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. + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# Hackager +# 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 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. diff --git a/hackager.cabal b/hackager.cabal --- a/hackager.cabal +++ b/hackager.cabal @@ -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 -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 +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, diff --git a/src/Build.hs b/src/Build.hs --- a/src/Build.hs +++ b/src/Build.hs @@ -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 diff --git a/src/BuildManager.hs b/src/BuildManager.hs --- a/src/BuildManager.hs +++ b/src/BuildManager.hs @@ -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 diff --git a/src/BuildTools.hs b/src/BuildTools.hs --- a/src/BuildTools.hs +++ b/src/BuildTools.hs @@ -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) diff --git a/src/HackageMonad.hs b/src/HackageMonad.hs --- a/src/HackageMonad.hs +++ b/src/HackageMonad.hs @@ -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) diff --git a/src/Parallel.hs b/src/Parallel.hs new file mode 100644 --- /dev/null +++ b/src/Parallel.hs @@ -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 diff --git a/src/Record.hs b/src/Record.hs --- a/src/Record.hs +++ b/src/Record.hs @@ -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' diff --git a/src/RecordOptions.hs b/src/RecordOptions.hs --- a/src/RecordOptions.hs +++ b/src/RecordOptions.hs @@ -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 () diff --git a/src/Report.hs b/src/Report.hs --- a/src/Report.hs +++ b/src/Report.hs @@ -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") diff --git a/src/Utils.hs b/src/Utils.hs --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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