summaryrefslogtreecommitdiff
path: root/src/Main.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2023-01-21 21:05:37 +0100
committerRoman Smrž <roman.smrz@seznam.cz>2023-01-24 19:34:25 +0100
commit50c956a4dac59760598c1e272c375ed0ec1bd98d (patch)
tree0fe996b9126623ae112a485dab92435f5bf02a4b /src/Main.hs
parent048529bcb06601ee4ff91190b823ba00beba1a6a (diff)
Detailed and continuously updated job status
Diffstat (limited to 'src/Main.hs')
-rw-r--r--src/Main.hs70
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