{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}

{- |
Implementations of different backends that telemetry can be exported to.
-}
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

-- TODO convert this into a Render instance

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