1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
|
{-# 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)
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
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)
withLineManager :: [Namespace] -> (LineManager -> IO a) -> IO a
withLineManager nss action = do
termInfo <- detectTerminal
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
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, lmTermInfo = termInfo}
writeIORef currentLineManager (Just mgr)
-- 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
pure result
-- | Initialize all lines with pending status
initializeLines :: LineManager -> IO ()
initializeLines LineManager {..} =
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
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
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
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
-- 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
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)
|
