From 66d2298f29f8e054687acc9e9615ddfa3cdb604a Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Thu, 25 Dec 2025 13:46:54 -0500 Subject: Omni/Bild: improve concurrent build logging MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Add per-namespace log files at _/var/bild-logs/.log - Show log path on failure instead of dumping stderr - Use efficient single-line updates instead of full redraws - Use cursor save/restore for reliable positioning - Simplify status symbols (no brackets): * + ~ . x _ - Remove OutputMode distinction (no longer needed) 🤖 Generated with [Claude Code](https://claude.com/claude-code) Co-Authored-By: Claude Opus 4.5 --- Omni/Bild.hs | 116 ++++++++++++++---- Omni/Log/Concurrent.hs | 314 ++++++++++++++++++++++--------------------------- Omni/Log/Terminal.hs | 16 +-- 3 files changed, 231 insertions(+), 215 deletions(-) diff --git a/Omni/Bild.hs b/Omni/Bild.hs index b4da154..73141e4 100644 --- a/Omni/Bild.hs +++ b/Omni/Bild.hs @@ -151,16 +151,26 @@ import Omni.Namespace (Namespace (..)) import qualified Omni.Namespace as Namespace import Omni.Test ((@=?)) import qualified Omni.Test as Test +import Rainbow (chunk, fore, red) +import qualified Rainbow import qualified System.Directory as Dir import qualified System.Environment as Env import qualified System.Exit as Exit -import System.FilePath (dropExtension, replaceExtension, takeDirectory, ()) +import System.FilePath (dropExtension, replaceExtension, takeDirectory, (<.>), ()) import qualified System.IO as IO import System.IO.Unsafe (unsafePerformIO) import qualified System.Process as Process import qualified System.Timeout as Timeout import qualified Text.Regex.Applicative as Regex +-- | Tee conduit: write to both log file and downstream +teeLog :: Maybe IO.Handle -> Conduit.ConduitT ByteString ByteString (Conduit.ResourceT IO) () +teeLog Nothing = Conduit.awaitForever Conduit.yield +teeLog (Just h) = + Conduit.awaitForever <| \bs -> do + liftIO (writeBuildLog (Just h) bs) + Conduit.yield bs + mapConcurrentlyBounded :: Int -> (a -> IO b) -> [a] -> IO [b] mapConcurrentlyBounded n f xs = do sem <- QSemN.newQSemN n @@ -572,11 +582,53 @@ outname = \case Just o -> o Nothing -> mempty -bindir, intdir, nixdir, vardir :: FilePath +bindir, intdir, nixdir, vardir, logdir :: FilePath bindir = cab "bin" intdir = cab "int" nixdir = cab "nix" vardir = cab "var" +logdir = cab "var" "bild-logs" + +-- | Get log file path for a namespace +logPathForNs :: Namespace -> FilePath +logPathForNs ns = logdir Namespace.toPath ns <.> "log" + +-- | Clear log file at the start of a build +clearBuildLog :: Namespace -> IO () +clearBuildLog ns = do + root <- getCoderoot + let path = root logPathForNs ns + Dir.createDirectoryIfMissing True (takeDirectory path) + writeFile path "" + +-- | Open a log file for appending, creating directories as needed +openBuildLog :: Namespace -> IO (Maybe IO.Handle) +openBuildLog ns = do + root <- getCoderoot + let path = root logPathForNs ns + Dir.createDirectoryIfMissing True (takeDirectory path) + h <- IO.openFile path IO.AppendMode + IO.hSetBuffering h IO.LineBuffering + pure (Just h) + +-- | Write to build log (if handle exists) +writeBuildLog :: Maybe IO.Handle -> ByteString -> IO () +writeBuildLog Nothing _ = pure () +writeBuildLog (Just h) bs = ByteString.hPutStr h bs >> IO.hFlush h + +-- | Close build log +closeBuildLog :: Maybe IO.Handle -> IO () +closeBuildLog Nothing = pure () +closeBuildLog (Just h) = IO.hClose h + +-- | Show where to find the build log +showLogPath :: Namespace -> IO () +showLogPath ns = do + root <- getCoderoot + let path = root logPathForNs ns + Rainbow.hPutChunks IO.stderr [fore red <| chunk <| " see " <> Text.pack path] + IO.hPutStrLn IO.stderr "" + IO.hFlush IO.stderr -- | Emulate the *nix hierarchy in the cabdir. createHier :: String -> IO () @@ -586,7 +638,8 @@ createHier root = [ root (outToPath <| Just ""), root intdir, root nixdir, - root vardir + root vardir, + root logdir ] -- >>> removeVersion "array-0.5.4.0-DFLKGIjfsadi" @@ -1167,8 +1220,8 @@ test loud Target {..} = cmd = root outToPath out, args = ["test"], ns = namespace, - onFailure = loud ?: (Log.fail ["test", nschunk namespace] >> Log.br, LogC.updateLineState namespace LogC.Failed), - onSuccess = loud ?: (Log.pass ["test", nschunk namespace] >> Log.br, LogC.updateLineState namespace LogC.Success) + onFailure = loud ?: (pure (), LogC.updateLineState namespace LogC.Failed), + onSuccess = loud ?: (pure (), LogC.updateLineState namespace LogC.Success) } |> run CPython -> @@ -1177,8 +1230,8 @@ test loud Target {..} = cmd = root outToPath out, args = ["test"], ns = namespace, - onFailure = loud ?: (Log.fail ["test", nschunk namespace] >> Log.br, LogC.updateLineState namespace LogC.Failed), - onSuccess = loud ?: (Log.pass ["test", nschunk namespace] >> Log.br, LogC.updateLineState namespace LogC.Success) + onFailure = loud ?: (pure (), LogC.updateLineState namespace LogC.Failed), + onSuccess = loud ?: (pure (), LogC.updateLineState namespace LogC.Success) } |> run _ -> @@ -1384,6 +1437,8 @@ promoteWaiters Coordinator {..} completedNs = do pipelineBuildOne :: Bool -> Bool -> Bool -> Int -> Int -> Target -> IO Exit.ExitCode pipelineBuildOne andTest loud andCache jobs cpus target@Target {..} = do root <- getCoderoot + -- Clear log file at the start of each build + unless loud (clearBuildLog namespace) result <- case compiler of CPython -> case out of Just _ -> @@ -1441,10 +1496,10 @@ cacheStorePath :: Bool -> Namespace -> FilePath -> IO () cacheStorePath loud ns storePath = do mKeyPath <- Env.lookupEnv "NIX_CACHE_KEY" case mKeyPath of - Nothing -> Log.warn ["cache", "NIX_CACHE_KEY not set, skipping"] + Nothing -> loud ?| Log.warn ["cache", "NIX_CACHE_KEY not set, skipping"] Just keyPath -> do let s3Url = "s3://omni-nix-cache?profile=digitalocean&scheme=https&endpoint=nyc3.digitaloceanspaces.com" - LogC.updateLine ns "signing..." + loud ?: (pure (), LogC.updateLine ns "signing...") (signExit, _, signErr) <- Process.readProcessWithExitCode "nix" @@ -1452,7 +1507,7 @@ cacheStorePath loud ns storePath = do "" case signExit of Exit.ExitSuccess -> do - LogC.updateLine ns "pushing to cache..." + loud ?: (pure (), LogC.updateLine ns "pushing to cache...") (pushExit, _, pushErr) <- Process.readProcessWithExitCode "nix" @@ -1460,14 +1515,14 @@ cacheStorePath loud ns storePath = do "" case pushExit of Exit.ExitSuccess -> do - loud ?| Log.good ["cache", "pushed", Text.pack storePath] - Text.IO.putStrLn <| "STORE_PATH=" <> Text.pack storePath + -- Only print STORE_PATH in loud mode to avoid interfering with line manager + loud ?: (Text.IO.putStrLn <| "STORE_PATH=" <> Text.pack storePath, pure ()) Exit.ExitFailure _ -> do - Log.fail ["cache", "push failed", Text.pack storePath] - loud ?| putStrLn pushErr + -- Write error to log file, show path in normal mode + loud ?: (Log.fail ["cache", "push failed", Text.pack storePath] >> putStrLn pushErr, showLogPath ns) Exit.ExitFailure _ -> do - Log.fail ["cache", "sign failed", Text.pack storePath] - loud ?| putStrLn signErr + -- Write error to log file, show path in normal mode + loud ?: (Log.fail ["cache", "sign failed", Text.pack storePath] >> putStrLn signErr, showLogPath ns) pipelineBuild :: Bool -> Bool -> Bool -> Int -> Int -> Int -> [Namespace] -> (Namespace -> IO (Maybe Target)) -> IO [Exit.ExitCode] pipelineBuild andTest loud andCache analysisWorkers buildWorkers cpus namespaces analyzeFn = do @@ -1505,24 +1560,35 @@ run :: Proc -> IO (Exit.ExitCode, ByteString) run Proc {..} = do IO.hSetBuffering stdout IO.NoBuffering loud ?| Log.info ["proc", unwords <| map str <| cmd : args] + + -- Open log file for this build (skip if loud mode) + logHandle <- if loud then pure Nothing else openBuildLog ns + Conduit.proc cmd args |> (\proc_ -> proc_ {Process.create_group = True}) |> Conduit.streamingProcess +> \(stdin_, stdout_, stderr_, hdl) -> do IO.hClose stdin_ -- Close stdin immediately since we don't use it + + -- Insert teeLog to write to file while streaming + let stdoutWithLog = stdout_ .| teeLog logHandle + let stderrWithLog = stderr_ .| teeLog logHandle + (,,) Async.Concurrently (loud ?: (puts stdout_, logs ns stdout_)) - <*> Async.Concurrently (loud ?: (puts stderr_, logs ns stderr_)) + <*> Async.Concurrently (loud ?: (puts stdoutWithLog, logs ns stdoutWithLog)) + <*> Async.Concurrently (loud ?: (puts stderrWithLog, logs ns stderrWithLog)) |> Async.runConcurrently +> \case (Exit.ExitFailure n, output, outerr) -> - Conduit.closeStreamingProcessHandle hdl - >> putStr outerr + closeBuildLog logHandle + >> Conduit.closeStreamingProcessHandle hdl + >> (loud ?: (putStr outerr, showLogPath ns)) >> onFailure >> pure (Exit.ExitFailure n, output) (Exit.ExitSuccess, output, _) -> - Conduit.closeStreamingProcessHandle hdl + closeBuildLog logHandle + >> Conduit.closeStreamingProcessHandle hdl >> onSuccess >> pure (Exit.ExitSuccess, output) @@ -1539,7 +1605,7 @@ proc loud namespace cmd args = ns = namespace, cmd = cmd, args = map Text.unpack args, - onFailure = Log.fail ["bild", nschunk namespace] >> Log.br, + onFailure = pure (), -- Let run() handle failure display onSuccess = pure () } |> run @@ -1639,7 +1705,7 @@ nixBuild loud maxJobs cores target@(Target {..}) = ] |> mconcat |> map Text.unpack, - onFailure = Log.fail ["bild", "instantiate", nschunk namespace] >> Log.br, + onFailure = pure (), -- Let run() handle failure display onSuccess = pure () } realise drv = @@ -1657,7 +1723,7 @@ nixBuild loud maxJobs cores target@(Target {..}) = "--cores", str cores ], - onFailure = Log.fail ["bild", "realise", nschunk namespace] >> Log.br, + onFailure = pure (), -- Let run() handle failure display onSuccess = pure () } symlink = @@ -1672,7 +1738,7 @@ nixBuild loud maxJobs cores target@(Target {..}) = nixdir outname out "bin" outname out, bindir outname out ], - onFailure = Log.fail ["bild", "symlink", nschunk namespace] >> Log.br, + onFailure = pure (), -- Let run() handle failure display onSuccess = pure () } diff --git a/Omni/Log/Concurrent.hs b/Omni/Log/Concurrent.hs index 77131ef..e502e32 100644 --- a/Omni/Log/Concurrent.hs +++ b/Omni/Log/Concurrent.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} --- | Concurrent logging with multi-line output support +-- | Concurrent logging with efficient single-line updates module Omni.Log.Concurrent ( LineManager, BuildState (..), @@ -14,13 +15,13 @@ module Omni.Log.Concurrent where import Alpha -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import qualified Data.Map as Map +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) +import qualified Data.Map.Strict as Map import qualified Data.Text as Text -import Omni.Log.Terminal (OutputMode (..), TerminalInfo (..), detectTerminal, truncateToWidth) +import Omni.Log.Terminal (TerminalInfo (..), detectTerminal, truncateToWidth) import Omni.Namespace (Namespace) import qualified Omni.Namespace as Namespace -import Rainbow (chunk, fore, green, red, white, yellow) +import Rainbow (chunk, fore, green, red, yellow) import qualified Rainbow import qualified System.Console.ANSI as ANSI import qualified System.IO as IO @@ -38,206 +39,169 @@ data LineManager = LineManager currentLineManager :: IORef (Maybe LineManager) currentLineManager = unsafePerformIO (newIORef Nothing) +-- | Current state of each namespace +{-# NOINLINE namespaceStates #-} +namespaceStates :: IORef (Map Namespace (BuildState, Text)) +namespaceStates = unsafePerformIO (newIORef Map.empty) + +-- | Namespace to line number mapping (0-indexed from top of our area) {-# 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) +-- | Tracks if lines have been initialized {-# 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) + let mgr = LineManager {lmNamespaces = nss, lmTermInfo = termInfo} + writeIORef currentLineManager (Just mgr) + writeIORef linesInitialized False + -- Initialize all namespaces to Pending state + writeIORef namespaceStates (Map.fromList [(ns, (Pending, "")) | ns <- nss]) + -- Create line number mapping + writeIORef namespaceLines (Map.fromList (zip nss [0 ..])) + + -- Reserve lines for the display area + let numLines = length nss + when (numLines > 0 && tiSupportsANSI termInfo) <| do + -- Start fresh: clear from cursor to end of screen + IO.hPutStr IO.stderr "\r" + ANSI.hClearFromCursorToScreenEnd IO.stderr + -- Print N blank lines to reserve space + replicateM_ numLines (IO.hPutStrLn IO.stderr "") + -- Move back to the first line and save this position + ANSI.hCursorUp IO.stderr numLines + ANSI.hSaveCursor IO.stderr + IO.hFlush IO.stderr + + result <- action mgr + + -- Move to end and print final newline + when (numLines > 0 && tiSupportsANSI termInfo) <| do + -- Restore to top, then move down past our area + ANSI.hRestoreCursor IO.stderr + ANSI.hCursorDown IO.stderr numLines + IO.hPutStrLn IO.stderr "" + IO.hFlush IO.stderr + + writeIORef currentLineManager Nothing + writeIORef namespaceStates Map.empty + writeIORef namespaceLines Map.empty + writeIORef linesInitialized False + pure result + +-- | Initialize display with all namespaces initializeLines :: LineManager -> IO () -initializeLines LineManager {..} = do +initializeLines mgr = 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 + unless alreadyInit <| do + writeIORef linesInitialized True + -- Draw all lines once at initialization + redrawAll mgr +-- | Update progress text for a namespace 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) - + Nothing -> pure () + Just mgr -> do + -- Update state and redraw just this line + atomicModifyIORef' namespaceStates <| \m -> + case Map.lookup ns m of + Just (bState, _) -> (Map.insert ns (bState, output) m, ()) + Nothing -> (m, ()) + redrawLine mgr ns + +-- | Update build state for a namespace 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) + Just mgr -> do + -- Update state and redraw just this line + atomicModifyIORef' namespaceStates <| \m -> + (Map.insert ns (buildState, "") m, ()) + redrawLine mgr ns + +-- | Redraw a single line efficiently +redrawLine :: LineManager -> Namespace -> IO () +redrawLine LineManager {..} ns = do + states <- readIORef namespaceStates + lineMap <- readIORef namespaceLines + + case Map.lookup ns lineMap of + Nothing -> pure () + Just lineNum -> do + let (bState, progress) = Map.findWithDefault (Pending, "") ns states + withMVar terminalLock <| \_ -> do + -- Restore to top of our area, then move down to the right line + ANSI.hRestoreCursor IO.stderr + when (lineNum > 0) <| ANSI.hCursorDown IO.stderr lineNum + -- Clear and redraw this line + ANSI.hClearLine IO.stderr + drawNamespaceLine lmTermInfo ns bState progress + IO.hFlush IO.stderr + +-- | Redraw all lines (used only at initialization) +redrawAll :: LineManager -> IO () +redrawAll LineManager {..} = do + states <- readIORef namespaceStates + + withMVar terminalLock <| \_ -> do + let numLines = length lmNamespaces + when (numLines > 0) <| do + -- Restore to saved position (top of our area) + ANSI.hRestoreCursor IO.stderr + -- Clear from here to end of screen + ANSI.hClearFromCursorToScreenEnd IO.stderr + + -- Redraw each line + forM_ lmNamespaces <| \ns -> do + let (bState, progress) = Map.findWithDefault (Pending, "") ns states + drawNamespaceLine lmTermInfo ns bState progress + IO.hPutStrLn IO.stderr "" + + IO.hFlush IO.stderr + +-- | Draw a single namespace line (without newline) +drawNamespaceLine :: TerminalInfo -> Namespace -> BuildState -> Text -> IO () +drawNamespaceLine termInfo ns bState progress = do + let nsText = Text.pack (Namespace.toPath ns) + let (symbol, mColor) = stateSymbol bState + let msg = case bState of + Success -> symbol <> " " <> nsText + Failed -> symbol <> " " <> nsText + Skipped -> symbol <> " " <> nsText + _ + | Text.null progress -> symbol <> " " <> nsText + | otherwise -> symbol <> " " <> nsText <> ": " <> progress + let truncated = truncateToWidth (tiWidth termInfo - 1) msg + + case mColor of + Just color -> Rainbow.hPutChunks IO.stderr [fore color <| chunk truncated] + Nothing -> IO.hPutStr IO.stderr (Text.unpack truncated) + +stateSymbol :: BuildState -> (Text, Maybe Rainbow.Radiant) +stateSymbol = \case + Success -> ("*", Just green) + Failed -> ("x", Just red) + Skipped -> ("_", Just yellow) + Analyzing -> ("+", Nothing) + Pending -> (".", Nothing) + Building -> ("~", Nothing) diff --git a/Omni/Log/Terminal.hs b/Omni/Log/Terminal.hs index 1a4c717..fd0a617 100644 --- a/Omni/Log/Terminal.hs +++ b/Omni/Log/Terminal.hs @@ -1,10 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} --- | Terminal detection and output mode selection +-- | Terminal detection and utilities module Omni.Log.Terminal ( TerminalInfo (..), - OutputMode (..), detectTerminal, truncateToWidth, ) @@ -16,15 +15,9 @@ 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) @@ -53,17 +46,10 @@ detectTerminal = do 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 } -- cgit v1.2.3