{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
module Control.Monad.Logger.Aeson.Internal
  ( -- * Disclaimer
    -- $disclaimer

    -- ** @Message@-related
    Message(..)
  , SeriesElem(..)
  , LoggedMessage(..)
  , threadContextStore
  , logCS
  , OutputOptions(..)
  , defaultLogStrBS
  , defaultLogStrLBS
  , messageEncoding
  , messageSeries

    -- ** @LogItem@-related
  , LogItem(..)
  , logItemEncoding

    -- ** Encoding-related
  , pairsEncoding
  , pairsSeries
  , levelEncoding
  , locEncoding

    -- ** @monad-logger@ internals
  , mkLoggerLoc
  , locFromCS
  , isDefaultLoc

    -- ** Aeson compat
  , Key
  , KeyMap
  , emptyKeyMap
  , keyMapFromList
  , keyMapToList
  , keyMapInsert
  , keyMapUnion
  ) where

import Context (Store)
import Control.Monad.Logger (Loc(..), LogLevel(..), MonadLogger(..), ToLogStr(..), LogSource)
import Data.Aeson (KeyValue(..), Value(Object), (.:), (.:?), Encoding, FromJSON, ToJSON)
import Data.Aeson.Encoding.Internal (Series(..))
import Data.Aeson.Types (Pair, Parser)
import Data.String (IsString)
import Data.Text (Text)
import Data.Time (UTCTime)
import GHC.Generics (Generic)
import GHC.Stack (SrcLoc(..), CallStack, getCallStack)
import qualified Context
import qualified Control.Monad.Logger as Logger
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encoding as Aeson
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS8
import qualified Data.Maybe as Maybe
import qualified Data.String as String
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text.Encoding
import qualified Data.Text.Encoding.Error as Text.Encoding.Error
import qualified System.IO.Unsafe as IO.Unsafe

#if MIN_VERSION_fast_logger(3,0,1)
import System.Log.FastLogger.Internal (LogStr(..))
#else
import System.Log.FastLogger (LogStr, fromLogStr)
#endif

#if MIN_VERSION_aeson(2, 0, 0)
import Data.Aeson.Key (Key)
import Data.Aeson.KeyMap (KeyMap)
import qualified Data.Aeson.KeyMap as AesonCompat
#else
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as AesonCompat
type Key = Text
type KeyMap v = HashMap Key v
#endif

emptyKeyMap :: KeyMap v
emptyKeyMap :: forall v. KeyMap v
emptyKeyMap = KeyMap v
forall v. KeyMap v
AesonCompat.empty

keyMapFromList :: [(Key, v)] -> KeyMap v
keyMapFromList :: forall v. [(Key, v)] -> KeyMap v
keyMapFromList = [(Key, v)] -> KeyMap v
forall v. [(Key, v)] -> KeyMap v
AesonCompat.fromList

keyMapToList :: KeyMap v -> [(Key, v)]
keyMapToList :: forall v. KeyMap v -> [(Key, v)]
keyMapToList = KeyMap v -> [(Key, v)]
forall v. KeyMap v -> [(Key, v)]
AesonCompat.toList

keyMapInsert :: Key -> v -> KeyMap v -> KeyMap v
keyMapInsert :: forall v. Key -> v -> KeyMap v -> KeyMap v
keyMapInsert = Key -> v -> KeyMap v -> KeyMap v
forall v. Key -> v -> KeyMap v -> KeyMap v
AesonCompat.insert

keyMapUnion :: KeyMap v -> KeyMap v -> KeyMap v
keyMapUnion :: forall v. KeyMap v -> KeyMap v -> KeyMap v
keyMapUnion = KeyMap v -> KeyMap v -> KeyMap v
forall v. KeyMap v -> KeyMap v -> KeyMap v
AesonCompat.union

-- | A single key-value pair, where the value is encoded JSON. This is a more
-- restricted version of 'Series': a 'SeriesElem' is intended to encapsulate
-- exactly one key-value pair, whereas a 'Series' encapsulates zero or more
-- key-value pairs. 'SeriesElem' values can be created via '(.=)' from @aeson@.
--
-- While a 'SeriesElem' most often will map to a single pair, note that a
-- 'Semigroup' instance is available for performance's sake. The 'Semigroup'
-- instance is useful when multiple pairs are grouped together and then shared
-- across multiple logging calls. In that case, the cost of combining the pairs
-- in the group must only be paid once.
--
-- @since 0.3.0.0
newtype SeriesElem = UnsafeSeriesElem
  { SeriesElem -> Series
unSeriesElem :: Series
  }

-- | @since 0.3.0.0
#if MIN_VERSION_aeson(2, 2, 0)
instance KeyValue Encoding SeriesElem where
  .= :: forall v. ToJSON v => Key -> v -> SeriesElem
(.=) = (v -> Encoding) -> Key -> v -> SeriesElem
forall v. (v -> Encoding) -> Key -> v -> SeriesElem
forall e kv v. KeyValue e kv => (v -> e) -> Key -> v -> kv
explicitToField v -> Encoding
forall a. ToJSON a => a -> Encoding
Aeson.toEncoding
  {-# INLINE (.=) #-}

  explicitToField :: forall v. (v -> Encoding) -> Key -> v -> SeriesElem
explicitToField v -> Encoding
f Key
name v
value =
    Series -> SeriesElem
UnsafeSeriesElem (Series -> SeriesElem) -> Series -> SeriesElem
forall a b. (a -> b) -> a -> b
$ Key -> Encoding -> Series
Aeson.pair Key
name (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ v -> Encoding
f v
value
  {-# INLINE explicitToField #-}
#else
deriving newtype instance KeyValue SeriesElem
#endif
-- | @since 0.3.1.0
deriving newtype instance Semigroup SeriesElem

-- | This type is the Haskell representation of each JSON log message produced
-- by this library.
--
-- While we never interact with this type directly when logging messages with
-- @monad-logger-aeson@, we may wish to use this type if we are
-- parsing/processing log files generated by this library.
--
-- @since 0.1.0.0
data LoggedMessage = LoggedMessage
  { LoggedMessage -> UTCTime
loggedMessageTimestamp :: UTCTime
  , LoggedMessage -> LogLevel
loggedMessageLevel :: LogLevel
  , LoggedMessage -> Maybe Loc
loggedMessageLoc :: Maybe Loc
  , LoggedMessage -> Maybe Text
loggedMessageLogSource :: Maybe LogSource
  , LoggedMessage -> KeyMap Value
loggedMessageThreadContext :: KeyMap Value
  , LoggedMessage -> Text
loggedMessageText :: Text
  , LoggedMessage -> KeyMap Value
loggedMessageMeta :: KeyMap Value
  } deriving stock (LoggedMessage -> LoggedMessage -> Bool
(LoggedMessage -> LoggedMessage -> Bool)
-> (LoggedMessage -> LoggedMessage -> Bool) -> Eq LoggedMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LoggedMessage -> LoggedMessage -> Bool
== :: LoggedMessage -> LoggedMessage -> Bool
$c/= :: LoggedMessage -> LoggedMessage -> Bool
/= :: LoggedMessage -> LoggedMessage -> Bool
Eq, (forall x. LoggedMessage -> Rep LoggedMessage x)
-> (forall x. Rep LoggedMessage x -> LoggedMessage)
-> Generic LoggedMessage
forall x. Rep LoggedMessage x -> LoggedMessage
forall x. LoggedMessage -> Rep LoggedMessage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LoggedMessage -> Rep LoggedMessage x
from :: forall x. LoggedMessage -> Rep LoggedMessage x
$cto :: forall x. Rep LoggedMessage x -> LoggedMessage
to :: forall x. Rep LoggedMessage x -> LoggedMessage
Generic, Eq LoggedMessage
Eq LoggedMessage =>
(LoggedMessage -> LoggedMessage -> Ordering)
-> (LoggedMessage -> LoggedMessage -> Bool)
-> (LoggedMessage -> LoggedMessage -> Bool)
-> (LoggedMessage -> LoggedMessage -> Bool)
-> (LoggedMessage -> LoggedMessage -> Bool)
-> (LoggedMessage -> LoggedMessage -> LoggedMessage)
-> (LoggedMessage -> LoggedMessage -> LoggedMessage)
-> Ord LoggedMessage
LoggedMessage -> LoggedMessage -> Bool
LoggedMessage -> LoggedMessage -> Ordering
LoggedMessage -> LoggedMessage -> LoggedMessage
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LoggedMessage -> LoggedMessage -> Ordering
compare :: LoggedMessage -> LoggedMessage -> Ordering
$c< :: LoggedMessage -> LoggedMessage -> Bool
< :: LoggedMessage -> LoggedMessage -> Bool
$c<= :: LoggedMessage -> LoggedMessage -> Bool
<= :: LoggedMessage -> LoggedMessage -> Bool
$c> :: LoggedMessage -> LoggedMessage -> Bool
> :: LoggedMessage -> LoggedMessage -> Bool
$c>= :: LoggedMessage -> LoggedMessage -> Bool
>= :: LoggedMessage -> LoggedMessage -> Bool
$cmax :: LoggedMessage -> LoggedMessage -> LoggedMessage
max :: LoggedMessage -> LoggedMessage -> LoggedMessage
$cmin :: LoggedMessage -> LoggedMessage -> LoggedMessage
min :: LoggedMessage -> LoggedMessage -> LoggedMessage
Ord, Int -> LoggedMessage -> ShowS
[LoggedMessage] -> ShowS
LoggedMessage -> String
(Int -> LoggedMessage -> ShowS)
-> (LoggedMessage -> String)
-> ([LoggedMessage] -> ShowS)
-> Show LoggedMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LoggedMessage -> ShowS
showsPrec :: Int -> LoggedMessage -> ShowS
$cshow :: LoggedMessage -> String
show :: LoggedMessage -> String
$cshowList :: [LoggedMessage] -> ShowS
showList :: [LoggedMessage] -> ShowS
Show)

instance FromJSON LoggedMessage where
  parseJSON :: Value -> Parser LoggedMessage
parseJSON = String
-> (KeyMap Value -> Parser LoggedMessage)
-> Value
-> Parser LoggedMessage
forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
Aeson.withObject String
"LoggedMessage" ((KeyMap Value -> Parser LoggedMessage)
 -> Value -> Parser LoggedMessage)
-> (KeyMap Value -> Parser LoggedMessage)
-> Value
-> Parser LoggedMessage
forall a b. (a -> b) -> a -> b
$ \KeyMap Value
obj -> do
    UTCTime
loggedMessageTimestamp <- KeyMap Value
obj KeyMap Value -> Key -> Parser UTCTime
forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"time"
    LogLevel
loggedMessageLevel <- (Text -> LogLevel) -> Parser Text -> Parser LogLevel
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> LogLevel
logLevelFromText (Parser Text -> Parser LogLevel) -> Parser Text -> Parser LogLevel
forall a b. (a -> b) -> a -> b
$ KeyMap Value
obj KeyMap Value -> Key -> Parser Text
forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"level"
    Maybe Loc
loggedMessageLoc <- Maybe Value -> Parser (Maybe Loc)
parseLoc (Maybe Value -> Parser (Maybe Loc))
-> Parser (Maybe Value) -> Parser (Maybe Loc)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KeyMap Value
obj KeyMap Value -> Key -> Parser (Maybe Value)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"location"
    Maybe Text
loggedMessageLogSource <- KeyMap Value
obj KeyMap Value -> Key -> Parser (Maybe Text)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"source"
    KeyMap Value
loggedMessageThreadContext <- Maybe Value -> Parser (KeyMap Value)
parsePairs (Maybe Value -> Parser (KeyMap Value))
-> Parser (Maybe Value) -> Parser (KeyMap Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KeyMap Value
obj KeyMap Value -> Key -> Parser (Maybe Value)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"context"
    (Text
loggedMessageText, KeyMap Value
loggedMessageMeta) <- Value -> Parser (Text, KeyMap Value)
parseMessage (Value -> Parser (Text, KeyMap Value))
-> Parser Value -> Parser (Text, KeyMap Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KeyMap Value
obj KeyMap Value -> Key -> Parser Value
forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"message"
    LoggedMessage -> Parser LoggedMessage
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoggedMessage
      { UTCTime
loggedMessageTimestamp :: UTCTime
loggedMessageTimestamp :: UTCTime
loggedMessageTimestamp
      , LogLevel
loggedMessageLevel :: LogLevel
loggedMessageLevel :: LogLevel
loggedMessageLevel
      , Maybe Loc
loggedMessageLoc :: Maybe Loc
loggedMessageLoc :: Maybe Loc
loggedMessageLoc
      , Maybe Text
loggedMessageLogSource :: Maybe Text
loggedMessageLogSource :: Maybe Text
loggedMessageLogSource
      , KeyMap Value
loggedMessageThreadContext :: KeyMap Value
loggedMessageThreadContext :: KeyMap Value
loggedMessageThreadContext
      , Text
loggedMessageText :: Text
loggedMessageText :: Text
loggedMessageText
      , KeyMap Value
loggedMessageMeta :: KeyMap Value
loggedMessageMeta :: KeyMap Value
loggedMessageMeta
      }
    where
    logLevelFromText :: Text -> LogLevel
    logLevelFromText :: Text -> LogLevel
logLevelFromText = \case
      Text
"debug" -> LogLevel
LevelDebug
      Text
"info" -> LogLevel
LevelInfo
      Text
"warn" -> LogLevel
LevelWarn
      Text
"error" -> LogLevel
LevelError
      Text
other -> Text -> LogLevel
LevelOther Text
other

    parseLoc :: Maybe Value -> Parser (Maybe Loc)
    parseLoc :: Maybe Value -> Parser (Maybe Loc)
parseLoc =
      (Value -> Parser Loc) -> Maybe Value -> Parser (Maybe Loc)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ((Value -> Parser Loc) -> Maybe Value -> Parser (Maybe Loc))
-> (Value -> Parser Loc) -> Maybe Value -> Parser (Maybe Loc)
forall a b. (a -> b) -> a -> b
$ String -> (KeyMap Value -> Parser Loc) -> Value -> Parser Loc
forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Loc" ((KeyMap Value -> Parser Loc) -> Value -> Parser Loc)
-> (KeyMap Value -> Parser Loc) -> Value -> Parser Loc
forall a b. (a -> b) -> a -> b
$ \KeyMap Value
obj ->
        String -> String -> String -> CharPos -> CharPos -> Loc
Loc
          (String -> String -> String -> CharPos -> CharPos -> Loc)
-> Parser String
-> Parser (String -> String -> CharPos -> CharPos -> Loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyMap Value
obj KeyMap Value -> Key -> Parser String
forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"file"
          Parser (String -> String -> CharPos -> CharPos -> Loc)
-> Parser String -> Parser (String -> CharPos -> CharPos -> Loc)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyMap Value
obj KeyMap Value -> Key -> Parser String
forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"package"
          Parser (String -> CharPos -> CharPos -> Loc)
-> Parser String -> Parser (CharPos -> CharPos -> Loc)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyMap Value
obj KeyMap Value -> Key -> Parser String
forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"module"
          Parser (CharPos -> CharPos -> Loc)
-> Parser CharPos -> Parser (CharPos -> Loc)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Int -> Int -> CharPos) -> Parser (Int -> Int -> CharPos)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (,) Parser (Int -> Int -> CharPos)
-> Parser Int -> Parser (Int -> CharPos)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (KeyMap Value
obj KeyMap Value -> Key -> Parser Int
forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"line") Parser (Int -> CharPos) -> Parser Int -> Parser CharPos
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (KeyMap Value
obj KeyMap Value -> Key -> Parser Int
forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"char"))
          Parser (CharPos -> Loc) -> Parser CharPos -> Parser Loc
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CharPos -> Parser CharPos
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, Int
0)

    parsePairs :: Maybe Value -> Parser (KeyMap Value)
    parsePairs :: Maybe Value -> Parser (KeyMap Value)
parsePairs = \case
      Maybe Value
Nothing -> KeyMap Value -> Parser (KeyMap Value)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyMap Value
forall a. Monoid a => a
mempty
      Just Value
value -> ((KeyMap Value -> Parser (KeyMap Value))
 -> Value -> Parser (KeyMap Value))
-> Value
-> (KeyMap Value -> Parser (KeyMap Value))
-> Parser (KeyMap Value)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String
-> (KeyMap Value -> Parser (KeyMap Value))
-> Value
-> Parser (KeyMap Value)
forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
Aeson.withObject String
"[Pair]") Value
value ((KeyMap Value -> Parser (KeyMap Value)) -> Parser (KeyMap Value))
-> (KeyMap Value -> Parser (KeyMap Value)) -> Parser (KeyMap Value)
forall a b. (a -> b) -> a -> b
$ \KeyMap Value
obj -> do
        KeyMap Value -> Parser (KeyMap Value)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyMap Value
obj

    parseMessage :: Value -> Parser (Text, KeyMap Value)
    parseMessage :: Value -> Parser (Text, KeyMap Value)
parseMessage = String
-> (KeyMap Value -> Parser (Text, KeyMap Value))
-> Value
-> Parser (Text, KeyMap Value)
forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Message" ((KeyMap Value -> Parser (Text, KeyMap Value))
 -> Value -> Parser (Text, KeyMap Value))
-> (KeyMap Value -> Parser (Text, KeyMap Value))
-> Value
-> Parser (Text, KeyMap Value)
forall a b. (a -> b) -> a -> b
$ \KeyMap Value
obj ->
      (,) (Text -> KeyMap Value -> (Text, KeyMap Value))
-> Parser Text -> Parser (KeyMap Value -> (Text, KeyMap Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyMap Value
obj KeyMap Value -> Key -> Parser Text
forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"text" Parser (KeyMap Value -> (Text, KeyMap Value))
-> Parser (KeyMap Value) -> Parser (Text, KeyMap Value)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Maybe Value -> Parser (KeyMap Value)
parsePairs (Maybe Value -> Parser (KeyMap Value))
-> Parser (Maybe Value) -> Parser (KeyMap Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KeyMap Value
obj KeyMap Value -> Key -> Parser (Maybe Value)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"meta")

instance ToJSON LoggedMessage where
  toJSON :: LoggedMessage -> Value
toJSON LoggedMessage
loggedMessage =
    [Pair] -> Value
Aeson.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
Maybe.catMaybes
      [ Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"time" Key -> UTCTime -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTCTime
loggedMessageTimestamp
      , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"level" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= LogLevel -> Text
logLevelToText LogLevel
loggedMessageLevel
      , case Maybe Loc
loggedMessageLoc of
          Maybe Loc
Nothing -> Maybe Pair
forall a. Maybe a
Nothing
          Just Loc
loc -> Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"location" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Loc -> Value
locToJSON Loc
loc
      , case Maybe Text
loggedMessageLogSource of
          Maybe Text
Nothing -> Maybe Pair
forall a. Maybe a
Nothing
          Just Text
logSource -> Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"source" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
logSource
      , if KeyMap Value
loggedMessageThreadContext KeyMap Value -> KeyMap Value -> Bool
forall a. Eq a => a -> a -> Bool
== KeyMap Value
forall a. Monoid a => a
mempty then
          Maybe Pair
forall a. Maybe a
Nothing
        else
          Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"context" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= KeyMap Value -> Value
Object KeyMap Value
loggedMessageThreadContext
      , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"message" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
messageJSON
      ]
    where
    locToJSON :: Loc -> Value
    locToJSON :: Loc -> Value
locToJSON Loc
loc =
      [Pair] -> Value
Aeson.object
        [ Key
"package" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
loc_package
        , Key
"module" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
loc_module
        , Key
"file" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
loc_filename
        , Key
"line" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= CharPos -> Int
forall a b. (a, b) -> a
fst CharPos
loc_start
        , Key
"char" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= CharPos -> Int
forall a b. (a, b) -> b
snd CharPos
loc_start
        ]
      where
      Loc { String
loc_filename :: String
loc_filename :: Loc -> String
loc_filename, String
loc_package :: String
loc_package :: Loc -> String
loc_package, String
loc_module :: String
loc_module :: Loc -> String
loc_module, CharPos
loc_start :: CharPos
loc_start :: Loc -> CharPos
loc_start } = Loc
loc

    messageJSON :: Value
    messageJSON :: Value
messageJSON =
      [Pair] -> Value
Aeson.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
Maybe.catMaybes
        [ Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"text" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
loggedMessageText
        , if KeyMap Value
loggedMessageMeta KeyMap Value -> KeyMap Value -> Bool
forall a. Eq a => a -> a -> Bool
== KeyMap Value
forall a. Monoid a => a
mempty then
            Maybe Pair
forall a. Maybe a
Nothing
          else
            Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"meta" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= KeyMap Value -> Value
Object KeyMap Value
loggedMessageMeta
        ]

    LoggedMessage
      { UTCTime
loggedMessageTimestamp :: LoggedMessage -> UTCTime
loggedMessageTimestamp :: UTCTime
loggedMessageTimestamp
      , LogLevel
loggedMessageLevel :: LoggedMessage -> LogLevel
loggedMessageLevel :: LogLevel
loggedMessageLevel
      , Maybe Loc
loggedMessageLoc :: LoggedMessage -> Maybe Loc
loggedMessageLoc :: Maybe Loc
loggedMessageLoc
      , Maybe Text
loggedMessageLogSource :: LoggedMessage -> Maybe Text
loggedMessageLogSource :: Maybe Text
loggedMessageLogSource
      , KeyMap Value
loggedMessageThreadContext :: LoggedMessage -> KeyMap Value
loggedMessageThreadContext :: KeyMap Value
loggedMessageThreadContext
      , Text
loggedMessageText :: LoggedMessage -> Text
loggedMessageText :: Text
loggedMessageText
      , KeyMap Value
loggedMessageMeta :: LoggedMessage -> KeyMap Value
loggedMessageMeta :: KeyMap Value
loggedMessageMeta
      } = LoggedMessage
loggedMessage

  toEncoding :: LoggedMessage -> Encoding
toEncoding LoggedMessage
loggedMessage = LogItem -> Encoding
logItemEncoding LogItem
logItem
    where
    logItem :: LogItem
logItem =
      LogItem
        { logItemTimestamp :: UTCTime
logItemTimestamp = UTCTime
loggedMessageTimestamp
        , logItemLoc :: Loc
logItemLoc = Loc -> Maybe Loc -> Loc
forall a. a -> Maybe a -> a
Maybe.fromMaybe Loc
Logger.defaultLoc Maybe Loc
loggedMessageLoc
        , logItemLogSource :: Text
logItemLogSource = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
Maybe.fromMaybe Text
"" Maybe Text
loggedMessageLogSource
        , logItemLevel :: LogLevel
logItemLevel = LogLevel
loggedMessageLevel
        , logItemThreadContext :: KeyMap Value
logItemThreadContext = KeyMap Value
loggedMessageThreadContext
        , logItemMessageEncoding :: Encoding
logItemMessageEncoding =
            Message -> Encoding
messageEncoding (Message -> Encoding) -> Message -> Encoding
forall a b. (a -> b) -> a -> b
$
              Text
loggedMessageText Text -> [SeriesElem] -> Message
:# KeyMap Value -> [SeriesElem]
keyMapToSeriesList KeyMap Value
loggedMessageMeta
        }

    keyMapToSeriesList :: KeyMap Value -> [SeriesElem]
    keyMapToSeriesList :: KeyMap Value -> [SeriesElem]
keyMapToSeriesList =
      (Pair -> SeriesElem) -> [Pair] -> [SeriesElem]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Key -> Value -> SeriesElem) -> Pair -> SeriesElem
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key -> Value -> SeriesElem
forall v. ToJSON v => Key -> v -> SeriesElem
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
(.=)) ([Pair] -> [SeriesElem])
-> (KeyMap Value -> [Pair]) -> KeyMap Value -> [SeriesElem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyMap Value -> [Pair]
forall v. KeyMap v -> [(Key, v)]
keyMapToList

    LoggedMessage
      { UTCTime
loggedMessageTimestamp :: LoggedMessage -> UTCTime
loggedMessageTimestamp :: UTCTime
loggedMessageTimestamp
      , LogLevel
loggedMessageLevel :: LoggedMessage -> LogLevel
loggedMessageLevel :: LogLevel
loggedMessageLevel
      , Maybe Loc
loggedMessageLoc :: LoggedMessage -> Maybe Loc
loggedMessageLoc :: Maybe Loc
loggedMessageLoc
      , Maybe Text
loggedMessageLogSource :: LoggedMessage -> Maybe Text
loggedMessageLogSource :: Maybe Text
loggedMessageLogSource
      , KeyMap Value
loggedMessageThreadContext :: LoggedMessage -> KeyMap Value
loggedMessageThreadContext :: KeyMap Value
loggedMessageThreadContext
      , Text
loggedMessageText :: LoggedMessage -> Text
loggedMessageText :: Text
loggedMessageText
      , KeyMap Value
loggedMessageMeta :: LoggedMessage -> KeyMap Value
loggedMessageMeta :: KeyMap Value
loggedMessageMeta
      } = LoggedMessage
loggedMessage

-- | A 'Message' captures a textual component and a metadata component. The
-- metadata component is a list of 'SeriesElem' to support tacking on arbitrary
-- structured data to a log message.
--
-- With the @OverloadedStrings@ extension enabled, 'Message' values can be
-- constructed without metadata fairly conveniently, just as if we were using
-- 'Text' directly:
--
-- > logDebug "Some log message without metadata"
--
-- Metadata may be included in a 'Message' via the ':#' constructor:
--
-- @
-- 'Control.Monad.Logger.Aeson.logDebug' $ "Some log message with metadata" ':#'
--   [ "bloorp" '.=' (42 :: 'Int')
--   , "bonk" '.=' ("abc" :: 'Text')
--   ]
-- @
--
-- The mnemonic for the ':#' constructor is that the @#@ symbol is sometimes
-- referred to as a hash, a JSON object can be thought of as a hash map, and
-- so with @:#@ (and enough squinting), we are @cons@-ing a textual message onto
-- a JSON object. Yes, this mnemonic isn't well-typed, but hopefully it still
-- helps!
--
-- @since 0.1.0.0
data Message = Text :# [SeriesElem]
infixr 5 :#

instance IsString Message where
  fromString :: String -> Message
fromString String
string = String -> Text
Text.pack String
string Text -> [SeriesElem] -> Message
:# []

instance ToLogStr Message where
  toLogStr :: Message -> LogStr
toLogStr = ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (ByteString -> LogStr)
-> (Message -> ByteString) -> Message -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> ByteString
forall a. Encoding' a -> ByteString
Aeson.encodingToLazyByteString (Encoding -> ByteString)
-> (Message -> Encoding) -> Message -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Encoding
messageEncoding

-- | Thread-safe, global 'Store' that captures the thread context of messages.
--
-- Note that there is a bit of somewhat unavoidable name-overloading here: this
-- binding is called 'threadContextStore' because it stores the thread context
-- (i.e. @ThreadContext@/@MDC@ from Java land) for messages. It also just so
-- happens that the 'Store' type comes from the @context@ package, which is a
-- package providing thread-indexed storage of arbitrary context values. Please
-- don't hate the player!
--
-- @since 0.1.0.0
threadContextStore :: Store (KeyMap Value)
threadContextStore :: Store (KeyMap Value)
threadContextStore =
  IO (Store (KeyMap Value)) -> Store (KeyMap Value)
forall a. IO a -> a
IO.Unsafe.unsafePerformIO
    (IO (Store (KeyMap Value)) -> Store (KeyMap Value))
-> IO (Store (KeyMap Value)) -> Store (KeyMap Value)
forall a b. (a -> b) -> a -> b
$ PropagationStrategy
-> Maybe (KeyMap Value) -> IO (Store (KeyMap Value))
forall (m :: * -> *) ctx.
MonadIO m =>
PropagationStrategy -> Maybe ctx -> m (Store ctx)
Context.newStore PropagationStrategy
Context.noPropagation
    (Maybe (KeyMap Value) -> IO (Store (KeyMap Value)))
-> Maybe (KeyMap Value) -> IO (Store (KeyMap Value))
forall a b. (a -> b) -> a -> b
$ KeyMap Value -> Maybe (KeyMap Value)
forall a. a -> Maybe a
Just
    (KeyMap Value -> Maybe (KeyMap Value))
-> KeyMap Value -> Maybe (KeyMap Value)
forall a b. (a -> b) -> a -> b
$ KeyMap Value
forall v. KeyMap v
emptyKeyMap
{-# NOINLINE threadContextStore #-}

-- | 'OutputOptions' is for use with
-- 'Control.Monad.Logger.Aeson.defaultOutputWith' and enables us to configure
-- the JSON output produced by this library.
--
-- We can get a hold of a value of this type via
-- 'Control.Monad.Logger.Aeson.defaultOutputOptions'.
--
-- @since 0.1.0.0
data OutputOptions = OutputOptions
  { OutputOptions -> LogLevel -> ByteString -> IO ()
outputAction :: LogLevel -> BS8.ByteString -> IO ()
  , -- | Controls whether or not the thread ID is included in each log message's
    -- thread context.
    --
    -- Default: 'False'
    --
    -- @since 0.1.0.0
    OutputOptions -> Bool
outputIncludeThreadId :: Bool
  , -- | Allows for setting a "base" thread context, i.e. a set of 'Pair' that
    -- will always be present in log messages.
    --
    -- If we subsequently use 'Control.Monad.Logger.Aeson.withThreadContext' to
    -- register some thread context for our messages, if any of the keys in
    -- those 'Pair' values overlap with the "base" thread context, then the
    -- overlapped 'Pair' values in the "base" thread context will be overridden
    -- for the duration of the action provided to
    -- 'Control.Monad.Logger.Aeson.withThreadContext'.
    --
    -- Default: 'mempty'
    --
    -- @since 0.1.0.0
    OutputOptions -> [Pair]
outputBaseThreadContext :: [Pair]
  }

defaultLogStrBS
  :: UTCTime
  -> KeyMap Value
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> BS8.ByteString
defaultLogStrBS :: UTCTime
-> KeyMap Value -> Loc -> Text -> LogLevel -> LogStr -> ByteString
defaultLogStrBS UTCTime
now KeyMap Value
threadContext Loc
loc Text
logSource LogLevel
logLevel LogStr
logStr =
  ByteString -> ByteString
LBS.toStrict
    (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ UTCTime
-> KeyMap Value -> Loc -> Text -> LogLevel -> LogStr -> ByteString
defaultLogStrLBS UTCTime
now KeyMap Value
threadContext Loc
loc Text
logSource LogLevel
logLevel LogStr
logStr

defaultLogStrLBS
  :: UTCTime
  -> KeyMap Value
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> LBS8.ByteString
defaultLogStrLBS :: UTCTime
-> KeyMap Value -> Loc -> Text -> LogLevel -> LogStr -> ByteString
defaultLogStrLBS UTCTime
now KeyMap Value
threadContext Loc
loc Text
logSource LogLevel
logLevel LogStr
logStr =
  Encoding -> ByteString
forall a. Encoding' a -> ByteString
Aeson.encodingToLazyByteString (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$ LogItem -> Encoding
logItemEncoding LogItem
logItem
  where
  logItem :: LogItem
  logItem :: LogItem
logItem =
    case Int64 -> ByteString -> ByteString
LBS8.take Int64
9 ByteString
logStrLBS of
      ByteString
"{\"text\":\"" ->
        Encoding -> LogItem
mkLogItem
          (Encoding -> LogItem) -> Encoding -> LogItem
forall a b. (a -> b) -> a -> b
$ Builder -> Encoding
forall a. Builder -> Encoding' a
Aeson.unsafeToEncoding
          (Builder -> Encoding) -> Builder -> Encoding
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
Builder.lazyByteString ByteString
logStrLBS
      ByteString
_ ->
        Encoding -> LogItem
mkLogItem
          (Encoding -> LogItem) -> Encoding -> LogItem
forall a b. (a -> b) -> a -> b
$ Message -> Encoding
messageEncoding
          (Message -> Encoding) -> Message -> Encoding
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeLenient ByteString
logStrLBS Text -> [SeriesElem] -> Message
:# []

  mkLogItem :: Encoding -> LogItem
  mkLogItem :: Encoding -> LogItem
mkLogItem Encoding
messageEnc =
    LogItem
      { logItemTimestamp :: UTCTime
logItemTimestamp = UTCTime
now
      , logItemLoc :: Loc
logItemLoc = Loc
loc
      , logItemLogSource :: Text
logItemLogSource = Text
logSource
      , logItemLevel :: LogLevel
logItemLevel = LogLevel
logLevel
      , logItemThreadContext :: KeyMap Value
logItemThreadContext = KeyMap Value
threadContext
      , logItemMessageEncoding :: Encoding
logItemMessageEncoding = Encoding
messageEnc
      }

  decodeLenient :: ByteString -> Text
decodeLenient =
    OnDecodeError -> ByteString -> Text
Text.Encoding.decodeUtf8With OnDecodeError
Text.Encoding.Error.lenientDecode
      (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict

  logStrLBS :: ByteString
logStrLBS = LogStr -> ByteString
logStrToLBS LogStr
logStr

logStrToLBS :: LogStr -> LBS.ByteString
logStrToLBS :: LogStr -> ByteString
logStrToLBS =
#if MIN_VERSION_fast_logger(3,0,1)
  -- Use (presumably) faster/better conversion if we have new enough fast-logger
  Builder -> ByteString
Builder.toLazyByteString (Builder -> ByteString)
-> (LogStr -> Builder) -> LogStr -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> Builder
unLogStr
   where
    unLogStr :: LogStr -> Builder
unLogStr (LogStr Int
_ Builder
builder) = Builder
builder
#else
  LBS.fromStrict . fromLogStr
#endif

logCS
  :: (MonadLogger m)
  => CallStack
  -> LogSource
  -> LogLevel
  -> Message
  -> m ()
logCS :: forall (m :: * -> *).
MonadLogger m =>
CallStack -> Text -> LogLevel -> Message -> m ()
logCS CallStack
cs Text
logSource LogLevel
logLevel Message
msg =
  Loc -> Text -> LogLevel -> LogStr -> m ()
forall msg. ToLogStr msg => Loc -> Text -> LogLevel -> msg -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog (CallStack -> Loc
locFromCS CallStack
cs) Text
logSource LogLevel
logLevel (LogStr -> m ()) -> LogStr -> m ()
forall a b. (a -> b) -> a -> b
$ Message -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr Message
msg

data LogItem = LogItem
  { LogItem -> UTCTime
logItemTimestamp :: UTCTime
  , LogItem -> Loc
logItemLoc :: Loc
  , LogItem -> Text
logItemLogSource :: LogSource
  , LogItem -> LogLevel
logItemLevel :: LogLevel
  , LogItem -> KeyMap Value
logItemThreadContext :: KeyMap Value
  , LogItem -> Encoding
logItemMessageEncoding :: Encoding
  }

logItemEncoding :: LogItem -> Encoding
logItemEncoding :: LogItem -> Encoding
logItemEncoding LogItem
logItem =
  Series -> Encoding
Aeson.pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$
    (String -> Encoding -> Series
Aeson.pairStr String
"time" (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ UTCTime -> Encoding
forall a. ToJSON a => a -> Encoding
Aeson.toEncoding UTCTime
logItemTimestamp)
      Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> (String -> Encoding -> Series
Aeson.pairStr String
"level" (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ LogLevel -> Encoding
levelEncoding LogLevel
logItemLevel)
      Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> ( if Loc -> Bool
isDefaultLoc Loc
logItemLoc then
             Series
forall a. Monoid a => a
mempty
           else
             String -> Encoding -> Series
Aeson.pairStr String
"location" (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ Loc -> Encoding
locEncoding Loc
logItemLoc
         )
      Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> ( if Text -> Bool
Text.null Text
logItemLogSource then
             Series
forall a. Monoid a => a
mempty
           else
             String -> Encoding -> Series
Aeson.pairStr String
"source" (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ Text -> Encoding
forall a. ToJSON a => a -> Encoding
Aeson.toEncoding Text
logItemLogSource
         )
      Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> ( if KeyMap Value -> Bool
forall a. KeyMap a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null KeyMap Value
logItemThreadContext then
             Series
forall a. Monoid a => a
mempty
           else
             String -> Encoding -> Series
Aeson.pairStr String
"context" (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ KeyMap Value -> Encoding
forall a. ToJSON a => a -> Encoding
Aeson.toEncoding KeyMap Value
logItemThreadContext
         )
      Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> (String -> Encoding -> Series
Aeson.pairStr String
"message" Encoding
logItemMessageEncoding)
  where
  LogItem
    { UTCTime
logItemTimestamp :: LogItem -> UTCTime
logItemTimestamp :: UTCTime
logItemTimestamp
    , Loc
logItemLoc :: LogItem -> Loc
logItemLoc :: Loc
logItemLoc
    , Text
logItemLogSource :: LogItem -> Text
logItemLogSource :: Text
logItemLogSource
    , LogLevel
logItemLevel :: LogItem -> LogLevel
logItemLevel :: LogLevel
logItemLevel
    , KeyMap Value
logItemThreadContext :: LogItem -> KeyMap Value
logItemThreadContext :: KeyMap Value
logItemThreadContext
    , Encoding
logItemMessageEncoding :: LogItem -> Encoding
logItemMessageEncoding :: Encoding
logItemMessageEncoding
    } = LogItem
logItem

messageEncoding :: Message -> Encoding
messageEncoding :: Message -> Encoding
messageEncoding  = Series -> Encoding
Aeson.pairs (Series -> Encoding) -> (Message -> Series) -> Message -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Series
messageSeries

messageSeries :: Message -> Series
messageSeries :: Message -> Series
messageSeries Message
message =
  Key
"text" Key -> Text -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
messageText
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> ( if [SeriesElem] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SeriesElem]
messageMeta then
           Series
forall a. Monoid a => a
mempty
         else
           String -> Encoding -> Series
Aeson.pairStr String
"meta" (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ Series -> Encoding
Aeson.pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ (SeriesElem -> Series) -> [SeriesElem] -> Series
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap SeriesElem -> Series
unSeriesElem [SeriesElem]
messageMeta
       )
  where
  Text
messageText :# [SeriesElem]
messageMeta = Message
message

pairsEncoding :: [Pair] -> Encoding
pairsEncoding :: [Pair] -> Encoding
pairsEncoding = Series -> Encoding
Aeson.pairs (Series -> Encoding) -> ([Pair] -> Series) -> [Pair] -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> Series
pairsSeries

pairsSeries :: [Pair] -> Series
pairsSeries :: [Pair] -> Series
pairsSeries = [Series] -> Series
forall a. Monoid a => [a] -> a
mconcat ([Series] -> Series) -> ([Pair] -> [Series]) -> [Pair] -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pair -> Series) -> [Pair] -> [Series]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Key -> Value -> Series) -> Pair -> Series
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key -> Value -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
(.=))

levelEncoding :: LogLevel -> Encoding
levelEncoding :: LogLevel -> Encoding
levelEncoding = Text -> Encoding
forall a. Text -> Encoding' a
Aeson.text (Text -> Encoding) -> (LogLevel -> Text) -> LogLevel -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogLevel -> Text
logLevelToText

logLevelToText :: LogLevel -> Text
logLevelToText :: LogLevel -> Text
logLevelToText = \case
  LogLevel
LevelDebug -> Text
"debug"
  LogLevel
LevelInfo -> Text
"info"
  LogLevel
LevelWarn -> Text
"warn"
  LogLevel
LevelError -> Text
"error"
  LevelOther Text
otherLevel -> Text
otherLevel

locEncoding :: Loc -> Encoding
locEncoding :: Loc -> Encoding
locEncoding Loc
loc =
  Series -> Encoding
Aeson.pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$
    (String -> Encoding -> Series
Aeson.pairStr String
"package" (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ String -> Encoding
forall a. String -> Encoding' a
Aeson.string String
loc_package)
      Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> (String -> Encoding -> Series
Aeson.pairStr String
"module" (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ String -> Encoding
forall a. String -> Encoding' a
Aeson.string String
loc_module)
      Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> (String -> Encoding -> Series
Aeson.pairStr String
"file" (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ String -> Encoding
forall a. String -> Encoding' a
Aeson.string String
loc_filename)
      Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> (String -> Encoding -> Series
Aeson.pairStr String
"line" (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ Int -> Encoding
Aeson.int (Int -> Encoding) -> Int -> Encoding
forall a b. (a -> b) -> a -> b
$ CharPos -> Int
forall a b. (a, b) -> a
fst CharPos
loc_start)
      Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> (String -> Encoding -> Series
Aeson.pairStr String
"char" (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ Int -> Encoding
Aeson.int (Int -> Encoding) -> Int -> Encoding
forall a b. (a -> b) -> a -> b
$ CharPos -> Int
forall a b. (a, b) -> b
snd CharPos
loc_start)
  where
  Loc { String
loc_filename :: Loc -> String
loc_filename :: String
loc_filename, String
loc_package :: Loc -> String
loc_package :: String
loc_package, String
loc_module :: Loc -> String
loc_module :: String
loc_module, CharPos
loc_start :: Loc -> CharPos
loc_start :: CharPos
loc_start } = Loc
loc

-- | Not exported from 'monad-logger', so copied here.
mkLoggerLoc :: SrcLoc -> Loc
mkLoggerLoc :: SrcLoc -> Loc
mkLoggerLoc SrcLoc
loc =
  Loc { loc_filename :: String
loc_filename = SrcLoc -> String
srcLocFile SrcLoc
loc
      , loc_package :: String
loc_package  = SrcLoc -> String
srcLocPackage SrcLoc
loc
      , loc_module :: String
loc_module   = SrcLoc -> String
srcLocModule SrcLoc
loc
      , loc_start :: CharPos
loc_start    = ( SrcLoc -> Int
srcLocStartLine SrcLoc
loc
                       , SrcLoc -> Int
srcLocStartCol SrcLoc
loc)
      , loc_end :: CharPos
loc_end      = ( SrcLoc -> Int
srcLocEndLine SrcLoc
loc
                       , SrcLoc -> Int
srcLocEndCol SrcLoc
loc)
      }

-- | Not exported from 'monad-logger', so copied here.
locFromCS :: CallStack -> Loc
locFromCS :: CallStack -> Loc
locFromCS CallStack
cs = case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs of
                 ((String
_, SrcLoc
loc):[(String, SrcLoc)]
_) -> SrcLoc -> Loc
mkLoggerLoc SrcLoc
loc
                 [(String, SrcLoc)]
_            -> Loc
Logger.defaultLoc

-- | Not exported from 'monad-logger', so copied here.
isDefaultLoc :: Loc -> Bool
isDefaultLoc :: Loc -> Bool
isDefaultLoc (Loc String
"<unknown>" String
"<unknown>" String
"<unknown>" (Int
0,Int
0) (Int
0,Int
0)) = Bool
True
isDefaultLoc Loc
_ = Bool
False

-- $disclaimer
--
-- In general, changes to this module will not be reflected in the library's
-- version updates. Direct use of this module should be done with care.