summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Omni/Log/Concurrent.hs183
-rw-r--r--Omni/Log/Terminal.hs78
2 files changed, 202 insertions, 59 deletions
diff --git a/Omni/Log/Concurrent.hs b/Omni/Log/Concurrent.hs
index 1a82507..d56d1cc 100644
--- a/Omni/Log/Concurrent.hs
+++ b/Omni/Log/Concurrent.hs
@@ -17,12 +17,12 @@ 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)
+import Rainbow (chunk, fore, green, red, white)
import qualified Rainbow
import qualified System.Console.ANSI as ANSI
-import qualified System.Environment as Env
import qualified System.IO as IO
import System.IO.Unsafe (unsafePerformIO)
@@ -31,7 +31,7 @@ data BuildState = Analyzing | Pending | Building | Success | Failed
data LineManager = LineManager
{ lmNamespaces :: [Namespace],
- lmSupportsANSI :: Bool
+ lmTermInfo :: TerminalInfo
}
{-# NOINLINE currentLineManager #-}
@@ -44,23 +44,34 @@ namespaceLines = unsafePerformIO (newIORef Map.empty)
withLineManager :: [Namespace] -> (LineManager -> IO a) -> IO a
withLineManager nss action = do
- supportsANSI <- checkANSISupport
+ termInfo <- detectTerminal
- if not supportsANSI
- then do
- let mgr = LineManager {lmNamespaces = nss, lmSupportsANSI = False}
+ case tiMode termInfo of
+ SimpleFallback -> do
+ -- Simple mode: no line reservations
+ let mgr = LineManager {lmNamespaces = nss, lmTermInfo = termInfo}
writeIORef currentLineManager (Just mgr)
result <- action mgr
writeIORef currentLineManager Nothing
writeIORef namespaceLines Map.empty
pure result
- else do
- let numLines = length nss
+ SingleLine -> do
+ -- Single-line mode: no reservations, updates in place
+ let mgr = LineManager {lmNamespaces = nss, lmTermInfo = termInfo}
+ writeIORef currentLineManager (Just mgr)
+ result <- action mgr
+ IO.hPutStrLn IO.stderr "" -- Final newline
+ writeIORef currentLineManager Nothing
+ writeIORef namespaceLines Map.empty
+ pure result
+ RichMultiLine -> do
+ -- Multi-line mode: reserve lines (existing behavior)
+ let numLines = min (length nss) (tiHeight termInfo - 2)
IO.hPutStrLn IO.stderr ""
replicateM_ numLines (IO.hPutStrLn IO.stderr "")
ANSI.hCursorUp IO.stderr numLines
- let mgr = LineManager {lmNamespaces = nss, lmSupportsANSI = True}
+ let mgr = LineManager {lmNamespaces = nss, lmTermInfo = termInfo}
writeIORef currentLineManager (Just mgr)
-- Initialize the namespace -> line mapping
@@ -73,27 +84,22 @@ withLineManager nss action = do
writeIORef namespaceLines Map.empty
pure result
-checkANSISupport :: IO Bool
-checkANSISupport = do
- term <- Env.lookupEnv "TERM"
- area <- Env.lookupEnv "AREA"
- pure <| case (term, area) of
- (Just "dumb", _) -> False
- (_, Just "Live") -> False
- (Nothing, _) -> False
- _ -> True
-
-- | Initialize all lines with pending status
initializeLines :: LineManager -> IO ()
initializeLines LineManager {..} =
- when lmSupportsANSI <| do
- nsMap <- readIORef namespaceLines
- forM_ (Map.toList nsMap) <| \(ns, _) -> do
- ANSI.hSetCursorColumn IO.stderr 0
- ANSI.hClearLine IO.stderr
- let nsText = Text.pack (Namespace.toPath ns)
- IO.hPutStrLn IO.stderr (Text.unpack <| "[+] " <> nsText)
- IO.hFlush IO.stderr
+ case tiMode lmTermInfo of
+ SimpleFallback -> pure () -- No initialization needed
+ SingleLine -> pure () -- No initialization needed
+ RichMultiLine -> do
+ nsMap <- readIORef namespaceLines
+ forM_ (Map.toList nsMap) <| \(ns, _) -> do
+ ANSI.hSetCursorColumn IO.stderr 0
+ ANSI.hClearLine IO.stderr
+ let nsText = Text.pack (Namespace.toPath ns)
+ let msg = "[+] " <> nsText
+ 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
@@ -103,11 +109,35 @@ updateLine ns output = do
IO.hPutStr IO.stderr (Text.unpack <| output <> "\r")
IO.hFlush IO.stderr
Just LineManager {..} ->
- if not lmSupportsANSI
- then do
- IO.hPutStr IO.stderr (Text.unpack <| output <> "\n")
+ case tiMode lmTermInfo of
+ SimpleFallback -> do
+ -- Simple: just print with newline
+ let nsText = Text.pack (Namespace.toPath ns)
+ let msg =
+ if Text.null output
+ then "[~] " <> nsText
+ else "[~] " <> nsText <> ": " <> output
+ IO.hPutStrLn IO.stderr (Text.unpack msg)
+ IO.hFlush IO.stderr
+ SingleLine -> do
+ -- Single line: update in place
+ 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
- else do
+ RichMultiLine -> do
+ -- Multi-line: use reserved lines with truncation
nsMap <- readIORef namespaceLines
case Map.lookup ns nsMap of
Nothing -> pure ()
@@ -118,8 +148,12 @@ updateLine ns output = do
ANSI.hSetCursorColumn IO.stderr 0
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)
+ 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)
@@ -130,28 +164,59 @@ updateLineState ns buildState = do
case mMgr of
Nothing -> pure ()
Just LineManager {..} ->
- when lmSupportsANSI <| 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)
- case buildState of
- Success ->
- Rainbow.hPutChunks IO.stderr [fore green <| chunk <| "[✓] " <> nsText]
- Failed ->
- Rainbow.hPutChunks IO.stderr [fore red <| chunk <| "[x] " <> nsText]
- Analyzing ->
- IO.hPutStr IO.stderr (Text.unpack <| "[+] " <> nsText)
- Pending ->
- IO.hPutStr IO.stderr (Text.unpack <| "[…] " <> nsText)
- Building ->
- IO.hPutStr IO.stderr (Text.unpack <| "[~] " <> nsText)
- IO.hFlush IO.stderr
- -- Move back to bottom
- ANSI.hCursorDown IO.stderr (numLines - lineNum)
+ case tiMode lmTermInfo of
+ SimpleFallback -> do
+ -- Simple: print completion status
+ let nsText = Text.pack (Namespace.toPath ns)
+ let (symbol, color) = case buildState of
+ Success -> ("✓", green)
+ Failed -> ("x", red)
+ _ -> ("~", white)
+ let msg = "[" <> symbol <> "] " <> nsText
+ case buildState of
+ Success -> do
+ Rainbow.hPutChunks IO.stderr [fore color <| chunk msg]
+ IO.hPutStrLn IO.stderr ""
+ Failed -> do
+ Rainbow.hPutChunks IO.stderr [fore color <| chunk msg]
+ IO.hPutStrLn IO.stderr ""
+ _ -> pure ()
+ SingleLine -> do
+ -- Single line: show completion, keep visible for success/failure
+ let nsText = Text.pack (Namespace.toPath ns)
+ let (symbol, color) = case buildState of
+ Success -> ("✓", green)
+ Failed -> ("x", red)
+ _ -> ("~", 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 -> IO.hPutStrLn IO.stderr "" -- Keep successes visible
+ Failed -> IO.hPutStrLn IO.stderr "" -- Keep failures visible
+ _ -> pure () -- Transient states overwrite
+ IO.hFlush IO.stderr
+ RichMultiLine -> do
+ -- Multi-line: use reserved lines with truncation
+ 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)
+ 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..1230eb3
--- /dev/null
+++ b/Omni/Log/Terminal.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Terminal detection and output mode selection
+module Omni.Log.Terminal
+ ( TerminalInfo (..),
+ OutputMode (..),
+ detectTerminal,
+ truncateToWidth,
+ )
+where
+
+import Alpha
+import qualified Data.Text as Text
+import qualified System.Console.ANSI as ANSI
+import qualified System.Environment as Env
+
+data OutputMode
+ = RichMultiLine -- Wide terminals (≥80 cols)
+ | SingleLine -- Narrow terminals (40-79 cols)
+ | SimpleFallback -- Very narrow (<40) or dumb terminals
+ 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"
+ modeOverride <- Env.lookupEnv "BILD_OUTPUT_MODE"
+
+ -- Check if we support ANSI
+ let supportsANSI = case (term, area) of
+ (Just "dumb", _) -> False
+ (_, Just "Live") -> False -- production logs
+ (Nothing, _) -> False
+ _ -> True
+
+ -- Get terminal size
+ mSize <- ANSI.getTerminalSize
+ let (width, height) = case mSize of
+ Just (h, w) -> (w, h)
+ Nothing -> (80, 24) -- sensible default
+
+ -- Determine mode
+ let autoMode
+ | not supportsANSI = SimpleFallback
+ | width < 40 = SimpleFallback
+ | width < 80 = SingleLine
+ | otherwise = RichMultiLine
+
+ -- Allow manual override
+ let mode = case modeOverride of
+ Just "simple" -> SimpleFallback
+ Just "single" -> SingleLine
+ Just "rich" -> RichMultiLine
+ _ -> autoMode
+
+ 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 <> "..."
generated by cgit v1.2.3 (git 2.25.1) at 2025-11-16 22:16:00 +0000