Detailed and continuously updated job status

1 files changed, 48 insertions, 22 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 8ba28d1..4e99c5f 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,19 +1,60 @@
 module Main (main) where
 
+import Control.Concurrent
 import Control.Concurrent.STM
 
 import Control.Monad
 
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+
 import System.IO
 import System.Process
 
 import Config
 import Job
 
-fitToLength :: Int -> String -> String
-fitToLength maxlen str | len <= maxlen = str <> replicate (maxlen - len) ' '
-                       | otherwise     = take (maxlen - 1) str <> "…"
-    where len = length str
+fitToLength :: Int -> Text -> Text
+fitToLength maxlen str | len <= maxlen = str <> T.replicate (maxlen - len) " "
+                       | otherwise     = T.take (maxlen - 1) str <> "…"
+    where len = T.length str
+
+showStatus :: Bool -> JobStatus a -> Text
+showStatus blink = \case
+    JobQueued       -> "\ESC[94m…\ESC[0m      "
+    JobWaiting uses -> "\ESC[94m~" <> fitToLength 6 (T.intercalate "," (map textJobName uses)) <> "\ESC[0m"
+    JobSkipped      ->  "\ESC[0m-\ESC[0m      "
+    JobRunning      -> "\ESC[96m" <> (if blink then "*" else "⋅") <> "\ESC[0m      "
+    JobError _      -> "\ESC[91m!!\ESC[0m     "
+    JobFailed       -> "\ESC[91m✗\ESC[0m      "
+    JobDone _       -> "\ESC[92m✓\ESC[0m      "
+
+displayStatusLine :: Text -> Text -> [TVar (JobStatus JobOutput)] -> IO ()
+displayStatusLine prefix1 prefix2 statuses = do
+    blinkVar <- newTVarIO False
+    t <- forkIO $ forever $ do
+        threadDelay 500000
+        atomically $ writeTVar blinkVar . not =<< readTVar blinkVar
+    go blinkVar ""
+    killThread t
+  where
+    go blinkVar prev = do
+        (ss, cur) <- atomically $ do
+            ss <- mapM readTVar statuses
+            blink <- readTVar blinkVar
+            let cur = T.concat $ map ((" " <>) . showStatus blink) ss
+            when (cur == prev) retry
+            return (ss, cur)
+        when (not $ T.null prev) $ putStr "\r"
+        let prefix1' = if any jobStatusFailed ss then "\ESC[91m" <> prefix1 <> "\ESC[0m"
+                                                 else prefix1
+        T.putStr $ prefix1' <> prefix2 <> cur
+        hFlush stdout
+
+        if all jobStatusFinished ss
+           then T.putStrLn ""
+           else go blinkVar cur
 
 main :: IO ()
 main = do
@@ -25,25 +66,10 @@ main = do
 
     putStr $ replicate (8 + 50) ' '
     forM_ (configJobs config) $ \job -> do
-        putStr $ (' ':) $ fitToLength 7 $ stringJobName $ jobName job
+        T.putStr $ (" "<>) $ fitToLength 7 $ textJobName $ jobName job
     putStrLn ""
 
     forM_ commits $ \(cid, desc) -> do
-        let shortCid = take 7 cid
-        putStr $ shortCid <> " " <> fitToLength 50 desc
-        hFlush stdout
+        let shortCid = T.pack $ take 7 cid
         outs <- runJobs "./.minici" cid $ configJobs config
-        results <- forM outs $ \outVar -> do
-            putStr " "
-            hFlush stdout
-            out <- atomically $ maybe retry return =<< readTVar outVar
-            if | outStatus out -> do
-                    putStr "\ESC[92m✓\ESC[0m      "
-               | otherwise -> do
-                    putStr "\ESC[91m✗\ESC[0m      "
-            hFlush stdout
-            return $ outStatus out
-
-        when (not $ and results) $ do
-            putStr $ "\r\ESC[91m" <> shortCid <> "\ESC[0m"
-        putStrLn ""
+        displayStatusLine shortCid (" " <> fitToLength 50 (T.pack desc)) outs