Skip to content
Permalink
Browse files

WIP use concurrent-output for build plan execution updates.

  • Loading branch information
mboes committed May 1, 2016
1 parent 032e1db commit f1c6711c733885738a323c7392e1d912921bc881
Showing with 46 additions and 28 deletions.
  1. +2 −1 src/Stack/Build.hs
  2. +31 −22 src/Stack/Build/Execute.hs
  3. +4 −3 src/Stack/Ghci.hs
  4. +2 −1 src/Stack/Ide.hs
  5. +2 −1 src/Stack/SDist.hs
  6. +4 −0 src/Stack/Types/StackT.hs
  7. +1 −0 stack.cabal
@@ -61,14 +61,15 @@ import Stack.GhcPkg
import Stack.Package
import Stack.Types
import Stack.Types.Internal
import System.Console.Regions (LiftRegion)
import System.FileLock (FileLock, unlockFile)

#ifdef WINDOWS
import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP)
import qualified Control.Monad.Catch as Catch
#endif

type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env, LiftRegion m)

-- | Build.
--
@@ -81,6 +81,7 @@ import Stack.PackageDump
import Stack.Types
import Stack.Types.Internal
import Stack.Types.StackT
import System.Console.Regions
import qualified System.Directory as D
import System.Environment (getExecutablePath)
import System.Exit (ExitCode (ExitSuccess))
@@ -95,7 +96,7 @@ import System.Process.Run
import System.Process.Internals (createProcess_)
#endif

type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env, HasConfig env)
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env, HasConfig env, LiftRegion m)

-- | Fetch the packages necessary for a build, for example in combination with a dry run.
preFetch :: M env m => Plan -> m ()
@@ -526,22 +527,23 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do
then concurrentTests
else True
terminal <- asks getTerminal
errs <- liftIO $ runActions threads keepGoing concurrentFinal actions $ \doneVar -> do
let total = length actions
loop prev
| prev == total =
runInBase $ $logStickyDone ("Completed " <> T.pack (show total) <> " action(s).")
| otherwise = do
when terminal $ runInBase $
$logSticky ("Progress: " <> T.pack (show prev) <> "/" <> T.pack (show total))
errs <- liftIO $ displayConsoleRegions $ runActions threads keepGoing concurrentFinal actions $ \doneVar -> do
withConsoleRegion Linear $ \r -> do
let total = length actions
loop prev
| prev == total =
finishConsoleRegion r ("Completed " <> show total <> " action(s).")
| otherwise = do
when terminal $ do
setConsoleRegion r ("Progress: " <> show prev <> "/" <> show total)
done <- atomically $ do
done <- readTVar doneVar
check $ done /= prev
return done
loop done
if total > 1
then loop 0
else return ()
if total > 1
then loop 0
else return ()
when (toCoverage $ boptsTestOpts eeBuildOpts) $ do
generateHpcUnifiedReport
generateHpcMarkupIndex
@@ -727,12 +729,16 @@ ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp = do

return needConfig

announceTask :: MonadLogger m => Task -> Text -> m ()
announceTask task x = $logInfo $ T.concat
[ T.pack $ packageIdentifierString $ taskProvides task
, ": "
, x
]
announceTask :: LiftRegion m => ConsoleRegion -> Task -> Text -> m ()
announceTask r task x = setConsoleRegion r $ T.concat
[ T.pack $ packageIdentifierString $ taskProvides task
, ": "
, x
]

finishTask :: LiftRegion m => ConsoleRegion -> Task -> m ()
finishTask r task = finishConsoleRegion r $ T.concat
[T.pack $ packageIdentifierString $ taskProvides task, ": done"]

withSingleContext :: M env m
=> (m () -> IO ())
@@ -757,10 +763,12 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
withPackage $ \package cabalfp pkgDir ->
withLogFile package $ \mlogFile ->
withCabal package pkgDir mlogFile $ \cabal ->
inner0 package cabalfp pkgDir cabal announce console mlogFile
withConsoleRegion Linear $ \r -> do
let announce = announceTask r task
result <- inner0 package cabalfp pkgDir cabal announce console mlogFile
finishTask r task
return result
where
announce = announceTask task

wanted =
case taskType of
TTLocal lp -> lpWanted lp
@@ -1007,7 +1015,8 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in

copyPreCompiled (PrecompiledCache mlib exes) = do
wc <- getWhichCompiler
announceTask task "using precompiled package"
withConsoleRegion Linear $ \r ->
announceTask r task "using precompiled package"
forM_ mlib $ \libpath -> do
menv <- getMinimalEnvOverride
withMVar eeInstallLock $ \() -> do
@@ -54,6 +54,7 @@ import Stack.Exec
import Stack.Package
import Stack.Types
import Stack.Types.Internal
import System.Console.Regions (LiftRegion)
import Text.Read (readMaybe)

#ifndef WINDOWS
@@ -105,7 +106,7 @@ instance Show GhciException where
-- given options and configure it with the load paths and extensions
-- of those targets.
ghci
:: (HasConfig r, HasBuildConfig r, HasHttpManager r, MonadMask m, HasLogLevel r, HasTerminal r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)
:: (HasConfig r, HasBuildConfig r, HasHttpManager r, MonadMask m, HasLogLevel r, HasTerminal r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m, LiftRegion m)
=> GhciOpts -> m ()
ghci opts@GhciOpts{..} = do
bopts <- asks (configBuild . getConfig)
@@ -256,11 +257,11 @@ figureOutMainFile bopts mainIsTargets targets0 packages =
-- | Create a list of infos for each target containing necessary
-- information to load that package/components.
ghciSetup
:: (HasConfig r, HasHttpManager r, HasBuildConfig r, MonadMask m, HasTerminal r, HasLogLevel r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)
:: (HasConfig r, HasHttpManager r, HasBuildConfig r, MonadMask m, HasTerminal r, HasLogLevel r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m, LiftRegion m)
=> GhciOpts
-> m (Map PackageName SimpleTarget, Maybe (Map PackageName SimpleTarget), [GhciPkgInfo])
ghciSetup GhciOpts{..} = do
(_,_,targets) <- parseTargetsFromBuildOpts AllowNoTargets ghciBuildOptsCLI
(_,_,targets) <- parseTargetsFromBuildOpts AllowNoTargets ghciBuildOptsCLI
mainIsTargets <-
case ghciMainIs of
Nothing -> return Nothing
@@ -31,6 +31,7 @@ import Stack.Ghci (GhciPkgInfo(..), GhciOpts(..), ghciSetup)
import Stack.Package
import Stack.Types
import Stack.Types.Internal
import System.Console.Regions (LiftRegion)
import System.Environment (lookupEnv)
import System.FilePath (searchPathSeparator)
import System.Process.Run
@@ -39,7 +40,7 @@ import System.Process.Run
-- given options and configure it with the load paths and extensions
-- of those targets.
ide
:: (HasConfig r, HasBuildConfig r, HasTerminal r, HasLogLevel r, MonadMask m, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m, HasHttpManager r)
:: (HasConfig r, HasBuildConfig r, HasTerminal r, HasLogLevel r, MonadMask m, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m, HasHttpManager r, LiftRegion m)
=> [Text] -- ^ Targets.
-> [String] -- ^ GHC options.
-> m ()
@@ -57,6 +57,7 @@ import Stack.Constants
import Stack.Package
import Stack.Types
import Stack.Types.Internal
import System.Console.Regions (LiftRegion)
import System.Directory (getModificationTime, getPermissions)
import qualified System.FilePath as FP

@@ -74,7 +75,7 @@ instance Show CheckException where
"Package check reported the following errors:\n" ++
(intercalate "\n" . fmap show . NE.toList $ xs)

type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env,LiftRegion m)

-- | Given the path to a local package, creates its source
-- distribution tarball.
@@ -52,6 +52,7 @@ import Network.HTTP.Conduit
import Prelude -- Fix AMP warning
import Stack.Types.Internal
import Stack.Types.Config (GlobalOpts (..))
import System.Console.Regions (LiftRegion(..))
import System.IO
import System.Log.FastLogger

@@ -86,6 +87,9 @@ instance MonadTransControl (StackT config) where
instance (MonadIO m) => MonadLogger (StackT config m) where
monadLoggerLog = stickyLoggerFunc

instance MonadIO m => LiftRegion (StackT config m) where
liftRegion = liftIO . liftRegion

-- | Run a Stack action, using global options.
runStackTGlobal :: (MonadIO m,MonadBaseControl IO m)
=> Manager -> config -> GlobalOpts -> StackT config m a -> m a
@@ -150,6 +150,7 @@ library
, blaze-builder
, byteable
, bytestring
, concurrent-output >= 1.7
, conduit >= 1.2.4
, conduit-extra >= 1.1.7.1
, containers >= 0.5.5.1

0 comments on commit f1c6711

Please sign in to comment.
You can’t perform that action at this time.