summaryrefslogtreecommitdiff
path: root/Omni
diff options
context:
space:
mode:
authorBen Sima <ben@bsima.me>2025-11-14 13:33:39 -0500
committerBen Sima <ben@bsima.me>2025-11-14 13:33:39 -0500
commit4c4dc3a991ffde0aa821f8669024787fb65635ba (patch)
treeb98e0262d805deb5cca1ae6bffcf9165b916c3c5 /Omni
parented9548957db92f112ab1d7105da235e12d5ea3a8 (diff)
Create Omni/Log/Concurrent module for multi-line output
- Implement LineManager abstraction with IORef state - Line reservation/update/release functions - ANSI cursor positioning for concurrent updates - Terminal capability detection (ANSI vs dumb) - Graceful fallback for non-ANSI terminals Tasks: t-1a1DzES, t-1a1DGY0, t-1a1DOev, t-1a1DVM5
Diffstat (limited to 'Omni')
-rw-r--r--Omni/Log/Concurrent.hs155
1 files changed, 155 insertions, 0 deletions
diff --git a/Omni/Log/Concurrent.hs b/Omni/Log/Concurrent.hs
new file mode 100644
index 0000000..2a46df5
--- /dev/null
+++ b/Omni/Log/Concurrent.hs
@@ -0,0 +1,155 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Concurrent logging with multi-line output support
+module Omni.Log.Concurrent
+ ( LineManager,
+ BuildState (..),
+ withLineManager,
+ reserveLine,
+ updateLine,
+ releaseLine,
+ )
+where
+
+import Alpha
+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef)
+import qualified Data.Map as Map
+import qualified Data.Text as Text
+import Omni.Namespace (Namespace)
+import qualified Omni.Namespace as Namespace
+import qualified System.Console.ANSI as ANSI
+import qualified System.Environment as Env
+import qualified System.IO as IO
+
+data BuildState = Building | Success | Failed
+ deriving (Eq, Show)
+
+data BuildStatus = BuildStatus
+ { bsTarget :: Namespace,
+ bsLastOutput :: Text,
+ bsState :: BuildState
+ }
+
+data LineManager = LineManager
+ { lmLines :: IORef (Map Int (Maybe BuildStatus)),
+ lmMaxLines :: Int,
+ lmCurrentLine :: IORef Int,
+ lmSupportsANSI :: Bool
+ }
+
+withLineManager :: Int -> (LineManager -> IO a) -> IO a
+withLineManager maxLines action = do
+ supportsANSI <- checkANSISupport
+
+ if not supportsANSI
+ then do
+ linesRef <- newIORef Map.empty
+ currentRef <- newIORef 0
+ action
+ LineManager
+ { lmLines = linesRef,
+ lmMaxLines = 1,
+ lmCurrentLine = currentRef,
+ lmSupportsANSI = False
+ }
+ else do
+ replicateM_ maxLines (IO.hPutStrLn IO.stderr "")
+ ANSI.hCursorUp IO.stderr maxLines
+
+ linesRef <- newIORef (Map.fromList [(i, Nothing) | i <- [0 .. maxLines - 1]])
+ currentRef <- newIORef maxLines
+
+ result <-
+ action
+ LineManager
+ { lmLines = linesRef,
+ lmMaxLines = maxLines,
+ lmCurrentLine = currentRef,
+ lmSupportsANSI = True
+ }
+
+ ANSI.hCursorDown IO.stderr maxLines
+ 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
+
+reserveLine :: LineManager -> Namespace -> IO (Maybe Int)
+reserveLine LineManager {..} ns =
+ if not lmSupportsANSI
+ then pure Nothing
+ else
+ atomicModifyIORef' lmLines <| \lines ->
+ case findFirstFree lines of
+ Nothing -> (lines, Nothing)
+ Just lineNum ->
+ let status = BuildStatus ns "" Building
+ lines' = Map.insert lineNum (Just status) lines
+ in (lines', Just lineNum)
+ 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")
+ 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.hClearLine IO.stderr
+ IO.hPutStr IO.stderr (Text.unpack output)
+ IO.hFlush IO.stderr
+
+ ANSI.hRestoreCursor IO.stderr
+
+ modifyIORef' lmLines <| \lines ->
+ Map.adjust (fmap (\bs -> bs {bsLastOutput = output})) lineNum lines
+
+releaseLine :: LineManager -> Maybe Int -> BuildState -> IO ()
+releaseLine LineManager {..} mLineNum state =
+ case mLineNum of
+ Nothing -> pure ()
+ Just lineNum -> do
+ modifyIORef' lmLines <| \lines ->
+ Map.insert lineNum Nothing lines
+
+ 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 statusChar = case state of
+ Success -> "✓"
+ Failed -> "✗"
+ Building -> "…"
+ IO.hPutStr IO.stderr statusChar
+ IO.hFlush IO.stderr
+
+ ANSI.hRestoreCursor IO.stderr