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