Footnotes for errors in terminal output

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      "
diff --git a/src/Job.hs b/src/Job.hs
index 820f5e5..4b20c0e 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -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