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

{- |
A simple exporter backend that prints your metrics to the terminal as they are
submitted.

Taking the example from 'Core.Telemetry.Observability.telemetry', the output
would be:

@
09:58:54Z (03.755) Process order:
  calories = 667.0
  flavour = true
  meal_name = "hamburger"
  precise = 45.0
@
-}
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

{- |
Output metrics to the terminal. This is mostly useful for debugging, but it
can also be used as general output mechanism if your program is mostly
concerned with gathering metrics and displaying them.
-}
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 ()
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
    (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 :: Time
start = Datum -> Time
spanTimeFrom Datum
datum
        let text :: Rope
text =
                Char -> Rope
singletonRope Char
'\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
<> 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

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