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
|
{-# 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.Namespace (Namespace)
import qualified Omni.Namespace as Namespace
import Rainbow (chunk, fore, green, red)
import qualified Rainbow
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 = Pending | Building | Success | Failed
deriving (Eq, Show)
data LineManager = LineManager
{ lmNamespaces :: [Namespace],
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 :: [Namespace] -> (LineManager -> IO a) -> IO a
withLineManager nss action = do
supportsANSI <- checkANSISupport
if not supportsANSI
then do
let mgr = LineManager {lmNamespaces = nss, lmSupportsANSI = False}
writeIORef currentLineManager (Just mgr)
result <- action mgr
writeIORef currentLineManager Nothing
writeIORef namespaceLines Map.empty
pure result
else do
let numLines = length nss
IO.hPutStrLn IO.stderr ""
replicateM_ numLines (IO.hPutStrLn IO.stderr "")
ANSI.hCursorUp IO.stderr numLines
let mgr = LineManager {lmNamespaces = nss, lmSupportsANSI = True}
writeIORef currentLineManager (Just mgr)
-- Initialize the namespace -> line mapping
writeIORef namespaceLines (Map.fromList <| zip nss [0 ..])
result <- action mgr
ANSI.hCursorDown IO.stderr numLines
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
-- | Initialize all lines with pending status
initializeLines :: LineManager -> IO ()
initializeLines LineManager {..} =
when lmSupportsANSI <| do
nsMap <- readIORef namespaceLines
forM_ (Map.toList nsMap) <| \(ns, lineNum) -> do
ANSI.hSaveCursor IO.stderr
ANSI.hSetCursorColumn IO.stderr 0
when (lineNum > 0) <| ANSI.hCursorDown IO.stderr lineNum
ANSI.hClearLine IO.stderr
let nsText = Text.pack (Namespace.toPath ns)
IO.hPutStr IO.stderr (Text.unpack <| "[…] " <> nsText)
IO.hFlush IO.stderr
ANSI.hRestoreCursor 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 {..} ->
if not lmSupportsANSI
then do
IO.hPutStr IO.stderr (Text.unpack <| output <> "\n")
IO.hFlush IO.stderr
else do
nsMap <- readIORef namespaceLines
case Map.lookup ns nsMap of
Nothing -> pure ()
Just lineNum -> do
ANSI.hSaveCursor IO.stderr
ANSI.hSetCursorColumn IO.stderr 0
ANSI.hCursorUp IO.stderr (length lmNamespaces - lineNum)
ANSI.hClearLine IO.stderr
let nsText = Text.pack (Namespace.toPath ns)
let formattedOutput = if Text.null output then "[~] " <> nsText else "[~] " <> nsText <> ": " <> output
IO.hPutStr IO.stderr (Text.unpack formattedOutput)
IO.hFlush IO.stderr
ANSI.hRestoreCursor IO.stderr
updateLineState :: Namespace -> BuildState -> IO ()
updateLineState ns buildState = do
mMgr <- readIORef currentLineManager
case mMgr of
Nothing -> pure ()
Just LineManager {..} ->
when lmSupportsANSI <| do
nsMap <- readIORef namespaceLines
case Map.lookup ns nsMap of
Nothing -> pure ()
Just lineNum -> do
ANSI.hSaveCursor IO.stderr
ANSI.hSetCursorColumn IO.stderr 0
ANSI.hCursorUp IO.stderr (length lmNamespaces - lineNum)
ANSI.hClearLine IO.stderr
let nsText = Text.pack (Namespace.toPath ns)
case buildState of
Success ->
Rainbow.hPutChunks IO.stderr [fore green <| chunk <| "[✓] " <> nsText]
Failed ->
Rainbow.hPutChunks IO.stderr [fore red <| chunk <| "[x] " <> nsText]
Pending ->
IO.hPutStr IO.stderr (Text.unpack <| "[…] " <> nsText)
Building ->
IO.hPutStr IO.stderr (Text.unpack <| "[~] " <> nsText)
IO.hFlush IO.stderr
ANSI.hRestoreCursor IO.stderr
|
