Commit 70db82f4 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov

Add a '-j' flag to 'setup build'.

parent 6afd56db
......@@ -89,7 +89,7 @@ module Distribution.Simple.Setup (
fromFlagOrDefault,
flagToMaybe,
flagToList,
boolOpt, boolOpt', trueArg, falseArg, optionVerbosity ) where
boolOpt, boolOpt', trueArg, falseArg, optionVerbosity, numJobsParser ) where
import Distribution.Compiler ()
import Distribution.ReadE
......@@ -1356,6 +1356,7 @@ data BuildFlags = BuildFlags {
buildProgramArgs :: [(String, [String])],
buildDistPref :: Flag FilePath,
buildVerbosity :: Flag Verbosity,
buildNumJobs :: Flag (Maybe Int),
-- TODO: this one should not be here, it's just that the silly
-- UserHooks stop us from passing extra info in other ways
buildArgs :: [String]
......@@ -1372,6 +1373,7 @@ defaultBuildFlags = BuildFlags {
buildProgramArgs = [],
buildDistPref = Flag defaultDistPref,
buildVerbosity = Flag normal,
buildNumJobs = mempty,
buildArgs = []
}
......@@ -1405,6 +1407,13 @@ buildOptions progConf showOrParseArgs =
buildDistPref (\d flags -> flags { buildDistPref = d })
showOrParseArgs
: option "j" ["jobs"]
"Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)"
buildNumJobs (\v flags -> flags { buildNumJobs = v })
(optArg "NUM" (fmap Flag numJobsParser)
(Flag Nothing)
(map (Just . maybe "$ncpus" show) . flagToList))
: programConfigurationPaths progConf showOrParseArgs
buildProgramPaths (\v flags -> flags { buildProgramPaths = v})
......@@ -1423,6 +1432,7 @@ instance Monoid BuildFlags where
buildProgramArgs = mempty,
buildVerbosity = mempty,
buildDistPref = mempty,
buildNumJobs = mempty,
buildArgs = mempty
}
mappend a b = BuildFlags {
......@@ -1430,6 +1440,7 @@ instance Monoid BuildFlags where
buildProgramArgs = combine buildProgramArgs,
buildVerbosity = combine buildVerbosity,
buildDistPref = combine buildDistPref,
buildNumJobs = combine buildNumJobs,
buildArgs = combine buildArgs
}
where combine field = field a `mappend` field b
......@@ -1808,6 +1819,18 @@ programConfigurationOptions progConf showOrParseArgs get set =
get set
(reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const []))
-- | Common parser for the @-j@ flag of @build@ and @install@.
numJobsParser :: ReadE (Maybe Int)
numJobsParser = ReadE $ \s ->
case s of
"$ncpus" -> Right Nothing
_ -> case reads s of
[(n, "")]
| n < 1 -> Left "The number of jobs should be 1 or more."
| n > 64 -> Left "You probably don't want that many jobs."
| otherwise -> Right (Just n)
_ -> Left "The jobs value should be a number or '$ncpus'"
-- ------------------------------------------------------------
-- * GetOpt Utils
-- ------------------------------------------------------------
......
......@@ -58,7 +58,7 @@ import Distribution.Simple.Setup
( ConfigFlags(..), BuildFlags(..), TestFlags(..), BenchmarkFlags(..)
, SDistFlags(..), HaddockFlags(..)
, Flag(..), toFlag, fromFlag, flagToMaybe, flagToList
, optionVerbosity, boolOpt, trueArg, falseArg )
, optionVerbosity, boolOpt, trueArg, falseArg, numJobsParser )
import Distribution.Simple.InstallDirs
( PathTemplate, InstallDirs(sysconfdir)
, toPathTemplate, fromPathTemplate )
......@@ -344,20 +344,12 @@ data SkipAddSourceDepsCheck =
deriving Eq
data BuildExFlags = BuildExFlags {
buildNumJobs :: Flag (Maybe Int),
buildOnly :: Flag SkipAddSourceDepsCheck
}
buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]
buildExOptions _showOrParseArgs =
option "j" ["jobs"]
"Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)"
buildNumJobs (\v flags -> flags { buildNumJobs = v })
(optArg "NUM" (fmap Flag numJobsParser)
(Flag Nothing)
(map (Just . maybe "$ncpus" show) . flagToList))
: option [] ["only"]
option [] ["only"]
"Don't reinstall add-source dependencies (sandbox-only)"
buildOnly (\v flags -> flags { buildOnly = v })
(noArg (Flag SkipAddSourceDepsCheck))
......@@ -381,11 +373,9 @@ buildCommand = parent {
instance Monoid BuildExFlags where
mempty = BuildExFlags {
buildNumJobs = mempty,
buildOnly = mempty
}
mappend a b = BuildExFlags {
buildNumJobs = combine buildNumJobs,
buildOnly = combine buildOnly
}
where combine field = field a `mappend` field b
......@@ -394,39 +384,51 @@ instance Monoid BuildExFlags where
-- * Test command
-- ------------------------------------------------------------
testCommand :: CommandUI (TestFlags, BuildExFlags)
testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)
testCommand = parent {
commandDefaultFlags = (commandDefaultFlags parent, mempty),
commandDefaultFlags = (commandDefaultFlags parent,
Cabal.defaultBuildFlags, mempty),
commandOptions =
\showOrParseArgs -> liftOptions fst setFst
\showOrParseArgs -> liftOptions get1 set1
(commandOptions parent showOrParseArgs)
++
liftOptions snd setSnd (buildExOptions showOrParseArgs)
liftOptions get2 set2
(Cabal.buildOptions progConf showOrParseArgs)
++
liftOptions get3 set3 (buildExOptions showOrParseArgs)
}
where
setFst a (_,b) = (a,b)
setSnd b (a,_) = (a,b)
get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)
get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)
get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c)
parent = Cabal.testCommand
parent = Cabal.testCommand
progConf = defaultProgramConfiguration
-- ------------------------------------------------------------
-- * Bench command
-- ------------------------------------------------------------
benchmarkCommand :: CommandUI (BenchmarkFlags, BuildExFlags)
benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags)
benchmarkCommand = parent {
commandDefaultFlags = (commandDefaultFlags parent, mempty),
commandDefaultFlags = (commandDefaultFlags parent,
Cabal.defaultBuildFlags, mempty),
commandOptions =
\showOrParseArgs -> liftOptions fst setFst
\showOrParseArgs -> liftOptions get1 set1
(commandOptions parent showOrParseArgs)
++
liftOptions snd setSnd (buildExOptions showOrParseArgs)
liftOptions get2 set2
(Cabal.buildOptions progConf showOrParseArgs)
++
liftOptions get3 set3 (buildExOptions showOrParseArgs)
}
where
setFst a (_,b) = (a,b)
setSnd b (a,_) = (a,b)
get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)
get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)
get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c)
parent = Cabal.benchmarkCommand
parent = Cabal.benchmarkCommand
progConf = defaultProgramConfiguration
-- ------------------------------------------------------------
-- * Fetch command
......@@ -1435,22 +1437,6 @@ instance Monoid SandboxFlags where
}
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
-- * Shared options utils
-- ------------------------------------------------------------
-- | Common parser for the @-j@ flag of @build@ and @install@.
numJobsParser :: ReadE (Maybe Int)
numJobsParser = ReadE $ \s ->
case s of
"$ncpus" -> Right Nothing
_ -> case reads s of
[(n, "")]
| n < 1 -> Left "The number of jobs should be 1 or more."
| n > 64 -> Left "You probably don't want that many jobs."
| otherwise -> Right (Just n)
_ -> Left "The jobs value should be a number or '$ncpus'"
-- ------------------------------------------------------------
-- * GetOpt Utils
-- ------------------------------------------------------------
......
......@@ -275,7 +275,7 @@ buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do
-- Calls 'configureAction' to do the real work, so nothing special has to be
-- done to support sandboxes.
useSandbox <- reconfigure verbosity distPref
mempty [] globalFlags noAddSource (buildNumJobs buildExFlags)
mempty [] globalFlags noAddSource (buildNumJobs buildFlags)
(const Nothing)
maybeWithSandboxDirOnSearchPath useSandbox $
......@@ -621,8 +621,9 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
installFlags' haddockFlags
targets
testAction :: (TestFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()
testAction (testFlags, buildExFlags) extraArgs globalFlags = do
testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags
-> IO ()
testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (testVerbosity testFlags)
distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)
(testDistPref testFlags)
......@@ -637,7 +638,7 @@ testAction (testFlags, buildExFlags) extraArgs globalFlags = do
-- reconfigure also checks if we're in a sandbox and reinstalls add-source
-- deps if needed.
useSandbox <- reconfigure verbosity distPref addConfigFlags []
globalFlags noAddSource (buildNumJobs buildExFlags) checkFlags
globalFlags noAddSource (buildNumJobs buildFlags) checkFlags
maybeWithSandboxDirOnSearchPath useSandbox $
build verbosity distPref mempty extraArgs
......@@ -646,9 +647,11 @@ testAction (testFlags, buildExFlags) extraArgs globalFlags = do
setupWrapper verbosity setupOptions Nothing
Cabal.testCommand (const testFlags) extraArgs
benchmarkAction :: (BenchmarkFlags, BuildExFlags) -> [String] -> GlobalFlags
benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags)
-> [String] -> GlobalFlags
-> IO ()
benchmarkAction (benchmarkFlags, buildExFlags) extraArgs globalFlags = do
benchmarkAction (benchmarkFlags, buildFlags, buildExFlags)
extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal
(benchmarkVerbosity benchmarkFlags)
distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)
......@@ -664,7 +667,7 @@ benchmarkAction (benchmarkFlags, buildExFlags) extraArgs globalFlags = do
-- reconfigure also checks if we're in a sandbox and reinstalls add-source
-- deps if needed.
useSandbox <- reconfigure verbosity distPref addConfigFlags []
globalFlags noAddSource (buildNumJobs buildExFlags)
globalFlags noAddSource (buildNumJobs buildFlags)
checkFlags
maybeWithSandboxDirOnSearchPath useSandbox $
......@@ -815,7 +818,7 @@ runAction (buildFlags, buildExFlags) extraArgs globalFlags = do
-- reconfigure also checks if we're in a sandbox and reinstalls add-source
-- deps if needed.
useSandbox <- reconfigure verbosity distPref mempty []
globalFlags noAddSource (buildNumJobs buildExFlags)
globalFlags noAddSource (buildNumJobs buildFlags)
(const Nothing)
lbi <- getPersistBuildConfig distPref
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment