{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
module Core.Telemetry.Console (
consoleExporter,
) where
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TQueue (TQueue, writeTQueue)
import Core.Data.Clock
import Core.Data.Structures (fromMap)
import Core.Encoding.Json
import Core.Program.Arguments
import Core.Program.Context
import Core.Program.Logging
import Core.Text.Colour
import Core.Text.Rope
import Core.Text.Utilities
import Data.List qualified as List
consoleExporter :: Exporter
consoleExporter :: Exporter
consoleExporter =
Exporter
{ $sel:codenameFrom:Exporter :: Rope
codenameFrom = Rope
"console"
, $sel:setupConfigFrom:Exporter :: Config -> Config
setupConfigFrom = Config -> Config
setupConsoleConfig
, $sel:setupActionFrom:Exporter :: forall τ. Context τ -> IO Forwarder
setupActionFrom = forall τ. Context τ -> IO Forwarder
setupConsoleAction
}
setupConsoleConfig :: Config -> Config
setupConsoleConfig :: Config -> Config
setupConsoleConfig = forall a. a -> a
id
setupConsoleAction :: Context τ -> IO Forwarder
setupConsoleAction :: forall τ. Context τ -> IO Forwarder
setupConsoleAction Context τ
context = do
let out :: TQueue (Maybe Rope)
out = forall τ. Context τ -> TQueue (Maybe Rope)
outputChannelFrom Context τ
context
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Forwarder
{ $sel:telemetryHandlerFrom:Forwarder :: [Datum] -> IO ()
telemetryHandlerFrom = TQueue (Maybe Rope) -> [Datum] -> IO ()
processConsoleOutput TQueue (Maybe Rope)
out
}
)
processConsoleOutput :: TQueue (Maybe Rope) -> [Datum] -> IO ()
processConsoleOutput :: TQueue (Maybe Rope) -> [Datum] -> IO ()
processConsoleOutput TQueue (Maybe Rope)
out [Datum]
datums = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Datum -> IO ()
processOne [Datum]
datums
where
processOne :: Datum -> IO ()
processOne :: Datum -> IO ()
processOne Datum
datum = do
let start :: Time
start = Datum -> Time
spanTimeFrom Datum
datum
let text :: Rope
text =
Char -> Rope
singletonRope Char
'\n'
forall a. Semigroup a => a -> a -> a
<> AnsiColour -> Rope
intoEscapes AnsiColour
pureGrey
forall a. Semigroup a => a -> a -> a
<> Datum -> Rope
spanNameFrom Datum
datum
forall a. Semigroup a => a -> a -> a
<> Char -> Rope
singletonRope Char
':'
forall a. Semigroup a => a -> a -> a
<> let pairs :: [(JsonKey, JsonValue)]
pairs :: [(JsonKey, JsonValue)]
pairs = forall α. Dictionary α => Map (K α) (V α) -> α
fromMap (Datum -> Map JsonKey JsonValue
attachedMetadataFrom Datum
datum)
in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Rope -> (JsonKey, JsonValue) -> Rope
f Rope
emptyRope [(JsonKey, JsonValue)]
pairs
forall a. Semigroup a => a -> a -> a
<> AnsiColour -> Rope
intoEscapes AnsiColour
resetColour
Time
now <- IO Time
getCurrentTimeNanoseconds
let result :: Rope
result =
Time -> Time -> Bool -> Severity -> Rope -> Rope
formatLogMessage
Time
start
Time
now
Bool
True
Severity
SeverityInternal
Rope
text
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Rope)
out (forall a. a -> Maybe a
Just Rope
result)
f :: Rope -> (JsonKey, JsonValue) -> Rope
f :: Rope -> (JsonKey, JsonValue) -> Rope
f Rope
acc (JsonKey
k, JsonValue
v) =
Rope
acc forall a. Semigroup a => a -> a -> a
<> Rope
"\n "
forall a. Semigroup a => a -> a -> a
<> AnsiColour -> Rope
intoEscapes AnsiColour
pureGrey
forall a. Semigroup a => a -> a -> a
<> forall α. Textual α => α -> Rope
intoRope JsonKey
k
forall a. Semigroup a => a -> a -> a
<> Rope
" = "
forall a. Semigroup a => a -> a -> a
<> forall α. Render α => Int -> α -> Rope
render Int
80 JsonValue
v