Commit a91f71dd authored by refold's avatar refold
Browse files

Better output for parallel install.

Example of what happens in the normal case: https://gist.github.com/3032723
Example of what happens in case of error: https://gist.github.com/3032939
parent db8c9588
......@@ -732,6 +732,10 @@ data InstallMisc = InstallMisc {
libVersion :: Maybe Version
}
-- | If logging is enabled, contains location of the log file and the verbosity
-- level for logging.
type UseLogFile = Maybe (PackageIdentifier -> FilePath, Verbosity)
performInstallations :: Verbosity
-> InstallContext
-> PackageIndex
......@@ -749,12 +753,12 @@ performInstallations verbosity
installLock <- newLock -- serialise installation
cacheLock <- newLock -- serialise access to setup exe cache
executeInstallPlan verbosity jobControl installPlan $ \cpkg ->
executeInstallPlan verbosity jobControl useLogFile installPlan $ \cpkg ->
installConfiguredPackage platform compid configFlags
cpkg $ \configFlags' src pkg ->
fetchSourcePackage verbosity fetchLimit src $ \src' ->
installLocalPackage verbosity buildLimit (packageId pkg) src' $ \mpath ->
installUnpackedPackage verbosity buildLimit installLock
installUnpackedPackage verbosity buildLimit installLock numJobs
(setupScriptOptions installedPkgIndex cacheLock)
miscOptions configFlags' installFlags haddockFlags
compid pkg mpath useLogFile
......@@ -793,21 +797,50 @@ performInstallations verbosity
}
reportingLevel = fromFlag (installBuildReports installFlags)
logsDir = fromFlag (globalLogsDir globalFlags)
useLogFile :: Maybe (PackageIdentifier -> FilePath)
useLogFile = fmap substLogFileName logFileTemplate
-- Should the build output be written to a log file instead of stdout?
useLogFile :: UseLogFile
useLogFile = fmap ((\f -> (f, loggingVerbosity)) . substLogFileName)
logFileTemplate
where
installLogFile' = flagToMaybe $ installLogFile installFlags
defaultTemplate = toPathTemplate $ logsDir </> "$pkgid" <.> "log"
-- If the user has specified --remote-build-reporting=detailed, use the
-- default log file location. If the --build-log option is set, use the
-- provided location. Otherwise don't use logging, unless building in
-- parallel (in which case the default location is used).
logFileTemplate :: Maybe PathTemplate
logFileTemplate --TODO: separate policy from mechanism
| reportingLevel == DetailedReports
= Just $ toPathTemplate $ logsDir </> "$pkgid" <.> "log"
| otherwise
= flagToMaybe (installLogFile installFlags)
logFileTemplate
| useDefaultTemplate = Just defaultTemplate
| otherwise = installLogFile'
-- If the user has specified --remote-build-reporting=detailed or
-- --build-log, use more verbose logging.
loggingVerbosity :: Verbosity
loggingVerbosity | overrideVerbosity = max Verbosity.verbose verbosity
| otherwise = verbosity
useDefaultTemplate :: Bool
useDefaultTemplate
| reportingLevel == DetailedReports = True
| isJust installLogFile' = False
| numJobs > 1 = True
| otherwise = False
overrideVerbosity :: Bool
overrideVerbosity
| reportingLevel == DetailedReports = True
| isJust installLogFile' = True
| numJobs > 1 = False
| otherwise = False
substLogFileName :: PathTemplate -> PackageIdentifier -> FilePath
substLogFileName template pkg = fromPathTemplate
. substPathTemplate env
$ template
where env = initialPathTemplateEnv (packageId pkg) (compilerId comp)
miscOptions = InstallMisc {
rootCmd = if fromFlag (configUserInstall configFlags)
then Nothing -- ignore --root-cmd if --user.
......@@ -818,10 +851,11 @@ performInstallations verbosity
executeInstallPlan :: Verbosity
-> JobControl IO (PackageId, BuildResult)
-> UseLogFile
-> InstallPlan
-> (ConfiguredPackage -> IO BuildResult)
-> IO InstallPlan
executeInstallPlan verbosity jobCtl plan0 installPkg =
executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg =
tryNewTasks 0 plan0
where
tryNewTasks taskCount plan = do
......@@ -830,7 +864,7 @@ executeInstallPlan verbosity jobCtl plan0 installPkg =
| otherwise -> waitForTasks taskCount plan
pkgs -> do
sequence_
[ do notice verbosity $ "Ready to install " ++ display pkgid
[ do info verbosity $ "Ready to install " ++ display pkgid
spawnJob jobCtl $ do
buildResult <- installPkg pkg
return (packageId pkg, buildResult)
......@@ -842,13 +876,14 @@ executeInstallPlan verbosity jobCtl plan0 installPkg =
waitForTasks taskCount' plan'
waitForTasks taskCount plan = do
notice verbosity $ "Waiting for install task to finish..."
info verbosity $ "Waiting for install task to finish..."
(pkgid, buildResult) <- collectJob jobCtl
notice verbosity $ "Collecting build result for " ++ display pkgid
printBuildResult pkgid buildResult
let taskCount' = taskCount-1
plan' = updatePlan pkgid buildResult plan
tryNewTasks taskCount' plan'
updatePlan :: PackageIdentifier -> BuildResult -> InstallPlan -> InstallPlan
updatePlan pkgid (Right buildSuccess) =
InstallPlan.completed pkgid buildSuccess
......@@ -861,6 +896,27 @@ executeInstallPlan verbosity jobCtl plan0 installPkg =
-- now cannot build, we mark as failing due to 'DependentFailed'
-- which kind of means it was not their fault.
-- Print last 10 lines of the build log if something went wrong, and
-- 'Installed $PKGID' otherwise.
printBuildResult :: PackageId -> BuildResult -> IO ()
printBuildResult pkgid buildResult = case buildResult of
(Right _) -> notice verbosity $ "Installed " ++ display pkgid
(Left _) -> do
notice verbosity $ "Failed to install " ++ display pkgid
case useLogFile of
Nothing -> return ()
Just (mkLogFileName, _) -> do
let (logName, n) = (mkLogFileName pkgid, 10)
notice verbosity $ "Last " ++ (show n)
++ " lines of the build log ( " ++ logName ++ " ):"
printLastNLines logName n
printLastNLines :: FilePath -> Int -> IO ()
printLastNLines path n = do
lns <- fmap lines $ readFile path
let len = length lns
let toDrop = if len > n && n > 0 then (len - n) else 0
mapM_ (notice verbosity) (drop toDrop lns)
-- | Call an installer for an 'SourcePackage' but override the configure
-- flags with the ones given by the 'ConfiguredPackage'. In particular the
......@@ -958,6 +1014,7 @@ installUnpackedPackage
:: Verbosity
-> JobLimit
-> Lock
-> Int
-> SetupScriptOptions
-> InstallMisc
-> ConfigFlags
......@@ -966,19 +1023,23 @@ installUnpackedPackage
-> CompilerId
-> PackageDescription
-> Maybe FilePath -- ^ Directory to change to before starting the installation.
-> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any)
-> UseLogFile -- ^ File to log output to (if any)
-> IO BuildResult
installUnpackedPackage verbosity buildLimit installLock
installUnpackedPackage verbosity buildLimit installLock numJobs
scriptOptions miscOptions
configFlags installConfigFlags haddockFlags
compid pkg workingDir useLogFile =
-- Configure phase
onFailure ConfigureFailed $ withJobLimit buildLimit $ do
when (numJobs > 1) $ notice verbosity $
"Configuring " ++ display pkgid ++ "..."
setup configureCommand configureFlags
-- Build phase
onFailure BuildFailed $ do
when (numJobs > 1) $ notice verbosity $
"Building " ++ display pkgid ++ "..."
setup buildCommand' buildFlags
-- Doc generation phase
......@@ -1006,6 +1067,7 @@ installUnpackedPackage verbosity buildLimit installLock
return (Right (BuildOk docsResult testsResult))
where
pkgid = packageId pkg
configureFlags = filterConfigureFlags configFlags {
configVerbosity = toFlag verbosity'
}
......@@ -1024,12 +1086,12 @@ installUnpackedPackage verbosity buildLimit installLock
Cabal.installDistPref = configDistPref configFlags,
Cabal.installVerbosity = toFlag verbosity'
}
verbosity' | isJust useLogFile = max Verbosity.verbose verbosity
| otherwise = verbosity
verbosity' = maybe verbosity snd useLogFile
setup cmd flags = do
logFileHandle <- case useLogFile of
Nothing -> return Nothing
Just mkLogFileName -> do
Nothing -> return Nothing
Just (mkLogFileName, _) -> do
let logFileName = mkLogFileName (packageId pkg)
logDir = takeDirectory logFileName
unless (null logDir) $ createDirectoryIfMissing True logDir
......
......@@ -42,7 +42,7 @@ import Distribution.Simple.Compiler
, PackageDB(..), PackageDBStack )
import Distribution.Simple.Program
( ProgramConfiguration, emptyProgramConfiguration
, rawSystemProgramConf, ghcProgram )
, getDbProgramOutput, runDbProgram, ghcProgram )
import Distribution.Simple.BuildPaths
( defaultDistPref, exeExtension )
import Distribution.Simple.Command
......@@ -72,7 +72,7 @@ import Distribution.Compat.Exception
import System.Directory ( doesFileExist )
import System.FilePath ( (</>), (<.>) )
import System.IO ( Handle )
import System.IO ( Handle, hPutStr )
import System.Exit ( ExitCode(..), exitWith )
import System.Process ( runProcess, waitForProcess )
import Control.Monad ( when, unless )
......@@ -337,15 +337,22 @@ externalSetupMethod verbosity options pkg bt mkargs = do
debug verbosity "Setup script is out of date, compiling..."
(compiler, conf, _) <- configureCompiler options'
--TODO: get Cabal's GHC module to export a GhcOptions type and render func
rawSystemProgramConf verbosity ghcProgram conf $
ghcVerbosityOptions verbosity
++ ["--make", setupHsFile, "-o", setupProgFile
,"-odir", setupDir, "-hidir", setupDir
,"-i", "-i" ++ workingDir ]
++ ghcPackageDbOptions compiler (usePackageDB options')
++ if packageName pkg == PackageName "Cabal"
then []
else ["-package", display cabalPkgid]
let ghcCmdLine =
ghcVerbosityOptions verbosity
++ ["--make", setupHsFile, "-o", setupProgFile
,"-odir", setupDir, "-hidir", setupDir
,"-i", "-i" ++ workingDir ]
++ ghcPackageDbOptions compiler (usePackageDB options')
++ if packageName pkg == PackageName "Cabal"
then []
else ["-package", display cabalPkgid]
case useLoggingHandle options of
Nothing -> runDbProgram verbosity ghcProgram conf ghcCmdLine
-- If build logging is enabled, redirect compiler output to the log file.
(Just logHandle) -> do output <- getDbProgramOutput verbosity ghcProgram
conf ghcCmdLine
hPutStr logHandle output
return setupProgFile
where
setupProgFile = setupDir </> "setup" <.> exeExtension
......
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