{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} -- | Concurrent logging with multi-line output support module Omni.Log.Concurrent ( LineManager, BuildState (..), withLineManager, initializeLines, updateLine, updateLineState, ) where import Alpha import Data.IORef (IORef, newIORef, readIORef, writeIORef) import qualified Data.Map as Map import qualified Data.Text as Text import Omni.Log.Terminal (OutputMode (..), TerminalInfo (..), detectTerminal, truncateToWidth) import Omni.Namespace (Namespace) import qualified Omni.Namespace as Namespace import Rainbow (chunk, fore, green, red, white, yellow) import qualified Rainbow import qualified System.Console.ANSI as ANSI import qualified System.IO as IO import System.IO.Unsafe (unsafePerformIO) data BuildState = Analyzing | Pending | Building | Success | Failed | Skipped deriving (Eq, Show) data LineManager = LineManager { lmNamespaces :: [Namespace], lmTermInfo :: TerminalInfo } {-# NOINLINE currentLineManager #-} currentLineManager :: IORef (Maybe LineManager) currentLineManager = unsafePerformIO (newIORef Nothing) {-# NOINLINE namespaceLines #-} namespaceLines :: IORef (Map Namespace Int) namespaceLines = unsafePerformIO (newIORef Map.empty) -- | Tracks if the last output was transient (no newline printed) -- When True, cleanup should not add a newline since next manager will overwrite {-# NOINLINE lastOutputTransient #-} lastOutputTransient :: IORef Bool lastOutputTransient = unsafePerformIO (newIORef False) -- | Tracks if lines have been initialized (prevents duplicate initialization) {-# NOINLINE linesInitialized #-} linesInitialized :: IORef Bool linesInitialized = unsafePerformIO (newIORef False) -- | Global lock for all terminal operations -- ANSI terminal library (ncurses) is not thread-safe, so we must serialize all calls -- to prevent segfaults during concurrent builds {-# NOINLINE terminalLock #-} terminalLock :: MVar () terminalLock = unsafePerformIO (newMVar ()) withLineManager :: [Namespace] -> (LineManager -> IO a) -> IO a withLineManager nss action = do -- Check if a manager is already active (reentrant call) existingMgr <- readIORef currentLineManager maybe createNewManager action existingMgr where createNewManager = do termInfo <- detectTerminal case tiMode termInfo of SingleLine -> do -- Single-line mode: no reservations, updates in place let mgr = LineManager {lmNamespaces = nss, lmTermInfo = termInfo} writeIORef currentLineManager (Just mgr) writeIORef lastOutputTransient False writeIORef linesInitialized False result <- action mgr -- Only print final newline if last output wasn't transient -- (transient outputs expect to be overwritten by next manager) wasTransient <- readIORef lastOutputTransient unless wasTransient (IO.hPutStrLn IO.stderr "") writeIORef currentLineManager Nothing writeIORef namespaceLines Map.empty writeIORef linesInitialized False pure result MultiLine -> do -- Multi-line mode: reserve lines for each namespace let numLines = min (length nss) (tiHeight termInfo - 2) replicateM_ numLines (IO.hPutStrLn IO.stderr "") withMVar terminalLock <| \_ -> ANSI.hCursorUp IO.stderr numLines let mgr = LineManager {lmNamespaces = nss, lmTermInfo = termInfo} writeIORef currentLineManager (Just mgr) writeIORef linesInitialized False -- Initialize the namespace -> line mapping writeIORef namespaceLines (Map.fromList <| zip nss [0 ..]) result <- action mgr IO.hPutStrLn IO.stderr "" writeIORef currentLineManager Nothing writeIORef namespaceLines Map.empty writeIORef linesInitialized False pure result -- | Initialize all lines with pending status -- Only initializes once per manager session (prevents duplicate output on reentrant calls) initializeLines :: LineManager -> IO () initializeLines LineManager {..} = do alreadyInit <- readIORef linesInitialized unless alreadyInit <| case (tiMode lmTermInfo, tiSupportsANSI lmTermInfo) of (_, False) -> pure () -- No ANSI support, skip initialization (SingleLine, _) -> writeIORef linesInitialized True -- Mark as done even if no-op (MultiLine, _) -> do writeIORef linesInitialized True nsMap <- readIORef namespaceLines forM_ (Map.toList nsMap) <| \(ns, _) -> withMVar terminalLock <| \_ -> do ANSI.hSetCursorColumn IO.stderr 0 ANSI.hClearLine IO.stderr let nsText = Text.pack (Namespace.toPath ns) let msg = "[.] " <> nsText -- Pending state before analysis starts let truncated = truncateToWidth (tiWidth lmTermInfo - 1) msg IO.hPutStrLn IO.stderr (Text.unpack truncated) IO.hFlush IO.stderr 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 LineManager {..} -> case tiMode lmTermInfo of SingleLine -> -- Single line: update in place -- Lock all terminal output to prevent interleaved writes withMVar terminalLock <| \_ -> do let nsText = Text.pack (Namespace.toPath ns) let msg = if Text.null output then "[~] " <> nsText else "[~] " <> nsText <> ": " <> output let truncated = truncateToWidth (tiWidth lmTermInfo - 1) msg -- Clear line and write IO.hPutStr IO.stderr "\r" IO.hPutStr IO.stderr (Text.unpack truncated) -- Pad to clear previous longer text let padding = replicate (tiWidth lmTermInfo - Text.length truncated - 1) ' ' IO.hPutStr IO.stderr padding IO.hPutStr IO.stderr "\r" IO.hPutStr IO.stderr (Text.unpack truncated) IO.hFlush IO.stderr MultiLine -> -- Multi-line: use reserved lines with truncation -- Lock covers IORef read + all terminal operations to prevent races withMVar terminalLock <| \_ -> do nsMap <- readIORef namespaceLines case Map.lookup ns nsMap of Nothing -> pure () Just lineNum -> do let numLines = length lmNamespaces -- Move to the target line from bottom ANSI.hCursorUp IO.stderr (numLines - lineNum) ANSI.hSetCursorColumn IO.stderr 0 ANSI.hClearLine IO.stderr let nsText = Text.pack (Namespace.toPath ns) let msg = if Text.null output then "[~] " <> nsText else "[~] " <> nsText <> ": " <> output let truncated = truncateToWidth (tiWidth lmTermInfo - 1) msg IO.hPutStr IO.stderr (Text.unpack truncated) IO.hFlush IO.stderr -- Move back to bottom ANSI.hCursorDown IO.stderr (numLines - lineNum) updateLineState :: Namespace -> BuildState -> IO () updateLineState ns buildState = do mMgr <- readIORef currentLineManager case mMgr of Nothing -> pure () Just LineManager {..} -> case tiMode lmTermInfo of SingleLine -> -- Single line: show completion, keep visible for success/failure -- Lock all terminal output to prevent interleaved writes withMVar terminalLock <| \_ -> do let nsText = Text.pack (Namespace.toPath ns) let (symbol, color) = case buildState of Success -> ("✓", green) Failed -> ("x", red) Skipped -> ("_", yellow) Analyzing -> ("+", white) Pending -> (".", white) Building -> ("~", white) let msg = "[" <> symbol <> "] " <> nsText let truncated = truncateToWidth (tiWidth lmTermInfo - 1) msg IO.hPutStr IO.stderr "\r" Rainbow.hPutChunks IO.stderr [fore color <| chunk truncated] case buildState of Success -> do IO.hPutStrLn IO.stderr "" -- Keep successes visible writeIORef lastOutputTransient False Failed -> do IO.hPutStrLn IO.stderr "" -- Keep failures visible writeIORef lastOutputTransient False Skipped -> do IO.hPutStrLn IO.stderr "" -- Keep skipped visible writeIORef lastOutputTransient False _ -> writeIORef lastOutputTransient True -- Transient states overwrite IO.hFlush IO.stderr MultiLine -> -- Multi-line: use reserved lines with truncation -- Lock covers IORef read + all terminal operations to prevent races withMVar terminalLock <| \_ -> do nsMap <- readIORef namespaceLines case Map.lookup ns nsMap of Nothing -> pure () Just lineNum -> do let numLines = length lmNamespaces ANSI.hCursorUp IO.stderr (numLines - lineNum) ANSI.hSetCursorColumn IO.stderr 0 ANSI.hClearLine IO.stderr let nsText = Text.pack (Namespace.toPath ns) let (symbol, colorFn) = case buildState of Success -> ("✓", fore green) Failed -> ("x", fore red) Skipped -> ("_", fore yellow) Analyzing -> ("+", identity) Pending -> (".", identity) Building -> ("~", identity) let msg = "[" <> symbol <> "] " <> nsText let truncated = truncateToWidth (tiWidth lmTermInfo - 1) msg Rainbow.hPutChunks IO.stderr [colorFn <| chunk truncated] IO.hFlush IO.stderr ANSI.hCursorDown IO.stderr (numLines - lineNum)