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
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- | Concurrent logging with multi-line output support
module Omni.Log.Concurrent
( LineManager,
BuildState (..),
withLineManager,
reserveLine,
updateLine,
releaseLine,
updateCurrentLine,
releaseCurrentLine,
)
where
import Alpha
import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)
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
import System.IO.Unsafe (unsafePerformIO)
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
}
{-# NOINLINE currentLineManager #-}
currentLineManager :: IORef (Maybe LineManager)
currentLineManager = unsafePerformIO (newIORef Nothing)
{-# NOINLINE namespaceLines #-}
namespaceLines :: IORef (Map Namespace Int)
namespaceLines = unsafePerformIO (newIORef Map.empty)
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
let mgr =
LineManager
{ lmLines = linesRef,
lmMaxLines = 1,
lmCurrentLine = currentRef,
lmSupportsANSI = False
}
writeIORef currentLineManager (Just mgr)
result <- action mgr
writeIORef currentLineManager Nothing
writeIORef namespaceLines Map.empty
pure result
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
let mgr =
LineManager
{ lmLines = linesRef,
lmMaxLines = maxLines,
lmCurrentLine = currentRef,
lmSupportsANSI = True
}
writeIORef currentLineManager (Just mgr)
result <- action mgr
ANSI.hCursorDown IO.stderr maxLines
writeIORef currentLineManager Nothing
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
reserveLine :: LineManager -> Namespace -> IO (Maybe Int)
reserveLine LineManager {..} ns =
if not lmSupportsANSI
then pure Nothing
else do
mLine <-
atomicModifyIORef' lmLines <| \linesMap ->
case findFirstFree linesMap of
Nothing -> (linesMap, Nothing)
Just lineNum ->
let status = BuildStatus ns "" Building
linesMap' = Map.insert lineNum (Just status) linesMap
in (linesMap', Just lineNum)
case mLine of
Just lineNum -> modifyIORef' namespaceLines (Map.insert ns lineNum)
Nothing -> pure ()
pure mLine
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 _ 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 <| \linesMap ->
Map.adjust (fmap (\bs -> bs {bsLastOutput = output})) lineNum linesMap
releaseLine :: LineManager -> Maybe Int -> BuildState -> IO ()
releaseLine LineManager {..} mLineNum buildState =
case mLineNum of
Nothing -> pure ()
Just lineNum -> do
modifyIORef' lmLines <| \linesMap ->
Map.insert lineNum Nothing linesMap
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 buildState of
Success -> "✓"
Failed -> "✗"
Building -> "…"
IO.hPutStr IO.stderr statusChar
IO.hFlush IO.stderr
ANSI.hRestoreCursor IO.stderr
updateCurrentLine :: Namespace -> Text -> IO ()
updateCurrentLine ns output = do
mMgr <- readIORef currentLineManager
case mMgr of
Nothing -> do
IO.hPutStr IO.stderr (Text.unpack <| output <> "\r")
IO.hFlush IO.stderr
Just mgr -> do
nsMap <- readIORef namespaceLines
case Map.lookup ns nsMap of
Nothing -> do
IO.hPutStr IO.stderr (Text.unpack <| output <> "\r")
IO.hFlush IO.stderr
Just lineNum -> updateLine mgr (Just lineNum) ns output
releaseCurrentLine :: Namespace -> BuildState -> IO ()
releaseCurrentLine ns buildState = do
mMgr <- readIORef currentLineManager
case mMgr of
Nothing -> pure ()
Just mgr -> do
nsMap <- readIORef namespaceLines
case Map.lookup ns nsMap of
Nothing -> pure ()
Just lineNum -> do
releaseLine mgr (Just lineNum) buildState
modifyIORef' namespaceLines (Map.delete ns)
|
