path: root/Omni/Log/Concurrent.hs

{-# 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)