diff options
Diffstat (limited to 'Omni/Log')
| -rw-r--r-- | Omni/Log/Concurrent.hs | 243 | ||||
| -rw-r--r-- | Omni/Log/Terminal.hs | 75 |
2 files changed, 318 insertions, 0 deletions
diff --git a/Omni/Log/Concurrent.hs b/Omni/Log/Concurrent.hs new file mode 100644 index 0000000..77131ef --- /dev/null +++ b/Omni/Log/Concurrent.hs @@ -0,0 +1,243 @@ +{-# 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) diff --git a/Omni/Log/Terminal.hs b/Omni/Log/Terminal.hs new file mode 100644 index 0000000..1a4c717 --- /dev/null +++ b/Omni/Log/Terminal.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Terminal detection and output mode selection +module Omni.Log.Terminal + ( TerminalInfo (..), + OutputMode (..), + detectTerminal, + truncateToWidth, + ) +where + +import Alpha +import qualified Control.Exception as Exception +import qualified Data.Text as Text +import qualified System.Console.ANSI as ANSI +import qualified System.Environment as Env + +data OutputMode + = MultiLine -- Wide terminals (≥80 cols) - reserved lines per namespace + | SingleLine -- Narrow terminals (<80 cols) - rotating single line + deriving (Eq, Show) + +data TerminalInfo = TerminalInfo + { tiWidth :: Int, + tiHeight :: Int, + tiMode :: OutputMode, + tiSupportsANSI :: Bool + } + deriving (Eq, Show) + +detectTerminal :: IO TerminalInfo +detectTerminal = do + term <- Env.lookupEnv "TERM" + area <- Env.lookupEnv "AREA" + noColor <- Env.lookupEnv "NO_COLOR" + + -- Check if we support ANSI + let supportsANSI = case (term, area, noColor) of + (_, _, Just _) -> False -- NO_COLOR set + (Just "dumb", _, _) -> False + (_, Just "Live", _) -> False -- production logs + (Nothing, _, _) -> False + _ -> True + + -- Get terminal size, catching exceptions from stdin issues + -- When NO_COLOR is set or ANSI is not supported, skip terminal size detection + -- to avoid outputting escape codes + mSize <- + if supportsANSI + then Exception.catch ANSI.getTerminalSize <| \(_ :: Exception.IOException) -> pure Nothing + else pure Nothing -- Skip if no ANSI support + let (width, height) = case mSize of + Just (h, w) -> (w, h) + Nothing -> (80, 24) -- sensible default + + -- Determine mode based on ANSI support + let mode + | not supportsANSI = SingleLine -- Fallback to single line for dumb terminals + | otherwise = MultiLine + + pure + TerminalInfo + { tiWidth = width, + tiHeight = height, + tiMode = mode, + tiSupportsANSI = supportsANSI + } + +-- | Truncate text to fit width with ellipsis +truncateToWidth :: Int -> Text -> Text +truncateToWidth maxWidth text + | Text.length text <= maxWidth = text + | maxWidth <= 3 = Text.take maxWidth text + | otherwise = Text.take (maxWidth - 3) text <> "..." |