diff options
| -rw-r--r-- | src/Command/Run.hs | 4 | ||||
| -rw-r--r-- | src/Job.hs | 31 | ||||
| -rw-r--r-- | src/Terminal.hs | 23 |
3 files changed, 41 insertions, 17 deletions
diff --git a/src/Command/Run.hs b/src/Command/Run.hs index b297ec1..fd5b6d7 100644 --- a/src/Command/Run.hs +++ b/src/Command/Run.hs @@ -261,7 +261,7 @@ cmdRun (RunCommand RunOptions {..} args) = do case jobsetJobsEither jobset of Right jobs -> do - outs <- runJobs mngr commit jobs + outs <- runJobs mngr tout commit jobs let findJob name = snd <$> find ((name ==) . jobName . fst) outs line <- newLine tout "" mask $ \restore -> do @@ -291,7 +291,7 @@ showStatus blink = \case 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 " + JobError fnote -> "\ESC[91m" <> fitToLength 7 ("!! [" <> T.pack (show (footnoteNumber fnote)) <> "]") <> "\ESC[0m" JobFailed -> "\ESC[91m✗\ESC[0m " JobCancelled -> "\ESC[0mC\ESC[0m " JobDone _ -> "\ESC[92m✓\ESC[0m " @@ -38,6 +38,7 @@ import System.Process import Job.Types import Repo +import Terminal data JobOutput = JobOutput @@ -59,7 +60,7 @@ data JobStatus a = JobQueued | JobWaiting [JobName] | JobRunning | JobSkipped - | JobError Text + | JobError TerminalFootnote | JobFailed | JobCancelled | JobDone a @@ -87,7 +88,7 @@ textJobStatus = \case JobWaiting _ -> "waiting" JobRunning -> "running" JobSkipped -> "skipped" - JobError err -> "error\n" <> err + JobError err -> "error\n" <> footnoteText err JobFailed -> "failed" JobCancelled -> "cancelled" JobDone _ -> "done" @@ -179,8 +180,8 @@ runManagedJob JobManager {..} tid cancel job = bracket acquire release $ \case writeTVar jmRunningTasks . M.delete tid =<< readTVar jmRunningTasks -runJobs :: JobManager -> Maybe Commit -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ] -runJobs mngr@JobManager {..} commit jobs = do +runJobs :: JobManager -> TerminalOutput -> Maybe Commit -> [ Job ] -> IO [ ( Job, TVar (JobStatus JobOutput) ) ] +runJobs mngr@JobManager {..} tout commit jobs = do tree <- sequence $ fmap getCommitTree commit results <- atomically $ do forM jobs $ \job -> do @@ -197,9 +198,12 @@ runJobs mngr@JobManager {..} commit jobs = do return statusVar forM_ results $ \( job, tid, outVar ) -> void $ forkIO $ do - let handler e = atomically $ writeTVar outVar $ if - | Just JobCancelledException <- fromException e -> JobCancelled - | otherwise -> JobError (T.pack $ displayException e) + let handler e = if + | Just JobCancelledException <- fromException e -> do + atomically $ writeTVar outVar $ JobCancelled + | otherwise -> do + footnote <- newFootnote tout $ T.pack $ displayException e + atomically $ writeTVar outVar $ JobError footnote handle handler $ do res <- runExceptT $ do duplicate <- liftIO $ atomically $ do @@ -211,7 +215,7 @@ runJobs mngr@JobManager {..} commit jobs = do case duplicate of Nothing -> do - uses <- waitForUsedArtifacts job results outVar + uses <- waitForUsedArtifacts tout job results outVar runManagedJob mngr tid (return JobCancelled) $ do liftIO $ atomically $ writeTVar outVar JobRunning prepareJob jmDataDir commit job $ \checkoutPath jdir -> do @@ -233,21 +237,18 @@ runJobs mngr@JobManager {..} commit jobs = do else wait liftIO wait - case res of - Left (JobError err) -> T.putStrLn err - _ -> return () - atomically $ writeTVar outVar $ either id id res return $ map (\( job, _, var ) -> ( job, var )) results waitForUsedArtifacts :: (MonadIO m, MonadError (JobStatus JobOutput) m) => + TerminalOutput -> Job -> [ ( Job, TaskId, TVar (JobStatus JobOutput) ) ] -> TVar (JobStatus JobOutput) -> m [ ArtifactOutput ] -waitForUsedArtifacts job results outVar = do +waitForUsedArtifacts tout job results outVar = do origState <- liftIO $ atomically $ readTVar outVar ujobs <- forM (jobUses job) $ \(ujobName@(JobName tjobName), uartName) -> do case find (\( j, _, _ ) -> jobName j == ujobName) results of Just ( _, _, var ) -> return ( var, ( ujobName, uartName )) - Nothing -> throwError $ JobError $ "Job '" <> tjobName <> "' not found" + Nothing -> throwError . JobError =<< liftIO (newFootnote tout $ "Job '" <> tjobName <> "' not found") let loop prev = do ustatuses <- atomically $ do @@ -266,7 +267,7 @@ waitForUsedArtifacts job results outVar = do case ustatus of JobDone out -> case find ((==uartName) . aoutName) $ outArtifacts out of Just art -> return art - Nothing -> throwError $ JobError $ "Artifact '" <> tjobName <> "." <> tartName <> "' not found" + Nothing -> throwError . JobError =<< liftIO (newFootnote tout $ "Artifact '" <> tjobName <> "." <> tartName <> "' not found") _ -> throwError JobSkipped updateStatusFile :: MonadIO m => FilePath -> TVar (JobStatus JobOutput) -> m () diff --git a/src/Terminal.hs b/src/Terminal.hs index 84dfb91..aa7335c 100644 --- a/src/Terminal.hs +++ b/src/Terminal.hs @@ -1,9 +1,11 @@ module Terminal ( TerminalOutput, TerminalLine, + TerminalFootnote(..), initTerminalOutput, newLine, redrawLine, + newFootnote, terminalBlinkStatus, ) where @@ -11,6 +13,7 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Monad +import Data.Function import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T @@ -20,17 +23,30 @@ import System.IO data TerminalOutput = TerminalOutput { outNumLines :: MVar Int + , outNextFootnote :: MVar Int , outBlinkVar :: TVar Bool } +instance Eq TerminalOutput where + (==) = (==) `on` outNumLines + data TerminalLine = TerminalLine { lineOutput :: TerminalOutput , lineNum :: Int } + deriving (Eq) + +data TerminalFootnote = TerminalFootnote + { footnoteLine :: TerminalLine + , footnoteNumber :: Int + , footnoteText :: Text + } + deriving (Eq) initTerminalOutput :: IO TerminalOutput initTerminalOutput = do outNumLines <- newMVar 0 + outNextFootnote <- newMVar 1 outBlinkVar <- newTVarIO False void $ forkIO $ forever $ do threadDelay 500000 @@ -52,5 +68,12 @@ redrawLine TerminalLine {..} text = do T.putStr $ "\ESC[s\ESC[" <> T.pack (show moveBy) <> "F" <> text <> "\ESC[u" hFlush stdout +newFootnote :: TerminalOutput -> Text -> IO TerminalFootnote +newFootnote tout@TerminalOutput {..} footnoteText = do + modifyMVar outNextFootnote $ \footnoteNumber -> do + footnoteLine <- newLine tout $ "[" <> T.pack (show footnoteNumber) <> "] " <> footnoteText + hFlush stdout + return ( footnoteNumber + 1, TerminalFootnote {..} ) + terminalBlinkStatus :: TerminalOutput -> STM Bool terminalBlinkStatus TerminalOutput {..} = readTVar outBlinkVar |