{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}

{- |
Copyright:  (c) 2018-2022 Kowainik, 2023 Co-Log
SPDX-License-Identifier: MPL-2.0

This module contains logging messages data types along with the formatting and
logging actions for them.
-}

module Colog.Message
       ( -- * Simple message type
         -- ** Type
         SimpleMsg (..)
         -- ** Logging
       , logText
         -- ** Formatting
       , fmtSimpleMessage
       , formatWith

         -- * Core messaging
         -- ** Types
       , Msg (..)
       , Message
         -- ** Logging
       , log
       , logDebug
       , logInfo
       , logWarning
       , logError
       , logException
         -- ** Formatting
       , fmtMessage
       , showSeverity
       , showSourceLoc
       , showTime
       , showTimeOffset
       , showThreadId

         -- * Externally extensible message type
         -- ** Field of the dependent map
       , FieldType
       , MessageField (..)
       , unMessageField
       , extractField
         -- ** Dependent map that allows to extend logging message
       , FieldMap
       , defaultFieldMap

         -- ** Extensible message
       , RichMessage
       , RichMsg (..)
       , fmtRichMessageDefault
       , fmtSimpleRichMessageDefault
       , fmtRichMessageCustomDefault
       , upgradeMessageAction
       ) where

import Prelude hiding (lookup, log)

import Control.Concurrent (ThreadId, myThreadId)
import Control.Exception (Exception, displayException)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Dependent.Map (DMap, fromList, lookup)
import Data.Dependent.Sum (DSum ((:=>)))
import Data.Kind (Type)
import Data.Text (Text)
import Data.Text.Lazy (toStrict)
import GHC.Stack (CallStack, SrcLoc (..), callStack, getCallStack, withFrozenCallStack)
import GHC.TypeLits (Symbol)
import System.Console.ANSI (Color (..), ColorIntensity (Vivid), ConsoleLayer (Foreground), SGR (..),
                            setSGRCode)
import Type.Reflection (TypeRep, typeRep)

import Colog.Core (LogAction, Severity (..), cmap)
import Colog.Monad (WithLog, logMsg)

import qualified Chronos as C
import qualified Chronos.Locale.English as C
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as TB
import qualified Data.Text.Lazy.Builder.Int as TB
import qualified Data.Vector as Vector

----------------------------------------------------------------------------
-- Plain message
----------------------------------------------------------------------------

{- | General logging message data type. Contains the following fields:

1. Polymorphic severity. This can be anything you want if you need more
flexibility.
2. Function 'CallStack'. It provides useful information about source code
locations where each particular function was called.
3. Custom text for logging.
-}
data Msg sev = Msg
    { forall sev. Msg sev -> sev
msgSeverity :: !sev
    , forall sev. Msg sev -> CallStack
msgStack    :: !CallStack
    , forall sev. Msg sev -> Text
msgText     ::  Text
    }

{- | Message data type without 'Severity'. Use 'logText' to log
messages of this type.

@since 0.4.0.0
-}
data SimpleMsg = SimpleMsg
    { SimpleMsg -> CallStack
simpleMsgStack :: !CallStack
    , SimpleMsg -> Text
simpleMsgText  :: !Text
    }

{- | 'Msg' parametrized by the 'Severity' type. Most formatting functions in
this module work with 'Severity' from @co-log-core@.
-}
type Message = Msg Severity

-- | Logs the message with given severity @sev@.
log :: WithLog env (Msg sev) m => sev -> Text -> m ()
log :: forall env sev (m :: * -> *).
WithLog env (Msg sev) m =>
sev -> Text -> m ()
log sev
msgSeverity Text
msgText =
    forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (forall msg env (m :: * -> *). WithLog env msg m => msg -> m ()
logMsg Msg{ msgStack :: CallStack
msgStack = HasCallStack => CallStack
callStack, sev
Text
msgText :: Text
msgSeverity :: sev
msgText :: Text
msgSeverity :: sev
.. })

-- | Logs the message with the 'Debug' severity.
logDebug :: WithLog env Message m => Text -> m ()
logDebug :: forall env (m :: * -> *). WithLog env Message m => Text -> m ()
logDebug = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (forall env sev (m :: * -> *).
WithLog env (Msg sev) m =>
sev -> Text -> m ()
log Severity
Debug)

-- | Logs the message with the 'Info' severity.
logInfo :: WithLog env Message m => Text -> m ()
logInfo :: forall env (m :: * -> *). WithLog env Message m => Text -> m ()
logInfo = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (forall env sev (m :: * -> *).
WithLog env (Msg sev) m =>
sev -> Text -> m ()
log Severity
Info)

-- | Logs the message with the 'Warning' severity.
logWarning :: WithLog env Message m => Text -> m ()
logWarning :: forall env (m :: * -> *). WithLog env Message m => Text -> m ()
logWarning = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (forall env sev (m :: * -> *).
WithLog env (Msg sev) m =>
sev -> Text -> m ()
log Severity
Warning)

-- | Logs the message with the 'Error' severity.
logError :: WithLog env Message m => Text -> m ()
logError :: forall env (m :: * -> *). WithLog env Message m => Text -> m ()
logError = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (forall env sev (m :: * -> *).
WithLog env (Msg sev) m =>
sev -> Text -> m ()
log Severity
Error)

-- | Logs 'Exception' message with the 'Error' severity.
logException :: forall e m env . (WithLog env Message m, Exception e) => e -> m ()
logException :: forall e (m :: * -> *) env.
(WithLog env Message m, Exception e) =>
e -> m ()
logException = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (forall env (m :: * -> *). WithLog env Message m => Text -> m ()
logError forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> String
displayException)

{- | Logs 'SimpleMsg' without severity, only 'CallStack' and 'Text'
body message.

@since 0.4.0.0
-}
logText :: WithLog env SimpleMsg m => Text -> m ()
logText :: forall env (m :: * -> *). WithLog env SimpleMsg m => Text -> m ()
logText Text
msgText = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (forall msg env (m :: * -> *). WithLog env msg m => msg -> m ()
logMsg SimpleMsg{ simpleMsgStack :: CallStack
simpleMsgStack = HasCallStack => CallStack
callStack, simpleMsgText :: Text
simpleMsgText = Text
msgText })

{- | Formats the 'Message' type according to the following format:

@
[Severity] [SourceLocation] \<Text message\>
@

__Examples:__

@
[Warning] [Main.app#39] Starting application...
[Debug]   [Main.example#34] app: First message...
@

See 'fmtRichMessageDefault' for a richer format.
-}
fmtMessage :: Message -> Text
fmtMessage :: Message -> Text
fmtMessage Msg{CallStack
Text
Severity
msgText :: Text
msgStack :: CallStack
msgSeverity :: Severity
msgText :: forall sev. Msg sev -> Text
msgStack :: forall sev. Msg sev -> CallStack
msgSeverity :: forall sev. Msg sev -> sev
..} =
    Severity -> Text
showSeverity Severity
msgSeverity
    forall a. Semigroup a => a -> a -> a
<> CallStack -> Text
showSourceLoc CallStack
msgStack
    forall a. Semigroup a => a -> a -> a
<> Text
msgText

{- | Formats the 'SimpleMsg' type in according to the following format:

@
[SourceLocation] \<Text message\>
@

__Examples:__

@
[Main.app#39] Starting application...
[Main.example#34] app: First message...
@

See 'fmtSimpleRichMessageDefault' for richer format.

@since 0.4.0.0
-}
fmtSimpleMessage :: SimpleMsg -> Text
fmtSimpleMessage :: SimpleMsg -> Text
fmtSimpleMessage SimpleMsg{CallStack
Text
simpleMsgText :: Text
simpleMsgStack :: CallStack
simpleMsgText :: SimpleMsg -> Text
simpleMsgStack :: SimpleMsg -> CallStack
..} = CallStack -> Text
showSourceLoc CallStack
simpleMsgStack forall a. Semigroup a => a -> a -> a
<> Text
simpleMsgText

{- | Alias for 'cmap' specialized for formatting purposes. If you have
an action that can output 'Text' (for example
'Colog.Actions.logTextStdout'), you can convert it to the action that
can print 'SimpleMsg' or 'Message':

@
logSimpleMsgStdout :: 'LogAction' 'IO' 'SimpleMsg'
logSimpleMsgStdout = 'formatWith' 'fmtSimpleMessage' 'Colog.Actions.logTextStdout'

logMessageStdout :: 'LogAction' 'IO' 'Message'
logMessageStdout = 'formatWith' 'fmtMessage' 'Colog.Actions.logTextStdout'
@

@since 0.4.0.0
-}
formatWith :: (msg -> Text) -> LogAction m Text -> LogAction m msg
formatWith :: forall msg (m :: * -> *).
(msg -> Text) -> LogAction m Text -> LogAction m msg
formatWith = forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
cmap
{-# INLINE formatWith #-}

{- | Formats severity in different colours with alignment.
-}
showSeverity :: Severity -> Text
showSeverity :: Severity -> Text
showSeverity = \case
    Severity
Debug   -> Color -> Text -> Text
color Color
Green  Text
"[Debug]   "
    Severity
Info    -> Color -> Text -> Text
color Color
Blue   Text
"[Info]    "
    Severity
Warning -> Color -> Text -> Text
color Color
Yellow Text
"[Warning] "
    Severity
Error   -> Color -> Text -> Text
color Color
Red    Text
"[Error]   "
 where
    color :: Color -> Text -> Text
    color :: Color -> Text -> Text
color Color
c Text
txt =
        String -> Text
T.pack ([SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
c])
        forall a. Semigroup a => a -> a -> a
<> Text
txt
        forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([SGR] -> String
setSGRCode [SGR
Reset])

square :: Text -> Text
square :: Text -> Text
square Text
t = Text
"[" forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
"] "

{- | Shows source code locations in the following format:

@
[Main.example#35]
@
-}
showSourceLoc :: CallStack -> Text
showSourceLoc :: CallStack -> Text
showSourceLoc CallStack
cs = Text -> Text
square Text
showCallStack
  where
    showCallStack :: Text
    showCallStack :: Text
showCallStack = case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs of
        []                             -> Text
"<unknown loc>"
        [(String
name, SrcLoc
loc)]                  -> String -> SrcLoc -> Text
showLoc String
name SrcLoc
loc
        (String
_, SrcLoc
loc) : (String
callerName, SrcLoc
_) : [(String, SrcLoc)]
_ -> String -> SrcLoc -> Text
showLoc String
callerName SrcLoc
loc

    showLoc :: String -> SrcLoc -> Text
    showLoc :: String -> SrcLoc -> Text
showLoc String
name SrcLoc{Int
String
srcLocEndCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocFile :: SrcLoc -> String
srcLocModule :: SrcLoc -> String
srcLocPackage :: SrcLoc -> String
srcLocStartCol :: SrcLoc -> Int
srcLocStartLine :: SrcLoc -> Int
srcLocEndCol :: Int
srcLocEndLine :: Int
srcLocStartCol :: Int
srcLocStartLine :: Int
srcLocFile :: String
srcLocModule :: String
srcLocPackage :: String
..} =
        String -> Text
T.pack String
srcLocModule forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
name forall a. Semigroup a => a -> a -> a
<> Text
"#" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Int
srcLocStartLine)

----------------------------------------------------------------------------
-- Externally extensible message
----------------------------------------------------------------------------

{- | Open type family that maps some user defined tags (type names) to actual
types. The type family is open so you can add new instances.
-}
type family FieldType (fieldName :: Symbol) :: Type
type instance FieldType "threadId"  = ThreadId
type instance FieldType "posixTime" = C.Time

{- | @newtype@ wrapper. Stores monadic ability to extract value of 'FieldType'.

__Implementation detail:__ this exotic writing of 'MessageField' is required in
order to use it nicer with type applications. So users can write

@
MessageField @"threadId" myThreadId
@

instead of

@
MessageField @_ @"threadId" myThreadId
@

Simpler version of this @newtype@:

@
newtype MessageField m fieldName = MessageField
    { unMesssageField :: m (FieldType fieldName)
    }
@
-}
newtype MessageField (m :: Type -> Type) (fieldName :: Symbol) where
    MessageField :: forall fieldName m . m (FieldType fieldName) -> MessageField m fieldName

-- | Extracts field from the 'MessageField' constructor.
unMessageField :: forall fieldName m . MessageField m fieldName -> m (FieldType fieldName)
unMessageField :: forall (fieldName :: Symbol) (m :: * -> *).
MessageField m fieldName -> m (FieldType fieldName)
unMessageField (MessageField m (FieldType fieldName)
f) = m (FieldType fieldName)
f
{-# INLINE unMessageField #-}

-- | Helper function to deal with 'MessageField' when looking it up in the 'FieldMap'.
extractField
    :: Applicative m
    => Maybe (MessageField m fieldName)
    -> m (Maybe (FieldType fieldName))
extractField :: forall (m :: * -> *) (fieldName :: Symbol).
Applicative m =>
Maybe (MessageField m fieldName) -> m (Maybe (FieldType fieldName))
extractField = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (fieldName :: Symbol) (m :: * -> *).
MessageField m fieldName -> m (FieldType fieldName)
unMessageField
{-# INLINE extractField #-}

-- same as:
-- extractField = \case
--    Nothing -> pure Nothing
--    Just (MessageField field) -> Just <$> field

{- | Depedent map from type level strings to the corresponding types. See
'FieldType' for mapping between names and types.
-}
type FieldMap m = DMap TypeRep (MessageField m)

{- | Default message map that contains actions to extract 'ThreadId' and
'C.Time'. Basically, the following mapping:

@
"threadId"  -> 'myThreadId'
"posixTime" -> 'C.now'
@
-}
defaultFieldMap :: MonadIO m => FieldMap m
defaultFieldMap :: forall (m :: * -> *). MonadIO m => FieldMap m
defaultFieldMap = forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
[DSum k2 f] -> DMap k2 f
fromList
    [ forall {k} (a :: k). Typeable a => TypeRep a
typeRep @"threadId"  forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> forall (fieldName :: Symbol) (m :: * -> *).
m (FieldType fieldName) -> MessageField m fieldName
MessageField (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ThreadId
myThreadId)
    , forall {k} (a :: k). Typeable a => TypeRep a
typeRep @"posixTime" forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> forall (fieldName :: Symbol) (m :: * -> *).
m (FieldType fieldName) -> MessageField m fieldName
MessageField (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Time
C.now)
    ]

{- | Contains additional data to 'Message' to display more verbose information.

@since 0.4.0.0
-}
data RichMsg (m :: Type -> Type) (msg :: Type) = RichMsg
    { forall (m :: * -> *) msg. RichMsg m msg -> msg
richMsgMsg :: !msg
    , forall (m :: * -> *) msg. RichMsg m msg -> FieldMap m
richMsgMap :: {-# UNPACK #-} !(FieldMap m)
    } deriving stock (forall a b. a -> RichMsg m b -> RichMsg m a
forall a b. (a -> b) -> RichMsg m a -> RichMsg m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) a b. a -> RichMsg m b -> RichMsg m a
forall (m :: * -> *) a b. (a -> b) -> RichMsg m a -> RichMsg m b
<$ :: forall a b. a -> RichMsg m b -> RichMsg m a
$c<$ :: forall (m :: * -> *) a b. a -> RichMsg m b -> RichMsg m a
fmap :: forall a b. (a -> b) -> RichMsg m a -> RichMsg m b
$cfmap :: forall (m :: * -> *) a b. (a -> b) -> RichMsg m a -> RichMsg m b
Functor)

-- | Specialised version of 'RichMsg' that stores severity, callstack and text message.
type RichMessage m = RichMsg m Message

{- | Formats 'RichMessage' in the following way:

@
[Severity] [Time] [SourceLocation] [ThreadId] \<Text message\>
@

__Examples:__

@
[Debug]   [03 May 2019 05:23:19.058 +00:00] [Main.example#34] [ThreadId 11] app: First message...
[Info]    [03 May 2019 05:23:19.059 +00:00] [Main.example#35] [ThreadId 11] app: Second message...
@

See 'fmtMessage' if you don't need both time and thread ID.
-}
fmtRichMessageDefault :: MonadIO m => RichMessage m -> m Text
fmtRichMessageDefault :: forall (m :: * -> *). MonadIO m => RichMessage m -> m Text
fmtRichMessageDefault RichMessage m
msg = forall (m :: * -> *) msg.
MonadIO m =>
RichMsg m msg
-> (Maybe ThreadId -> Maybe Time -> msg -> Text) -> m Text
fmtRichMessageCustomDefault RichMessage m
msg Maybe ThreadId -> Maybe Time -> Message -> Text
formatRichMessage
  where
    formatRichMessage :: Maybe ThreadId -> Maybe C.Time -> Message -> Text
    formatRichMessage :: Maybe ThreadId -> Maybe Time -> Message -> Text
formatRichMessage (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ThreadId -> Text
showThreadId -> Text
thread) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Time -> Text
showTime -> Text
time) Msg{CallStack
Text
Severity
msgText :: Text
msgStack :: CallStack
msgSeverity :: Severity
msgText :: forall sev. Msg sev -> Text
msgStack :: forall sev. Msg sev -> CallStack
msgSeverity :: forall sev. Msg sev -> sev
..} =
        Severity -> Text
showSeverity Severity
msgSeverity
     forall a. Semigroup a => a -> a -> a
<> Text
time
     forall a. Semigroup a => a -> a -> a
<> CallStack -> Text
showSourceLoc CallStack
msgStack
     forall a. Semigroup a => a -> a -> a
<> Text
thread
     forall a. Semigroup a => a -> a -> a
<> Text
msgText

{- | Formats 'RichMessage' in the following way:

@
[Time] [SourceLocation] [ThreadId] \<Text message\>
@

__Examples:__

@
[03 May 2019 05:23:19.058 +00:00] [Main.example#34] [ThreadId 11] app: First message...
[03 May 2019 05:23:19.059 +00:00] [Main.example#35] [ThreadId 11] app: Second message...
@

Practically, it formats a message as 'fmtRichMessageDefault' without the severity information.

@since 0.4.0.0
-}
fmtSimpleRichMessageDefault :: MonadIO m => RichMsg m SimpleMsg -> m Text
fmtSimpleRichMessageDefault :: forall (m :: * -> *). MonadIO m => RichMsg m SimpleMsg -> m Text
fmtSimpleRichMessageDefault RichMsg m SimpleMsg
msg = forall (m :: * -> *) msg.
MonadIO m =>
RichMsg m msg
-> (Maybe ThreadId -> Maybe Time -> msg -> Text) -> m Text
fmtRichMessageCustomDefault RichMsg m SimpleMsg
msg Maybe ThreadId -> Maybe Time -> SimpleMsg -> Text
formatRichMessage
  where
    formatRichMessage :: Maybe ThreadId -> Maybe C.Time -> SimpleMsg -> Text
    formatRichMessage :: Maybe ThreadId -> Maybe Time -> SimpleMsg -> Text
formatRichMessage (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ThreadId -> Text
showThreadId -> Text
thread) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Time -> Text
showTime -> Text
time) SimpleMsg{CallStack
Text
simpleMsgText :: Text
simpleMsgStack :: CallStack
simpleMsgText :: SimpleMsg -> Text
simpleMsgStack :: SimpleMsg -> CallStack
..} =
        Text
time
     forall a. Semigroup a => a -> a -> a
<> CallStack -> Text
showSourceLoc CallStack
simpleMsgStack
     forall a. Semigroup a => a -> a -> a
<> Text
thread
     forall a. Semigroup a => a -> a -> a
<> Text
simpleMsgText
{- | Custom formatting function for 'RichMsg'. It extracts 'ThreadId'
and 'C.Time' from fields and allows you to specify how to format them.

@since 0.4.0.0
-}
fmtRichMessageCustomDefault
    :: MonadIO m
    => RichMsg m msg
    -> (Maybe ThreadId -> Maybe C.Time -> msg -> Text)
    -> m Text
fmtRichMessageCustomDefault :: forall (m :: * -> *) msg.
MonadIO m =>
RichMsg m msg
-> (Maybe ThreadId -> Maybe Time -> msg -> Text) -> m Text
fmtRichMessageCustomDefault RichMsg{msg
FieldMap m
richMsgMap :: FieldMap m
richMsgMsg :: msg
richMsgMap :: forall (m :: * -> *) msg. RichMsg m msg -> FieldMap m
richMsgMsg :: forall (m :: * -> *) msg. RichMsg m msg -> msg
..} Maybe ThreadId -> Maybe Time -> msg -> Text
formatter = do
    Maybe ThreadId
maybeThreadId  <- forall (m :: * -> *) (fieldName :: Symbol).
Applicative m =>
Maybe (MessageField m fieldName) -> m (Maybe (FieldType fieldName))
extractField forall a b. (a -> b) -> a -> b
$ forall {k1} (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
lookup (forall {k} (a :: k). Typeable a => TypeRep a
typeRep @"threadId")  FieldMap m
richMsgMap
    Maybe Time
maybePosixTime <- forall (m :: * -> *) (fieldName :: Symbol).
Applicative m =>
Maybe (MessageField m fieldName) -> m (Maybe (FieldType fieldName))
extractField forall a b. (a -> b) -> a -> b
$ forall {k1} (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
lookup (forall {k} (a :: k). Typeable a => TypeRep a
typeRep @"posixTime") FieldMap m
richMsgMap
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe ThreadId -> Maybe Time -> msg -> Text
formatter Maybe ThreadId
maybeThreadId Maybe Time
maybePosixTime msg
richMsgMsg

{- | Shows time in the following format:

>>> showTime $ C.Time 1577656800000000000
"[29 Dec 2019 22:00:00.000 +00:00] "
-}
showTime :: C.Time -> Text
showTime :: Time -> Text
showTime Time
t =
    Text -> Text
square
    forall a b. (a -> b) -> a -> b
$ Text -> Text
toStrict
    forall a b. (a -> b) -> a -> b
$ Builder -> Text
TB.toLazyText
    forall a b. (a -> b) -> a -> b
$ OffsetDatetime -> Builder
builderDmyHMSz (Offset -> Time -> OffsetDatetime
C.timeToOffsetDatetime (Int -> Offset
C.Offset Int
0) Time
t)

{- | Shows time in the following format:

>>> showTimeOffset $ C.timeToOffsetDatetime (C.Offset $ -120) $ C.Time 1577656800000000000
"[29 Dec 2019 20:00:00.000 -02:00] "
-}
showTimeOffset :: C.OffsetDatetime -> Text
showTimeOffset :: OffsetDatetime -> Text
showTimeOffset = Text -> Text
square forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TB.toLazyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. OffsetDatetime -> Builder
builderDmyHMSz

----------------------------------------------------------------------------
-- Chronos extra
----------------------------------------------------------------------------

{- | Given a 'OffsetDatetime', constructs a 'Text' 'TB.Builder' corresponding to a
Day\/Month\/Year,Hour\/Minute\/Second\/Offset encoding of the given 'OffsetDatetime'.

Example: @29 Dec 2019 22:00:00.000 +00:00@
-}
builderDmyHMSz :: C.OffsetDatetime -> TB.Builder
builderDmyHMSz :: OffsetDatetime -> Builder
builderDmyHMSz (C.OffsetDatetime (C.Datetime Date
date TimeOfDay
time) Offset
offset) =
       Date -> Builder
builderDmy Date
date
    forall a. Semigroup a => a -> a -> a
<> Builder
spaceSep
    forall a. Semigroup a => a -> a -> a
<> SubsecondPrecision -> Maybe Char -> TimeOfDay -> Builder
C.builder_HMS (Int -> SubsecondPrecision
C.SubsecondPrecisionFixed Int
3) (forall a. a -> Maybe a
Just Char
':') TimeOfDay
time
    forall a. Semigroup a => a -> a -> a
<> Builder
spaceSep
    forall a. Semigroup a => a -> a -> a
<> OffsetFormat -> Offset -> Builder
C.builderOffset OffsetFormat
C.OffsetFormatColonOn Offset
offset
  where
    spaceSep :: TB.Builder
    spaceSep :: Builder
spaceSep = Char -> Builder
TB.singleton Char
' '

    {- Given a 'Date' construct a 'Text' 'TB.Builder'
    corresponding to a Day\/Month\/Year encoding.

    Example: @01 Jan 2020@
    -}
    builderDmy :: C.Date -> TB.Builder
    builderDmy :: Date -> Builder
builderDmy (C.Date (C.Year Int
y) Month
m DayOfMonth
d) =
           DayOfMonth -> Builder
zeroPadDayOfMonth DayOfMonth
d
        forall a. Semigroup a => a -> a -> a
<> Builder
spaceSep
        forall a. Semigroup a => a -> a -> a
<> Text -> Builder
TB.fromText (forall a. MonthMatch a -> Month -> a
C.caseMonth MonthMatch Text
C.abbreviated Month
m)
        forall a. Semigroup a => a -> a -> a
<> Builder
spaceSep
        forall a. Semigroup a => a -> a -> a
<> forall a. Integral a => a -> Builder
TB.decimal Int
y


    zeroPadDayOfMonth :: C.DayOfMonth -> TB.Builder
    zeroPadDayOfMonth :: DayOfMonth -> Builder
zeroPadDayOfMonth (C.DayOfMonth Int
d) =
        if Int
d forall a. Ord a => a -> a -> Bool
< Int
100
        then forall a. Vector a -> Int -> a
Vector.unsafeIndex Vector Builder
twoDigitTextBuilder Int
d
        else forall a. Integral a => a -> Builder
TB.decimal Int
d

    twoDigitTextBuilder :: Vector.Vector TB.Builder
    twoDigitTextBuilder :: Vector Builder
twoDigitTextBuilder = forall a. [a] -> Vector a
Vector.fromList forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (Text -> Builder
TB.fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) [String]
twoDigitStrings
    {-# NOINLINE twoDigitTextBuilder #-}

    twoDigitStrings :: [String]
    twoDigitStrings :: [String]
twoDigitStrings =
        [ String
"00",String
"01",String
"02",String
"03",String
"04",String
"05",String
"06",String
"07",String
"08",String
"09"
        , String
"10",String
"11",String
"12",String
"13",String
"14",String
"15",String
"16",String
"17",String
"18",String
"19"
        , String
"20",String
"21",String
"22",String
"23",String
"24",String
"25",String
"26",String
"27",String
"28",String
"29"
        , String
"30",String
"31",String
"32",String
"33",String
"34",String
"35",String
"36",String
"37",String
"38",String
"39"
        , String
"40",String
"41",String
"42",String
"43",String
"44",String
"45",String
"46",String
"47",String
"48",String
"49"
        , String
"50",String
"51",String
"52",String
"53",String
"54",String
"55",String
"56",String
"57",String
"58",String
"59"
        , String
"60",String
"61",String
"62",String
"63",String
"64",String
"65",String
"66",String
"67",String
"68",String
"69"
        , String
"70",String
"71",String
"72",String
"73",String
"74",String
"75",String
"76",String
"77",String
"78",String
"79"
        , String
"80",String
"81",String
"82",String
"83",String
"84",String
"85",String
"86",String
"87",String
"88",String
"89"
        , String
"90",String
"91",String
"92",String
"93",String
"94",String
"95",String
"96",String
"97",String
"98",String
"99"
        ]

----------------------------------------------------------------------------
-- Utility functions
----------------------------------------------------------------------------

{- | Shows a thread id in the following format:

__>>__ showThreadId <$> Control.Concurrent.myThreadId
"[ThreadId 4898] "
-}
showThreadId :: ThreadId -> Text
showThreadId :: ThreadId -> Text
showThreadId = Text -> Text
square forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

{- | Allows to extend basic 'Message' type with given dependent map of fields.
-}
upgradeMessageAction
    :: forall m msg .
       FieldMap m
    -> LogAction m (RichMsg m msg)
    -> LogAction m msg
upgradeMessageAction :: forall (m :: * -> *) msg.
FieldMap m -> LogAction m (RichMsg m msg) -> LogAction m msg
upgradeMessageAction FieldMap m
fieldMap = forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
cmap msg -> RichMsg m msg
addMap
  where
    addMap :: msg -> RichMsg m msg
    addMap :: msg -> RichMsg m msg
addMap msg
msg = forall (m :: * -> *) msg. msg -> FieldMap m -> RichMsg m msg
RichMsg msg
msg FieldMap m
fieldMap