WIP use concurrent-output for build plan execution updates.

mboes · May 1, 2016 · f1c6711c733885738a323c7392e1d912921bc881 · f1c6711
1 parent 032e1db
commit f1c6711c733885738a323c7392e1d912921bc881
Unified Split

Showing with 46 additions and 28 deletions.

+2 −1 src/Stack/Build.hs

+31 −22 src/Stack/Build/Execute.hs

+4 −3 src/Stack/Ghci.hs

+2 −1 src/Stack/Ide.hs

+2 −1 src/Stack/SDist.hs

+4 −0 src/Stack/Types/StackT.hs

+1 −0 stack.cabal
diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs
@@ -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.
 --
diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs
@@ -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
diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs
@@ -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
diff --git a/src/Stack/Ide.hs b/src/Stack/Ide.hs
@@ -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 ()
diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs
@@ -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.
diff --git a/src/Stack/Types/StackT.hs b/src/Stack/Types/StackT.hs
@@ -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
diff --git a/stack.cabal b/stack.cabal
@@ -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