Allow user control of -j argument #141

This commit is contained in:
Michael Snoyman 2013-11-17 14:28:30 +02:00
parent 5b6cff89e3
commit 2d420cc03b
2 changed files with 19 additions and 8 deletions

View File

@ -18,11 +18,20 @@ import System.IO (BufferMode (NoBuffering),
import System.Process (rawSystem, runProcess,
waitForProcess)
defaultBuildSettings :: GhcMajorVersion -> BuildSettings
defaultBuildSettings version = BuildSettings
defaultBuildSettings :: Maybe Int -- ^ argument to -j
-> GhcMajorVersion
-> BuildSettings
defaultBuildSettings cores version = BuildSettings
{ sandboxRoot = "sandbox"
, expectedFailuresBuild = defaultExpectedFailures version
, extraArgs = const ["-fnetwork23"]
, extraArgs = \bs -> "-fnetwork23" :
case bs of
BSTest -> []
_ ->
case cores of
Nothing -> ["-j"]
Just 1 -> []
Just j -> ["-j", show j]
, testWorkerThreads = 4
, buildDocs = True
, tarballDir = "patching/tarballs"
@ -64,7 +73,6 @@ build settings' bp = do
$ "install"
: ("--cabal-lib-version=" ++ libVersion)
: "--build-log=logs-tools/$pkg.log"
: "-j"
: [tool]
hPutStrLn handle ("cabal " ++ unwords (map (\s -> "'" ++ s ++ "'") args))
ph <- runCabal args handle
@ -89,7 +97,6 @@ build settings' bp = do
: "--build-log=logs/$pkg.log"
: "--max-backjumps=-1"
: "--reorder-goals"
: "-j"
: packageList
hPutStrLn handle ("cabal " ++ unwords (map (\s -> "'" ++ s ++ "'") args))
runCabal args handle

View File

@ -47,15 +47,17 @@ data BuildArgs = BuildArgs
, buildPlanSrc :: FilePath
, extraArgs' :: [String] -> [String]
, noDocs :: Bool
, buildCores :: Maybe Int
}
parseBuildArgs :: GhcMajorVersion -> [String] -> IO BuildArgs
parseBuildArgs version =
loop BuildArgs
{ sandbox = sandboxRoot $ defaultBuildSettings version
{ sandbox = sandboxRoot $ defaultBuildSettings Nothing version
, buildPlanSrc = defaultBuildPlan
, extraArgs' = id
, noDocs = False
, buildCores = Nothing
}
where
loop x [] = return x
@ -63,6 +65,7 @@ parseBuildArgs version =
loop x ("--build-plan":y:rest) = loop x { buildPlanSrc = y } rest
loop x ("--arg":y:rest) = loop x { extraArgs' = extraArgs' x . (y:) } rest
loop x ("--no-docs":rest) = loop x { noDocs = True } rest
loop x ("-j":y:rest) = loop x { buildCores = Just $ read y } rest
loop _ (y:_) = error $ "Did not understand argument: " ++ y
defaultBuildPlan :: FilePath
@ -73,9 +76,10 @@ withBuildSettings args f = do
version <- getGhcVersion
BuildArgs {..} <- parseBuildArgs version args
bp <- readBuildPlan buildPlanSrc
let settings = (defaultBuildSettings version)
let bs = defaultBuildSettings buildCores version
let settings = bs
{ sandboxRoot = sandbox
, extraArgs = extraArgs' . extraArgs (defaultBuildSettings version)
, extraArgs = extraArgs' . extraArgs bs
, buildDocs = not noDocs
}
f settings bp