Redesign LineManager to show one line per namespace

- Allocate one line per namespace (not per concurrent job) - Add
Pending state shown as [...] when build hasn't started - Initialize all
namespace lines at start showing [...]  - Update to [~] when building,
[✓]/[x] when complete - Each namespace keeps its line throughout
the build - At end, all namespaces show their final status - --jobs
controls concurrency, not line count

2 files changed, 89 insertions, 142 deletions

diff --git a/Omni/Bild.hs b/Omni/Bild.hs
index 704a47d..90f6cd6 100755
--- a/Omni/Bild.hs
+++ b/Omni/Bild.hs
@@ -955,13 +955,14 @@ build :: Bool -> Bool -> Int -> Int -> Analysis -> IO [Exit.ExitCode]
 build andTest loud jobs cpus analysis = do
   root <- Env.getEnv "CODEROOT"
   let targets = Map.elems analysis
-  LogC.withLineManager jobs <| \lineMgr -> do
-    results <- mapConcurrentlyBounded jobs (buildTarget lineMgr root) targets
+  let namespaces = map (\Target {..} -> namespace) targets
+  LogC.withLineManager namespaces <| \lineMgr -> do
+    LogC.initializeLines lineMgr
+    results <- mapConcurrentlyBounded jobs (buildTarget root) targets
     pure (map fst results)
   where
-    buildTarget :: LogC.LineManager -> FilePath -> Target -> IO (Exit.ExitCode, ByteString)
-    buildTarget lineMgr root target@Target {..} = do
-      _ <- LogC.reserveLine lineMgr namespace
+    buildTarget :: FilePath -> Target -> IO (Exit.ExitCode, ByteString)
+    buildTarget root target@Target {..} = do
       result <- case compiler of
         CPython -> case out of
           Just _ ->
@@ -1011,7 +1012,7 @@ build andTest loud jobs cpus analysis = do
           nixBuild loud jobs cpus target
         Sbcl ->
           proc loud namespace (toNixFlag compiler) compilerFlags
-      LogC.releaseCurrentLine namespace (isSuccess (fst result) ?: (LogC.Success, LogC.Failed))
+      LogC.updateLineState namespace (isSuccess (fst result) ?: (LogC.Success, LogC.Failed))
       pure result
 
 data Proc = Proc
@@ -1096,7 +1097,7 @@ logs ns src =
               .> decodeUtf8
               .> Text.take (columns - 1)
               .> (<> "…")
-              .> LogC.updateCurrentLine ns
+              .> LogC.updateLine ns
               .> liftIO
           )
         .| Conduit.foldC
diff --git a/Omni/Log/Concurrent.hs b/Omni/Log/Concurrent.hs
index 204e497..d7723e5 100644
--- a/Omni/Log/Concurrent.hs
+++ b/Omni/Log/Concurrent.hs
@@ -7,16 +7,14 @@ module Omni.Log.Concurrent
   ( LineManager,
     BuildState (..),
     withLineManager,
-    reserveLine,
+    initializeLines,
     updateLine,
-    releaseLine,
-    updateCurrentLine,
-    releaseCurrentLine,
+    updateLineState,
   )
 where
 
 import Alpha
-import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import qualified Data.Map as Map
 import qualified Data.Text as Text
 import Omni.Namespace (Namespace)
@@ -28,17 +26,11 @@ import qualified System.Environment as Env
 import qualified System.IO as IO
 import System.IO.Unsafe (unsafePerformIO)
 
-data BuildState = Building | Success | Failed
+data BuildState = Pending | Building | Success | Failed
   deriving (Eq, Show)
 
-newtype BuildStatus = BuildStatus
-  { bsLastOutput :: Text
-  }
-
 data LineManager = LineManager
-  { lmLines :: IORef (Map Int (Maybe BuildStatus)),
-    lmMaxLines :: Int,
-    lmCurrentLine :: IORef Int,
+  { lmNamespaces :: [Namespace],
     lmSupportsANSI :: Bool
   }
 
@@ -50,46 +42,33 @@ currentLineManager = unsafePerformIO (newIORef Nothing)
 namespaceLines :: IORef (Map Namespace Int)
 namespaceLines = unsafePerformIO (newIORef Map.empty)
 
-withLineManager :: Int -> (LineManager -> IO a) -> IO a
-withLineManager maxLines action = do
+withLineManager :: [Namespace] -> (LineManager -> IO a) -> IO a
+withLineManager nss action = do
   supportsANSI <- checkANSISupport
 
   if not supportsANSI
     then do
-      linesRef <- newIORef Map.empty
-      currentRef <- newIORef 0
-      let mgr =
-            LineManager
-              { lmLines = linesRef,
-                lmMaxLines = 1,
-                lmCurrentLine = currentRef,
-                lmSupportsANSI = False
-              }
+      let mgr = LineManager {lmNamespaces = nss, lmSupportsANSI = False}
       writeIORef currentLineManager (Just mgr)
       result <- action mgr
       writeIORef currentLineManager Nothing
       writeIORef namespaceLines Map.empty
       pure result
     else do
+      let numLines = length nss
       IO.hPutStrLn IO.stderr ""
-      replicateM_ maxLines (IO.hPutStrLn IO.stderr "")
-      ANSI.hCursorUp IO.stderr maxLines
-
-      linesRef <- newIORef (Map.fromList [(i, Nothing) | i <- [0 .. maxLines - 1]])
-      currentRef <- newIORef 0
-
-      let mgr =
-            LineManager
-              { lmLines = linesRef,
-                lmMaxLines = maxLines,
-                lmCurrentLine = currentRef,
-                lmSupportsANSI = True
-              }
+      replicateM_ numLines (IO.hPutStrLn IO.stderr "")
+      ANSI.hCursorUp IO.stderr numLines
+
+      let mgr = LineManager {lmNamespaces = nss, lmSupportsANSI = True}
       writeIORef currentLineManager (Just mgr)
 
+      -- Initialize the namespace -> line mapping
+      writeIORef namespaceLines (Map.fromList <| zip nss [0 ..])
+
       result <- action mgr
 
-      ANSI.hCursorDown IO.stderr maxLines
+      ANSI.hCursorDown IO.stderr numLines
       writeIORef currentLineManager Nothing
       writeIORef namespaceLines Map.empty
       pure result
@@ -104,111 +83,78 @@ checkANSISupport = do
     (Nothing, _) -> False
     _ -> True
 
-reserveLine :: LineManager -> Namespace -> IO (Maybe Int)
-reserveLine LineManager {..} ns =
-  if not lmSupportsANSI
-    then pure Nothing
-    else do
-      mLine <-
-        atomicModifyIORef' lmLines <| \linesMap ->
-          case findFirstFree linesMap of
-            Nothing -> (linesMap, Nothing)
-            Just lineNum ->
-              let status = BuildStatus ""
-                  linesMap' = Map.insert lineNum (Just status) linesMap
-               in (linesMap', Just lineNum)
-      case mLine of
-        Just lineNum -> modifyIORef' namespaceLines (Map.insert ns lineNum)
-        Nothing -> pure ()
-      pure mLine
-  where
-    findFirstFree :: Map Int (Maybe BuildStatus) -> Maybe Int
-    findFirstFree m =
-      Map.toList m
-        |> filter (\(_, mbs) -> isNothing mbs)
-        |> map fst
-        |> listToMaybe
-
-updateLine :: LineManager -> Maybe Int -> Namespace -> Text -> IO ()
-updateLine LineManager {..} mLineNum ns output =
-  if not lmSupportsANSI
-    then do
-      IO.hPutStr IO.stderr (Text.unpack <| output <> "\n")
+-- | Initialize all lines with pending status
+initializeLines :: LineManager -> IO ()
+initializeLines LineManager {..} =
+  when lmSupportsANSI <| do
+    nsMap <- readIORef namespaceLines
+    forM_ (Map.toList nsMap) <| \(ns, lineNum) -> do
+      ANSI.hSaveCursor IO.stderr
+      ANSI.hSetCursorColumn IO.stderr 0
+      ANSI.hCursorUp IO.stderr (length lmNamespaces - lineNum)
+      ANSI.hClearLine IO.stderr
+      let nsText = Text.pack (Namespace.toPath ns)
+      IO.hPutStr IO.stderr (Text.unpack <| "[…] " <> nsText)
       IO.hFlush IO.stderr
-    else case mLineNum of
-      Nothing -> pure ()
-      Just lineNum -> do
-        currentLine <- readIORef lmCurrentLine
-
-        ANSI.hSaveCursor IO.stderr
-        ANSI.hSetCursorColumn IO.stderr 0
-
-        let linesToMove = currentLine - lineNum
-        when (linesToMove > 0) <| ANSI.hCursorUp IO.stderr linesToMove
-        when (linesToMove < 0) <| ANSI.hCursorDown IO.stderr (abs linesToMove)
+      ANSI.hRestoreCursor IO.stderr
 
-        ANSI.hClearLine IO.stderr
-        let nsText = Text.pack (Namespace.toPath ns)
-        let formattedOutput = if Text.null output then "[~] " <> nsText else "[~] " <> nsText <> ": " <> output
-        IO.hPutStr IO.stderr (Text.unpack formattedOutput)
-        IO.hFlush IO.stderr
-
-        ANSI.hRestoreCursor IO.stderr
-
-        modifyIORef' lmLines <| \linesMap ->
-          Map.adjust (fmap (\bs -> bs {bsLastOutput = output})) lineNum linesMap
-
-releaseLine :: LineManager -> Maybe Int -> Namespace -> BuildState -> IO ()
-releaseLine LineManager {..} mLineNum ns buildState =
-  case mLineNum of
-    Nothing -> pure ()
-    Just lineNum -> do
-      modifyIORef' lmLines <| \linesMap ->
-        Map.insert lineNum Nothing linesMap
-
-      when lmSupportsANSI <| do
-        current <- readIORef lmCurrentLine
-        ANSI.hSaveCursor IO.stderr
-        ANSI.hSetCursorColumn IO.stderr 0
-        ANSI.hCursorUp IO.stderr (current - lineNum)
-        ANSI.hClearLine IO.stderr
-
-        let nsText = Text.pack (Namespace.toPath ns)
-        case buildState of
-          Success ->
-            Rainbow.hPutChunks IO.stderr [fore green <| chunk <| "[✓] " <> nsText]
-          Failed ->
-            Rainbow.hPutChunks IO.stderr [fore red <| chunk <| "[x] " <> nsText]
-          Building ->
-            IO.hPutStr IO.stderr (Text.unpack <| "[~] " <> nsText)
-        IO.hFlush IO.stderr
-
-        ANSI.hRestoreCursor IO.stderr
-
-updateCurrentLine :: Namespace -> Text -> IO ()
-updateCurrentLine ns output = do
+updateLine :: Namespace -> Text -> IO ()
+updateLine ns output = do
   mMgr <- readIORef currentLineManager
   case mMgr of
     Nothing -> do
       IO.hPutStr IO.stderr (Text.unpack <| output <> "\r")
       IO.hFlush IO.stderr
-    Just mgr -> do
-      nsMap <- readIORef namespaceLines
-      case Map.lookup ns nsMap of
-        Nothing -> do
-          IO.hPutStr IO.stderr (Text.unpack <| output <> "\r")
+    Just LineManager {..} ->
+      if not lmSupportsANSI
+        then do
+          IO.hPutStr IO.stderr (Text.unpack <| output <> "\n")
           IO.hFlush IO.stderr
-        Just lineNum -> updateLine mgr (Just lineNum) ns output
-
-releaseCurrentLine :: Namespace -> BuildState -> IO ()
-releaseCurrentLine ns buildState = do
+        else do
+          nsMap <- readIORef namespaceLines
+          case Map.lookup ns nsMap of
+            Nothing -> pure ()
+            Just lineNum -> do
+              ANSI.hSaveCursor IO.stderr
+              ANSI.hSetCursorColumn IO.stderr 0
+              let currentLine = length lmNamespaces
+              let linesToMove = currentLine - lineNum
+              when (linesToMove > 0) <| ANSI.hCursorUp IO.stderr linesToMove
+              when (linesToMove < 0) <| ANSI.hCursorDown IO.stderr (abs linesToMove)
+              ANSI.hClearLine IO.stderr
+              let nsText = Text.pack (Namespace.toPath ns)
+              let formattedOutput = if Text.null output then "[~] " <> nsText else "[~] " <> nsText <> ": " <> output
+              IO.hPutStr IO.stderr (Text.unpack formattedOutput)
+              IO.hFlush IO.stderr
+              ANSI.hRestoreCursor IO.stderr
+
+updateLineState :: Namespace -> BuildState -> IO ()
+updateLineState ns buildState = do
   mMgr <- readIORef currentLineManager
   case mMgr of
     Nothing -> pure ()
-    Just mgr -> do
-      nsMap <- readIORef namespaceLines
-      case Map.lookup ns nsMap of
-        Nothing -> pure ()
-        Just lineNum -> do
-          releaseLine mgr (Just lineNum) ns buildState
-          modifyIORef' namespaceLines (Map.delete ns)
+    Just LineManager {..} ->
+      when lmSupportsANSI <| do
+        nsMap <- readIORef namespaceLines
+        case Map.lookup ns nsMap of
+          Nothing -> pure ()
+          Just lineNum -> do
+            ANSI.hSaveCursor IO.stderr
+            ANSI.hSetCursorColumn IO.stderr 0
+            let currentLine = length lmNamespaces
+            let linesToMove = currentLine - lineNum
+            when (linesToMove > 0) <| ANSI.hCursorUp IO.stderr linesToMove
+            when (linesToMove < 0) <| ANSI.hCursorDown IO.stderr (abs linesToMove)
+            ANSI.hClearLine IO.stderr
+            let nsText = Text.pack (Namespace.toPath ns)
+            case buildState of
+              Success ->
+                Rainbow.hPutChunks IO.stderr [fore green <| chunk <| "[✓] " <> nsText]
+              Failed ->
+                Rainbow.hPutChunks IO.stderr [fore red <| chunk <| "[x] " <> nsText]
+              Pending ->
+                IO.hPutStr IO.stderr (Text.unpack <| "[…] " <> nsText)
+              Building ->
+                IO.hPutStr IO.stderr (Text.unpack <| "[~] " <> nsText)
+            IO.hFlush IO.stderr
+            ANSI.hRestoreCursor IO.stderr