Move OutputFootnote outside of JobStatus

2 files changed, 75 insertions, 66 deletions

diff --git a/src/Command/Run.hs b/src/Command/Run.hs
index dd56cf7..6a0fcd4 100644
--- a/src/Command/Run.hs
+++ b/src/Command/Run.hs
@@ -434,39 +434,42 @@ 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 fnote  -> "\ESC[91m" <> fitToLength 7 ("!! [" <> T.pack (maybe "?" (show . tfNumber) (either (const Nothing) footnoteTerminal fnote)) <> "]") <> "\ESC[0m"
-    JobFailed       -> " \ESC[91m✗\ESC[0m     "
-    JobCancelled    ->  " \ESC[0mC\ESC[0m     "
-    JobDone _       -> " \ESC[92m✓\ESC[0m     "
+showStatus :: Int -> Bool -> ( JobStatus a, [ OutputFootnote ] ) -> Text
+showStatus width blink ( status, fnotes ) = case status of
+    JobQueued       -> " \ESC[94m…\ESC[0m" <> showNotes (width - 2)
+    JobWaiting uses -> "\ESC[94m~" <> fitToLength (width - 1) (T.intercalate "," (map textJobName uses) <> showNotes (width - 1)) <> "\ESC[0m"
+    JobSkipped      ->  " \ESC[0m-\ESC[0m" <> showNotes (width - 2)
+    JobRunning      -> " \ESC[96m" <> (if blink then "*" else "•") <> "\ESC[0m" <> showNotes 5
+    JobError _      -> "\ESC[91m!!\ESC[0m" <> showNotes (width - 2)
+    JobFailed       -> " \ESC[91m✗\ESC[0m" <> showNotes (width - 2)
+    JobCancelled    ->  " \ESC[0mC\ESC[0m" <> showNotes (width - 2)
+    JobDone _       -> " \ESC[92m✓\ESC[0m" <> showNotes (width - 2)
 
     JobDuplicate _ s -> case s of
-        JobQueued    -> " \ESC[94m^\ESC[0m     "
-        JobWaiting _ -> " \ESC[94m^\ESC[0m     "
-        JobSkipped   ->  " \ESC[0m-\ESC[0m     "
-        JobRunning   -> " \ESC[96m" <> (if blink then "*" else "^") <> "\ESC[0m     "
-        _            -> showStatus blink s
-
-    JobPreviousStatus (JobDone _) -> "\ESC[90m«\ESC[32m✓\ESC[0m     "
-    JobPreviousStatus (JobFailed) -> "\ESC[90m«\ESC[31m✗\ESC[0m     "
-    JobPreviousStatus s           -> "\ESC[90m«" <> T.init (showStatus blink s)
+        JobQueued    -> " \ESC[94m^\ESC[0m" <> showNotes (width - 2)
+        JobWaiting _ -> " \ESC[94m^\ESC[0m" <> showNotes (width - 2)
+        JobSkipped   ->  " \ESC[0m-\ESC[0m" <> showNotes (width - 2)
+        JobRunning   -> " \ESC[96m" <> (if blink then "*" else "^") <> "\ESC[0m" <> showNotes (width - 2)
+        _            -> showStatus width blink ( s, fnotes )
+
+    JobPreviousStatus (JobDone _) -> "\ESC[90m«\ESC[32m✓\ESC[0m" <> showNotes (width - 2)
+    JobPreviousStatus (JobFailed) -> "\ESC[90m«\ESC[31m✗\ESC[0m" <> showNotes (width - 2)
+    JobPreviousStatus s           -> "\ESC[90m«\ESC[0m" <> showStatus (width - 1) blink ( s, fnotes )
+  where
+    showNotes w = fitToLength w $ T.concat $ " " : map showNote fnotes
+    showNote fnote = "[" <> T.pack (maybe "?" (show . tfNumber) (footnoteTerminal fnote)) <> "]"
 
-displayStatusLine :: TerminalOutput -> TerminalLine -> Text -> Text -> [ Maybe (TVar (JobStatus JobOutput)) ] -> IO ()
+displayStatusLine :: TerminalOutput -> TerminalLine -> Text -> Text -> [ Maybe (TVar ( JobStatus JobOutput, [ OutputFootnote ] )) ] -> IO ()
 displayStatusLine tout line prefix1 prefix2 statuses = do
     go "\0"
   where
     go prev = do
-        (ss, cur) <- atomically $ do
-            ss <- mapM (sequence . fmap readTVar) statuses
+        ( ss, cur ) <- atomically $ do
+            sns <- mapM (sequence . fmap readTVar) statuses
             blink <- terminalBlinkStatus tout
-            let cur = T.concat $ map (maybe "        " ((" " <>) . showStatus blink)) ss
+            let cur = T.concat $ map (maybe "        " ((" " <>) . showStatus 7 blink)) sns
             when (cur == prev) retry
-            return (ss, cur)
+            return ( map (fmap fst) sns, cur )
 
         let prefix1' = if any (maybe False jobStatusFailed) ss
                          then "\ESC[91m" <> prefix1 <> "\ESC[0m"
@@ -477,9 +480,9 @@ displayStatusLine tout line prefix1 prefix2 statuses = do
            then return ()
            else go cur
 
-waitForJobStatuses :: [ Maybe (TVar (JobStatus a)) ] -> IO ()
+waitForJobStatuses :: [ Maybe (TVar ( JobStatus a, [ OutputFootnote ] )) ] -> IO ()
 waitForJobStatuses mbstatuses = do
     let statuses = catMaybes mbstatuses
     atomically $ do
         ss <- mapM readTVar statuses
-        when (any (not . jobStatusFinished) ss) retry
+        when (any (not . jobStatusFinished . fst) ss) retry
diff --git a/src/Job.hs b/src/Job.hs
index e94524e..0d54571 100644
--- a/src/Job.hs
+++ b/src/Job.hs
@@ -78,7 +78,7 @@ data JobStatus a
     | JobWaiting [JobName]
     | JobRunning
     | JobSkipped
-    | JobError (Either Text OutputFootnote)
+    | JobError Text
     | JobFailed
     | JobCancelled
     | JobDone a
@@ -126,7 +126,7 @@ readJobStatus text readResult = case T.lines text of
     "queued" : _ -> return (Just JobQueued)
     "running" : _ -> return (Just JobRunning)
     "skipped" : _ -> return (Just JobSkipped)
-    "error" : note : _ -> return (Just $ JobError $ Left note)
+    "error" : note : _ -> return (Just $ JobError note)
     "failed" : _ -> return (Just JobFailed)
     "cancelled" : _ -> return (Just JobCancelled)
     "done" : _ -> Just . JobDone <$> readResult
@@ -134,20 +134,20 @@ readJobStatus text readResult = case T.lines text of
 
 textJobStatusDetails :: JobStatus a -> Text
 textJobStatusDetails = \case
-    JobError err -> either id footnoteText err <> "\n"
+    JobError err -> err <> "\n"
     JobPreviousStatus s -> textJobStatusDetails s
     _ -> ""
 
-printStatusError :: MonadIO m => Output -> JobStatus a -> m (JobStatus a)
+printStatusError :: MonadIO m => Output -> JobStatus a -> m [ OutputFootnote ]
 printStatusError tout = \case
-    JobError (Left note) -> JobError . Right <$> liftIO (outputFootnote tout note)
-    status -> return status
+    JobError note -> (: []) <$> liftIO (outputFootnote tout note)
+    _ -> return []
 
 
 data JobManager = JobManager
     { jmMaxRunningTasks :: Int
     , jmDataDir :: FilePath
-    , jmJobs :: TVar (Map JobId (TVar (JobStatus JobOutput)))
+    , jmJobs :: TVar (Map JobId (TVar ( JobStatus JobOutput, [ OutputFootnote ] )))
     , jmNextTaskId :: TVar TaskId
     , jmReadyTasks :: TVar (Set TaskId)
     , jmRunningTasks :: TVar (Map TaskId ThreadId)
@@ -159,7 +159,7 @@ data Task = Task
     { taskId :: TaskId
     , taskJob :: Job
     , taskThread :: ThreadId
-    , taskStatus :: TVar (JobStatus JobOutput)
+    , taskStatus :: TVar ( JobStatus JobOutput, [ OutputFootnote ] )
     }
 
 newtype TaskId = TaskId Int
@@ -237,26 +237,27 @@ runJobs mngr@JobManager {..} tout jobs rerun = do
             ( job, tid, ) <$> case M.lookup (jobId job) managed of
                 Just origVar -> do
                     readTVar origVar >>= \case
-                        JobCancelled -> do
+                        ( JobCancelled, notes ) -> do
                             -- Restart previously cancelled job
-                            statusVar <- newTVar JobQueued
+                            statusVar <- newTVar ( JobQueued, notes )
                             writeTVar jmJobs $ M.insert (jobId job) statusVar managed
                             return statusVar
-                        pstatus -> do
-                            newTVar $ JobDuplicate (jobId job) pstatus
+                        ( pstatus, notes ) -> do
+                            newTVar ( JobDuplicate (jobId job) pstatus, notes )
                 Nothing -> do
-                    statusVar <- newTVar JobQueued
+                    statusVar <- newTVar ( JobQueued, [] )
                     writeTVar jmJobs $ M.insert (jobId job) statusVar managed
                     return statusVar
 
     forM results $ \( taskJob, taskId, taskStatus ) -> do
         let handler e = do
-                status <- if
+                statusNote@( status, _ ) <- if
                     | Just JobCancelledException <- fromException e -> do
-                        return JobCancelled
+                        return ( JobCancelled, [] )
                     | otherwise -> do
-                        JobError . Right <$> outputFootnote tout (T.pack $ displayException e)
-                atomically $ writeTVar taskStatus status
+                        let err = T.pack $ displayException e
+                        ( JobError err, ) . (: []) <$> outputFootnote tout err
+                atomically $ writeTVar taskStatus statusNote
                 outputJobFinishedEvent tout taskJob status
 
         handlerInstalled <- newEmptyMVar
@@ -266,7 +267,7 @@ runJobs mngr@JobManager {..} tout jobs rerun = do
                 res <- runExceptT $ do
                     duplicate <- liftIO $ atomically $ do
                         readTVar taskStatus >>= \case
-                            JobDuplicate jid _ -> do
+                            ( JobDuplicate jid _, _ ) -> do
                                 fmap ( jid, ) . M.lookup jid <$> readTVar jmJobs
                             _ -> do
                                 return Nothing
@@ -276,16 +277,17 @@ runJobs mngr@JobManager {..} tout jobs rerun = do
                             let jdir = jmDataDir </> jobStorageSubdir (jobId taskJob)
                             readStatusFile taskJob jdir >>= \case
                                 Just status | status /= JobCancelled && not (rerun (jobId taskJob) status) -> do
-                                    status' <- JobPreviousStatus <$> printStatusError tout status
-                                    liftIO $ atomically $ writeTVar taskStatus status'
+                                    let status' = JobPreviousStatus status
+                                    notes <- printStatusError tout status
+                                    liftIO $ atomically $ writeTVar taskStatus ( status', notes )
                                     return status'
                                 mbStatus -> do
                                     when (isJust mbStatus) $ do
                                         liftIO $ removeDirectoryRecursive jdir
                                     liftIO $ outputEvent tout $ JobEnqueued (jobId taskJob)
-                                    uses <- waitForUsedArtifacts tout taskJob results taskStatus
+                                    uses <- waitForUsedArtifacts taskJob results taskStatus
                                     runManagedJob mngr taskId (return JobCancelled) $ do
-                                        liftIO $ atomically $ writeTVar taskStatus JobRunning
+                                        liftIO $ atomically $ writeTVar taskStatus ( JobRunning, [] )
                                         liftIO $ outputEvent tout $ JobStarted (jobId taskJob)
                                         prepareJob jmDataDir taskJob $ \checkoutPath -> do
                                             updateStatusFile mngr jdir taskStatus
@@ -294,20 +296,24 @@ runJobs mngr@JobManager {..} tout jobs rerun = do
                         Just ( jid, origVar ) -> do
                             let wait = do
                                     status <- atomically $ do
-                                        status <- readTVar origVar
-                                        out <- readTVar taskStatus
+                                        ( status, onotes ) <- readTVar origVar
+                                        ( out, _ ) <- readTVar taskStatus
                                         if status == out
                                           then retry
                                           else do
-                                            writeTVar taskStatus $ JobDuplicate jid status
+                                            writeTVar taskStatus ( JobDuplicate jid status, onotes )
                                             return status
                                     if jobStatusFinished status
                                       then return $ JobDuplicate jid status
                                       else wait
                             liftIO wait
 
-                atomically $ writeTVar taskStatus $ either id id res
-                outputJobFinishedEvent tout taskJob $ either id id res
+                let finalStatus = either id id res
+                rnotes <- either (printStatusError tout) (const $ return []) res
+                atomically $ do
+                    ( _, notes ) <- readTVar taskStatus
+                    writeTVar taskStatus ( finalStatus, notes ++ rnotes )
+                outputJobFinishedEvent tout taskJob finalStatus
         takeMVar handlerInstalled
         return Task {..}
 
@@ -319,22 +325,22 @@ waitForRemainingTasks JobManager {..} = do
 
 waitForUsedArtifacts
     :: (MonadIO m, MonadError (JobStatus JobOutput) m)
-    => Output -> Job
-    -> [ ( Job, TaskId, TVar (JobStatus JobOutput) ) ]
-    -> TVar (JobStatus JobOutput)
+    => Job
+    -> [ ( Job, TaskId, TVar ( JobStatus JobOutput, [ OutputFootnote ] ) ) ]
+    -> TVar ( JobStatus JobOutput, [ OutputFootnote ] )
     -> m [ ( ArtifactSpec Evaluated, ArtifactOutput ) ]
-waitForUsedArtifacts tout job results outVar = do
+waitForUsedArtifacts job results outVar = do
     origState <- liftIO $ atomically $ readTVar outVar
     let ( selfSpecs, artSpecs ) = partition ((jobId job ==) . fst) $ jobRequiredArtifacts job
 
     forM_ selfSpecs $ \( _, artName@(ArtifactName tname) ) -> do
         when (not (artName `elem` map fst (jobArtifacts job))) $ do
-            throwError . JobError . Right =<< liftIO (outputFootnote tout $ "Artifact ‘" <> tname <> "’ not produced by the job")
+            throwError $ JobError $ "Artifact ‘" <> tname <> "’ not produced by the job"
 
     ujobs <- forM artSpecs $ \( ujobId, uartName ) -> do
         case find (\( j, _, _ ) -> jobId j == ujobId) results of
             Just ( _, _, var ) -> return ( var, ( ujobId, uartName ))
-            Nothing -> throwError . JobError . Right =<< liftIO (outputFootnote tout $ "Job ‘" <> textJobId ujobId <> "’ not found")
+            Nothing -> throwError $ JobError $ "Job ‘" <> textJobId ujobId <> "’ not found"
 
     let loop prev = do
             ustatuses <- atomically $ do
@@ -342,19 +348,19 @@ waitForUsedArtifacts tout job results outVar = do
                     (, uartSpec) <$> readTVar uoutVar
                 when (Just (map fst ustatuses) == prev) retry
                 let remains = map (fromMaybe (JobName "?") . lastJobNameId . fst . snd) $
-                        filter (not . jobStatusFinished . fst) ustatuses
-                writeTVar outVar $ if null remains then origState else JobWaiting remains
+                        filter (not . jobStatusFinished . fst . fst) ustatuses
+                writeTVar outVar $ if null remains then origState else ( JobWaiting remains, [] )
                 return ustatuses
-            if all (jobStatusFinished . fst) ustatuses
+            if all (jobStatusFinished . fst . fst) ustatuses
                then return ustatuses
                else loop $ Just $ map fst ustatuses
     ustatuses <- liftIO $ loop Nothing
 
-    forM ustatuses $ \( ustatus, spec@( tjobId, uartName@(ArtifactName tartName)) ) -> do
+    forM ustatuses $ \( ( ustatus, _ ), spec@( tjobId, uartName@(ArtifactName tartName)) ) -> do
         case jobResult ustatus of
             Just out -> case find ((==uartName) . aoutName) $ outArtifacts out of
                 Just art -> return ( spec, art )
-                Nothing -> throwError . JobError . Right =<< liftIO (outputFootnote tout $ "Artifact ‘" <> textJobId tjobId <> "." <> tartName <> "’ not found")
+                Nothing -> throwError $ JobError $ "Artifact ‘" <> textJobId tjobId <> "." <> tartName <> "’ not found"
             _ -> throwError JobSkipped
 
 outputJobFinishedEvent :: Output -> Job -> JobStatus a -> IO ()
@@ -379,14 +385,14 @@ readStatusFile job jdir = do
                 { outArtifacts = artifacts
                 }
 
-updateStatusFile :: MonadIO m => JobManager -> FilePath -> TVar (JobStatus JobOutput) -> m ()
+updateStatusFile :: MonadIO m => JobManager -> FilePath -> TVar ( JobStatus JobOutput, [ OutputFootnote ] ) -> m ()
 updateStatusFile JobManager {..} jdir outVar = liftIO $ do
     atomically $ writeTVar jmOpenStatusUpdates . (+ 1) =<< readTVar jmOpenStatusUpdates
     void $ forkIO $ loop Nothing
   where
     loop prev = do
         status <- atomically $ do
-            status <- readTVar outVar
+            ( status, _ ) <- readTVar outVar
             when (Just status == prev) retry
             return status
         T.writeFile (jdir </> "status") $ textJobStatus status <> "\n" <> textJobStatusDetails status