{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Core.Telemetry.Console (
consoleExporter,
) where
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TQueue (TQueue, writeTQueue)
import Core.Data.Structures (fromMap)
import Core.Encoding.Json
import Core.Program.Arguments
import Core.Program.Context
import Core.Program.Logging
import Core.System.External (getCurrentTimeNanoseconds)
import Core.Text.Colour
import Core.Text.Rope
import Core.Text.Utilities
import qualified Data.List as List
consoleExporter :: Exporter
consoleExporter :: Exporter
consoleExporter =
Exporter :: Rope
-> (Config -> Config)
-> (forall τ. Context τ -> IO Forwarder)
-> Exporter
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 = Config -> Config
forall a. a -> a
id
setupConsoleAction :: Context τ -> IO Forwarder
setupConsoleAction :: Context τ -> IO Forwarder
setupConsoleAction Context τ
context = do
let out :: TQueue (Maybe Rope)
out = Context τ -> TQueue (Maybe Rope)
forall τ. Context τ -> TQueue (Maybe Rope)
outputChannelFrom Context τ
context
Forwarder -> IO Forwarder
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Forwarder :: ([Datum] -> IO ()) -> Forwarder
Forwarder
{ $sel:telemetryHandlerFrom:Forwarder :: [Datum] -> IO ()
telemetryHandlerFrom = TQueue (Maybe Rope) -> [Datum] -> IO ()
process TQueue (Maybe Rope)
out
}
)
process :: TQueue (Maybe Rope) -> [Datum] -> IO ()
process :: TQueue (Maybe Rope) -> [Datum] -> IO ()
process TQueue (Maybe Rope)
out [Datum]
datums = do
(Datum -> IO ()) -> [Datum] -> IO ()
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 :: TimeStamp
start = Datum -> TimeStamp
spanTimeFrom Datum
datum
let text :: Rope
text =
(AnsiColour -> Rope
intoEscapes AnsiColour
pureGrey)
Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Datum -> Rope
spanNameFrom Datum
datum
Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Char -> Rope
singletonRope Char
':'
Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> let pairs :: [(JsonKey, JsonValue)]
pairs :: [(JsonKey, JsonValue)]
pairs = Map (K [(JsonKey, JsonValue)]) (V [(JsonKey, JsonValue)])
-> [(JsonKey, JsonValue)]
forall α. Dictionary α => Map (K α) (V α) -> α
fromMap (Datum -> Map JsonKey JsonValue
attachedMetadataFrom Datum
datum)
in (Rope -> (JsonKey, JsonValue) -> Rope)
-> Rope -> [(JsonKey, JsonValue)] -> Rope
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
Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> (AnsiColour -> Rope
intoEscapes AnsiColour
resetColour)
TimeStamp
now <- IO TimeStamp
getCurrentTimeNanoseconds
let result :: Rope
result =
TimeStamp -> TimeStamp -> Severity -> Rope -> Rope
formatLogMessage
TimeStamp
start
TimeStamp
now
Severity
SeverityDebug
Rope
text
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TQueue (Maybe Rope) -> Maybe Rope -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Rope)
out (Rope -> Maybe Rope
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 Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
"\n "
Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> (AnsiColour -> Rope
intoEscapes AnsiColour
pureGrey)
Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> JsonKey -> Rope
forall α. Textual α => α -> Rope
intoRope JsonKey
k
Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
" = "
Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Int -> JsonValue -> Rope
forall α. Render α => Int -> α -> Rope
render Int
80 JsonValue
v