Concurrently run jobs for multiple commits

Changelog: Concurrently run jobs for multiple commits

5 files changed, 94 insertions, 26 deletions

diff --git a/minici.cabal b/minici.cabal
index 7f20ac1..6b298f6 100644
--- a/minici.cabal
+++ b/minici.cabal
@@ -54,6 +54,7 @@ executable minici
         Job.Types
         Paths_minici
         Repo
+        Terminal
         Version
         Version.Git
     autogen-modules:
diff --git a/src/Command.hs b/src/Command.hs
index 2c2235f..c602ba8 100644
--- a/src/Command.hs
+++ b/src/Command.hs
@@ -6,8 +6,10 @@ module Command (
     CommandArgumentsType(..),
 
     CommandExec(..),
+    CommandInput(..),
     getCommonOptions,
     getConfig,
+    getTerminalOutput,
 ) where
 
 import Control.Monad.Except
@@ -20,6 +22,7 @@ import Data.Text qualified as T
 import System.Console.GetOpt
 
 import Config
+import Terminal
 
 data CommonOptions = CommonOptions
     { optJobs :: Int
@@ -67,11 +70,20 @@ instance CommandArgumentsType (Maybe Text) where
     argsFromStrings _ = throwError "expected at most one argument"
 
 
-newtype CommandExec a = CommandExec (ReaderT ( CommonOptions, Config ) IO a)
+newtype CommandExec a = CommandExec (ReaderT CommandInput IO a)
     deriving (Functor, Applicative, Monad, MonadIO)
 
+data CommandInput = CommandInput
+    { ciOptions :: CommonOptions
+    , ciConfig :: Config
+    , ciTerminalOutput :: TerminalOutput
+    }
+
 getCommonOptions :: CommandExec CommonOptions
-getCommonOptions = CommandExec (asks fst)
+getCommonOptions = CommandExec (asks ciOptions)
 
 getConfig :: CommandExec Config
-getConfig = CommandExec (asks snd)
+getConfig = CommandExec (asks ciConfig)
+
+getTerminalOutput :: CommandExec TerminalOutput
+getTerminalOutput = CommandExec (asks ciTerminalOutput)
diff --git a/src/Command/Run.hs b/src/Command/Run.hs
index a2436c8..7c169b2 100644
--- a/src/Command/Run.hs
+++ b/src/Command/Run.hs
@@ -11,16 +11,16 @@ import Data.List
 import Data.Maybe
 import Data.Text (Text)
 import Data.Text qualified as T
-import Data.Text.IO qualified as T
 
 import System.Exit
-import System.IO
 import System.Process
 
 import Command
 import Config
 import Job
 import Repo
+import Terminal
+
 
 data RunCommand = RunCommand Text
 
@@ -56,6 +56,7 @@ cmdRun (RunCommand changeset) = do
             return ( base, tip )
         [] -> error "splitOn should not return empty list"
 
+    tout <- getTerminalOutput
     liftIO $ do
         mngr <- newJobManager optJobs
         Just repo <- openRepo "."
@@ -63,12 +64,11 @@ cmdRun (RunCommand changeset) = do
         jobssets <- mapM loadJobSetForCommit commits
         let names = nub $ map jobName $ concatMap jobsetJobs jobssets
 
-        putStr $ replicate (8 + 50) ' '
-        forM_ names $ \name -> do
-            T.putStr $ (" "<>) $ fitToLength 7 $ textJobName name
-        putStrLn ""
+        void $ newLine tout $ T.concat $
+            T.replicate (8 + 50) " " :
+            map ((" "<>) . fitToLength 7 . textJobName) names
 
-        forM_ jobssets $ \jobset -> do
+        statuses <- forM jobssets $ \jobset -> do
             let commit = jobsetCommit jobset
                 shortCid = T.pack $ take 7 $ showCommitId $ commitId commit
                 shortDesc = fitToLength 50 (commitDescription commit)
@@ -76,10 +76,17 @@ cmdRun (RunCommand changeset) = do
                 Right jobs -> do
                     outs <- runJobs mngr "./.minici" commit jobs
                     let findJob name = snd <$> find ((name ==) . jobName . fst) outs
-                    displayStatusLine shortCid (" " <> shortDesc) $ map findJob names
+                    displayStatusLine tout shortCid (" " <> shortDesc) $ map findJob names
+                    return $ map snd outs
                 Left err -> do
-                    T.putStrLn $ "\ESC[91m" <> shortCid <> "\ESC[0m" <> " " <> shortDesc <> " \ESC[91m" <> T.pack err <> "\ESC[0m"
-                    hFlush stdout
+                    void $ newLine tout $
+                        "\ESC[91m" <> shortCid <> "\ESC[0m" <> " " <> shortDesc <> " \ESC[91m" <> T.pack err <> "\ESC[0m"
+                    return []
+
+        -- wait for all jobs to complete
+        atomically $ forM_ (concat statuses) $ \tvar -> do
+            status <- readTVar tvar
+            when (not $ jobStatusFinished status) retry
 
 
 fitToLength :: Int -> Text -> Text
@@ -97,29 +104,30 @@ showStatus blink = \case
     JobFailed       -> "\ESC[91m✗\ESC[0m      "
     JobDone _       -> "\ESC[92m✓\ESC[0m      "
 
-displayStatusLine :: Text -> Text -> [ Maybe (TVar (JobStatus JobOutput)) ] -> IO ()
-displayStatusLine prefix1 prefix2 statuses = do
+displayStatusLine :: TerminalOutput -> Text -> Text -> [ Maybe (TVar (JobStatus JobOutput)) ] -> IO ()
+displayStatusLine tout prefix1 prefix2 statuses = do
     blinkVar <- newTVarIO False
     t <- forkIO $ forever $ do
         threadDelay 500000
         atomically $ writeTVar blinkVar . not =<< readTVar blinkVar
-    go blinkVar "\0"
-    killThread t
+    line <- newLine tout ""
+    void $ forkIO $ do
+        go line blinkVar "\0"
+        killThread t
   where
-    go blinkVar prev = do
+    go line blinkVar prev = do
         (ss, cur) <- atomically $ do
             ss <- mapM (sequence . fmap readTVar) statuses
             blink <- readTVar blinkVar
             let cur = T.concat $ map (maybe "        " ((" " <>) . showStatus blink)) ss
             when (cur == prev) retry
             return (ss, cur)
-        when (not $ T.null prev) $ putStr "\r"
+
         let prefix1' = if any (maybe False jobStatusFailed) ss
                          then "\ESC[91m" <> prefix1 <> "\ESC[0m"
                          else prefix1
-        T.putStr $ prefix1' <> prefix2 <> cur
-        hFlush stdout
+        redrawLine line $ prefix1' <> prefix2 <> cur
 
         if all (maybe True jobStatusFinished) ss
-           then T.putStrLn ""
-           else go blinkVar cur
+           then return ()
+           else go line blinkVar cur
diff --git a/src/Main.hs b/src/Main.hs
index c693281..d24642d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -17,6 +17,7 @@ import System.IO
 import Command
 import Command.Run
 import Config
+import Terminal
 import Version
 
 data CmdlineOptions = CmdlineOptions
@@ -120,7 +121,7 @@ fullCommandOptions proxy =
     ]
 
 runSomeCommand :: CommonOptions -> SomeCommandType -> [ String ] -> IO ()
-runSomeCommand copts (SC tproxy) args = do
+runSomeCommand ciOptions (SC tproxy) args = do
     let exitWithErrors errs = do
             hPutStrLn stderr $ concat errs <> "Try `minici " <> commandName tproxy <> " --help' for more information."
             exitFailure
@@ -142,7 +143,8 @@ runSomeCommand copts (SC tproxy) args = do
         Left err -> do
             putStr err
             exitFailure
-        Right config -> do
+        Right ciConfig -> do
             let cmd = commandInit tproxy (fcoSpecific opts) cmdargs
             let CommandExec exec = commandExec cmd
-            flip runReaderT ( copts, config ) exec
+            ciTerminalOutput <- initTerminalOutput
+            flip runReaderT CommandInput {..} exec
diff --git a/src/Terminal.hs b/src/Terminal.hs
new file mode 100644
index 0000000..bf50c58
--- /dev/null
+++ b/src/Terminal.hs
@@ -0,0 +1,45 @@
+module Terminal (
+    TerminalOutput,
+    TerminalLine,
+    initTerminalOutput,
+    newLine,
+    redrawLine,
+) where
+
+import Control.Concurrent
+
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+
+import System.IO
+
+
+data TerminalOutput = TerminalOutput
+    { outNumLines :: MVar Int
+    }
+
+data TerminalLine = TerminalLine
+    { lineOutput :: TerminalOutput
+    , lineNum :: Int
+    }
+
+initTerminalOutput :: IO TerminalOutput
+initTerminalOutput = do
+    outNumLines <- newMVar 0
+    return TerminalOutput {..}
+
+newLine :: TerminalOutput -> Text -> IO TerminalLine
+newLine lineOutput@TerminalOutput {..} text = do
+    modifyMVar outNumLines $ \lineNum -> do
+        T.putStrLn text
+        hFlush stdout
+        return ( lineNum + 1, TerminalLine {..} )
+
+redrawLine :: TerminalLine -> Text -> IO ()
+redrawLine TerminalLine {..} text = do
+    let TerminalOutput {..} = lineOutput
+    withMVar outNumLines $ \total -> do
+        let moveBy = total - lineNum
+        T.putStr $ "\ESC[s\ESC[" <> T.pack (show moveBy) <> "F" <> text <> "\ESC[u"
+        hFlush stdout