{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE LambdaCase #-}

-- | Helpers for the log messages
module MatrixBot.Log
     ( withLogger
     , logDebug
     , logInfo
     , logWarn
     , logError
     , Logger (..)
     , HasLogger (..)
     , defaultMonadLoggerLog
     , LogStateHandle -- Do not export the constructor
     , createLogState
     , setLogLevel
     , forceLogInitialization
     ) where

import GHC.Stack (HasCallStack, withFrozenCallStack, callStack)
import Prelude hiding (map)
import Data.Char (toUpper)
import Data.Text (Text, pack, map)
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Clock
import Data.Time.Format.ISO8601 (iso8601Show)
import Control.Concurrent (myThreadId)
import Control.Lens (Lens', view)
import Control.Monad.IO.Class
import qualified Control.Monad.Logger as ML
import qualified Control.Monad.Reader as MR
import qualified UnliftIO as UIO
import qualified System.Log.FastLogger as FL
import qualified Data.Sequence as Seq
import qualified UnliftIO.IORef as IORef


withLogger ∷ UIO.MonadUnliftIO m ⇒ LogStateHandle → (Logger → m a) → m a
withLogger :: forall (m :: * -> *) a.
MonadUnliftIO m =>
LogStateHandle -> (Logger -> m a) -> m a
withLogger LogStateHandle
logStateHandle Logger -> m a
m =
  ((forall a. m a -> IO a) -> IO a) -> m a
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
UIO.withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO →
    ((Text -> IO ()) -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
((Text -> m ()) -> m a) -> m a
withFastLogger (((Text -> IO ()) -> IO a) -> IO a)
-> ((Text -> IO ()) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Text -> IO ()
writeMsg →
      let
        loggerF :: Loc -> LogLevel -> Text -> m ()
loggerF Loc
location LogLevel
logLevel Text
msg = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          LogTime
t ← IO LogTime
forall (m :: * -> *). MonadIO m => m LogTime
getTimeForLog
          ThreadId
tid ← Text -> ThreadId
ThreadId (Text -> ThreadId) -> (ThreadId -> Text) -> ThreadId -> ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text) -> (ThreadId -> String) -> ThreadId -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> String
forall a. Show a => a -> String
show (ThreadId -> ThreadId) -> IO ThreadId -> IO ThreadId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ThreadId -> IO ThreadId
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ThreadId
myThreadId
          let logMessage :: (LogTime, LogLevel, Loc, ThreadId, Text)
logMessage = (LogTime
t, LogLevel
logLevel, Loc
location, ThreadId
tid, Text
msg)

          Maybe (Maybe LogLevel)
wantedLogLevel ←
            IORef LogState
-> (LogState -> (LogState, Maybe (Maybe LogLevel)))
-> IO (Maybe (Maybe LogLevel))
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
IORef.atomicModifyIORef' LogStateHandle
logStateHandle.unLogStateHandle ((LogState -> (LogState, Maybe (Maybe LogLevel)))
 -> IO (Maybe (Maybe LogLevel)))
-> (LogState -> (LogState, Maybe (Maybe LogLevel)))
-> IO (Maybe (Maybe LogLevel))
forall a b. (a -> b) -> a -> b
$ \case
              PreInit Seq (LogTime, LogLevel, Loc, ThreadId, Text)
queue → (Seq (LogTime, LogLevel, Loc, ThreadId, Text) -> LogState
PreInit (Seq (LogTime, LogLevel, Loc, ThreadId, Text)
queue Seq (LogTime, LogLevel, Loc, ThreadId, Text)
-> (LogTime, LogLevel, Loc, ThreadId, Text)
-> Seq (LogTime, LogLevel, Loc, ThreadId, Text)
forall a. Seq a -> a -> Seq a
Seq.|> (LogTime, LogLevel, Loc, ThreadId, Text)
logMessage), Maybe (Maybe LogLevel)
forall a. Maybe a
Nothing)
              x :: LogState
x@(Initialized Maybe LogLevel
wantedLogLevel) → (LogState
x, Maybe LogLevel -> Maybe (Maybe LogLevel)
forall a. a -> Maybe a
Just Maybe LogLevel
wantedLogLevel)

          IO ()
-> (Maybe LogLevel -> IO ()) -> Maybe (Maybe LogLevel) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ((Text -> IO ())
-> (LogTime, LogLevel, Loc, ThreadId, Text)
-> Maybe LogLevel
-> IO ()
forall (m :: * -> *).
MonadIO m =>
(Text -> m ())
-> (LogTime, LogLevel, Loc, ThreadId, Text)
-> Maybe LogLevel
-> m ()
handleLogMessage Text -> IO ()
writeMsg (LogTime, LogLevel, Loc, ThreadId, Text)
logMessage) Maybe (Maybe LogLevel)
wantedLogLevel
      in
        m a -> IO a
forall a. m a -> IO a
runInIO (m a -> IO a) -> (Logger -> m a) -> Logger -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger -> m a
m (Logger -> IO a) -> Logger -> IO a
forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *).
 MonadIO m =>
 Loc -> LogLevel -> Text -> m ())
-> Logger
Logger Loc -> LogLevel -> Text -> m ()
forall (m :: * -> *). MonadIO m => Loc -> LogLevel -> Text -> m ()
loggerF


logDebug ∷ (ML.MonadLogger m, HasCallStack) ⇒ Text → m ()
logDebug :: forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
logDebug = (HasCallStack => Text -> m ()) -> Text -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (CallStack -> Text -> m ()
forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m ()
ML.logDebugCS CallStack
HasCallStack => CallStack
callStack)

logInfo ∷ (ML.MonadLogger m, HasCallStack) ⇒ Text → m ()
logInfo :: forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
logInfo = (HasCallStack => Text -> m ()) -> Text -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (CallStack -> Text -> m ()
forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m ()
ML.logInfoCS CallStack
HasCallStack => CallStack
callStack)

logWarn ∷ (ML.MonadLogger m, HasCallStack) ⇒ Text → m ()
logWarn :: forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
logWarn = (HasCallStack => Text -> m ()) -> Text -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (CallStack -> Text -> m ()
forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m ()
ML.logWarnCS CallStack
HasCallStack => CallStack
callStack)

logError ∷ (ML.MonadLogger m, HasCallStack) ⇒ Text → m ()
logError :: forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
logError = (HasCallStack => Text -> m ()) -> Text -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (CallStack -> Text -> m ()
forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m ()
ML.logErrorCS CallStack
HasCallStack => CallStack
callStack)


handleLogMessage
  ∷ MonadIO m
  ⇒ (Text → m ())
  → LogMessage
  → Maybe ML.LogLevel
  → m ()
handleLogMessage :: forall (m :: * -> *).
MonadIO m =>
(Text -> m ())
-> (LogTime, LogLevel, Loc, ThreadId, Text)
-> Maybe LogLevel
-> m ()
handleLogMessage Text -> m ()
_ (LogTime, LogLevel, Loc, ThreadId, Text)
_ Maybe LogLevel
Nothing = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- The log is silenced, nothing to do
handleLogMessage Text -> m ()
writeMsg (LogTime
t, LogLevel
logLevel, Loc
location, ThreadId
tid, Text
msg) (Just LogLevel
minLevel) =
  if LogLevel
logLevel LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
minLevel
    then Text -> m ()
writeMsg Text
formattedMsg
    else () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- This log level is silenced
  where
    formattedMsg :: Text
formattedMsg =
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ (Text -> Text) -> [Text] -> Text
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]")) [LogTime
t.unLogTime, Text
lvl, Text
loc, ThreadId
tid.unThreadId]
        , Text
" "
        , Text
msg
        , Text
"\n"
        ]

    lvl :: Text
lvl = case LogLevel
logLevel of
      LogLevel
ML.LevelDebug → Text
"DEBUG"
      LogLevel
ML.LevelInfo → Text
"INFO"
      LogLevel
ML.LevelWarn → Text
"WARNING"
      LogLevel
ML.LevelError → Text
"ERROR"
      ML.LevelOther Text
x → (Char -> Char) -> Text -> Text
map Char -> Char
toUpper Text
x

    loc :: Text
loc = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
      [ String -> Text
pack (String -> Text) -> (Loc -> String) -> Loc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> String
ML.loc_module (Loc -> Text) -> Loc -> Text
forall a b. (a -> b) -> a -> b
$ Loc
location
      , Text
":"
      , String -> Text
pack (String -> Text) -> (Loc -> String) -> Loc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Loc -> Int) -> Loc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Loc -> (Int, Int)) -> Loc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> (Int, Int)
ML.loc_start (Loc -> Text) -> Loc -> Text
forall a b. (a -> b) -> a -> b
$ Loc
location
      ]


createLogState ∷ MonadIO m ⇒ m LogStateHandle
createLogState :: forall (m :: * -> *). MonadIO m => m LogStateHandle
createLogState = (IORef LogState -> LogStateHandle)
-> m (IORef LogState) -> m LogStateHandle
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IORef LogState -> LogStateHandle
LogStateHandle (m (IORef LogState) -> m LogStateHandle)
-> (LogState -> m (IORef LogState)) -> LogState -> m LogStateHandle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogState -> m (IORef LogState)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
IORef.newIORef (LogState -> m LogStateHandle) -> LogState -> m LogStateHandle
forall a b. (a -> b) -> a -> b
$ Seq (LogTime, LogLevel, Loc, ThreadId, Text) -> LogState
PreInit Seq (LogTime, LogLevel, Loc, ThreadId, Text)
forall a. Monoid a => a
mempty


-- | Set the desired log-level for the logger
--
-- Will initialize the logger if it was not yet initialized.
-- Otherwise will just override the wanted log level.
setLogLevel
  ∷ (UIO.MonadUnliftIO m, ML.MonadLogger m)
  ⇒ LogStateHandle
  → Maybe ML.LogLevel
  → m ()
setLogLevel :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLogger m) =>
LogStateHandle -> Maybe LogLevel -> m ()
setLogLevel LogStateHandle
logStateHandle Maybe LogLevel
wantedLogLevel = do
  Maybe (Seq (LogTime, LogLevel, Loc, ThreadId, Text))
mayQueue ←
    IORef LogState
-> (LogState
    -> (LogState,
        Maybe (Seq (LogTime, LogLevel, Loc, ThreadId, Text))))
-> m (Maybe (Seq (LogTime, LogLevel, Loc, ThreadId, Text)))
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
IORef.atomicModifyIORef' LogStateHandle
logStateHandle.unLogStateHandle ((LogState
  -> (LogState,
      Maybe (Seq (LogTime, LogLevel, Loc, ThreadId, Text))))
 -> m (Maybe (Seq (LogTime, LogLevel, Loc, ThreadId, Text))))
-> (LogState
    -> (LogState,
        Maybe (Seq (LogTime, LogLevel, Loc, ThreadId, Text))))
-> m (Maybe (Seq (LogTime, LogLevel, Loc, ThreadId, Text)))
forall a b. (a -> b) -> a -> b
$ \case
      PreInit Seq (LogTime, LogLevel, Loc, ThreadId, Text)
queue → (Maybe LogLevel -> LogState
Initialized Maybe LogLevel
wantedLogLevel, Seq (LogTime, LogLevel, Loc, ThreadId, Text)
-> Maybe (Seq (LogTime, LogLevel, Loc, ThreadId, Text))
forall a. a -> Maybe a
Just Seq (LogTime, LogLevel, Loc, ThreadId, Text)
queue)
      Initialized Maybe LogLevel
_ → (Maybe LogLevel -> LogState
Initialized Maybe LogLevel
wantedLogLevel, Maybe (Seq (LogTime, LogLevel, Loc, ThreadId, Text))
forall a. Maybe a
Nothing)
  case Maybe (Seq (LogTime, LogLevel, Loc, ThreadId, Text))
mayQueue of
    Maybe (Seq (LogTime, LogLevel, Loc, ThreadId, Text))
Nothing →
      Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Just updated the log level to: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text)
-> (Maybe LogLevel -> String) -> Maybe LogLevel -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe LogLevel -> String
forall a. Show a => a -> String
show) Maybe LogLevel
wantedLogLevel
    Just Seq (LogTime, LogLevel, Loc, ThreadId, Text)
queue → do
      Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Handling the log messages queue after initializing log level to: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        (String -> Text
pack (String -> Text)
-> (Maybe LogLevel -> String) -> Maybe LogLevel -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe LogLevel -> String
forall a. Show a => a -> String
show) Maybe LogLevel
wantedLogLevel
      ((Text -> m ()) -> m ()) -> m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
((Text -> m ()) -> m a) -> m a
withFastLogger (((Text -> m ()) -> m ()) -> m ())
-> ((Text -> m ()) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Text -> m ()
writeMsg → do
        -- Handle all previously queued log messages
        ((LogTime, LogLevel, Loc, ThreadId, Text) -> m ())
-> Seq (LogTime, LogLevel, Loc, ThreadId, Text) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (((LogTime, LogLevel, Loc, ThreadId, Text)
 -> Maybe LogLevel -> m ())
-> Maybe LogLevel
-> (LogTime, LogLevel, Loc, ThreadId, Text)
-> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Text -> m ())
-> (LogTime, LogLevel, Loc, ThreadId, Text)
-> Maybe LogLevel
-> m ()
forall (m :: * -> *).
MonadIO m =>
(Text -> m ())
-> (LogTime, LogLevel, Loc, ThreadId, Text)
-> Maybe LogLevel
-> m ()
handleLogMessage Text -> m ()
writeMsg) Maybe LogLevel
wantedLogLevel) Seq (LogTime, LogLevel, Loc, ThreadId, Text)
queue


-- | Initialize log to debug-level in case it is not yet initialized
--
-- Useful for handling application failures before the log-level is set.
-- So that errors are reported instead of stay silent in the queue.
forceLogInitialization
  ∷ (UIO.MonadUnliftIO m, ML.MonadLogger m)
  ⇒ LogStateHandle
  → m ()
forceLogInitialization :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLogger m) =>
LogStateHandle -> m ()
forceLogInitialization LogStateHandle
logStateHandle = do
  Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
logDebug Text
"Received a request to force log level initialization…"
  IORef LogState -> m LogState
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
IORef.readIORef LogStateHandle
logStateHandle.unLogStateHandle m LogState -> (LogState -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    PreInit Seq (LogTime, LogLevel, Loc, ThreadId, Text)
_ → do
      Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Forcing log initialization to debug level…"
      LogStateHandle -> Maybe LogLevel -> m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLogger m) =>
LogStateHandle -> Maybe LogLevel -> m ()
setLogLevel LogStateHandle
logStateHandle (LogLevel -> Maybe LogLevel
forall a. a -> Maybe a
Just LogLevel
ML.LevelDebug)
    Initialized Maybe LogLevel
wantedLogLevel →
      Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Log is already initialized to (no reason to force initialization): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        (String -> Text
pack (String -> Text)
-> (Maybe LogLevel -> String) -> Maybe LogLevel -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe LogLevel -> String
forall a. Show a => a -> String
show) Maybe LogLevel
wantedLogLevel


-- | Default implementation for "ML.MonadLogger"
defaultMonadLoggerLog
  ∷ (MonadIO m, HasLogger r, MR.MonadReader r m, ML.ToLogStr msg)
  ⇒ ML.Loc
  → ML.LogSource
  → ML.LogLevel
  → msg
  → m ()
defaultMonadLoggerLog :: forall (m :: * -> *) r msg.
(MonadIO m, HasLogger r, MonadReader r m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
defaultMonadLoggerLog Loc
loc Text
_src LogLevel
lvl msg
msg =
  (r -> Logger) -> m Logger
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
MR.asks (Getting Logger r Logger -> r -> Logger
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Logger r Logger
forall r. HasLogger r => Lens' r Logger
Lens' r Logger
logger) m Logger -> (Logger -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Logger
x → Logger
-> forall (m :: * -> *).
   MonadIO m =>
   Loc -> LogLevel -> Text -> m ()
runLogger Logger
x Loc
loc LogLevel
lvl (Text -> m ()) -> (msg -> Text) -> msg -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. msg -> Text
forall msg. ToLogStr msg => msg -> Text
logStrToText (msg -> m ()) -> msg -> m ()
forall a b. (a -> b) -> a -> b
$ msg
msg


withFastLogger ∷ UIO.MonadUnliftIO m ⇒ ((Text → m ()) → m a) → m a
withFastLogger :: forall (m :: * -> *) a.
MonadUnliftIO m =>
((Text -> m ()) -> m a) -> m a
withFastLogger (Text -> m ()) -> m a
m =
  ((forall a. m a -> IO a) -> IO a) -> m a
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
UIO.withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO →
    LogType -> (FastLogger -> IO a) -> IO a
forall a. LogType -> (FastLogger -> IO a) -> IO a
FL.withFastLogger (Int -> LogType
FL.LogStderr Int
0) ((FastLogger -> IO a) -> IO a) -> (FastLogger -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FastLogger
f →
      m a -> IO a
forall a. m a -> IO a
runInIO (m a -> IO a) -> m a -> IO a
forall a b. (a -> b) -> a -> b
$ (Text -> m ()) -> m a
m (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Text -> IO ()) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastLogger
f FastLogger -> (Text -> LogStr) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
FL.toLogStr)


-- * Types

newtype Logger = Logger { Logger
-> forall (m :: * -> *).
   MonadIO m =>
   Loc -> LogLevel -> Text -> m ()
runLogger ∷ ∀m. MonadIO m ⇒ ML.Loc → ML.LogLevel → Text → m () }

instance {-# OVERLAPS #-} MonadIO m ⇒ ML.MonadLogger (MR.ReaderT Logger m) where
  monadLoggerLog :: forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> ReaderT Logger m ()
monadLoggerLog = Loc -> Text -> LogLevel -> msg -> ReaderT Logger m ()
forall (m :: * -> *) r msg.
(MonadIO m, HasLogger r, MonadReader r m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
defaultMonadLoggerLog


class HasLogger r where
  logger ∷ Lens' r Logger

instance HasLogger Logger where
  logger :: Lens' Logger Logger
logger = (Logger -> f Logger) -> Logger -> f Logger
forall a. a -> a
id


data LogState
  -- | Before options are parsed and log-level is not known yet.
  -- Accumulate the log messages in a queue and handle them later.
  = PreInit (Seq.Seq LogMessage)
  -- | After log-level is known (@Nothing@ means the log is silenced)
  | Initialized (Maybe ML.LogLevel)
  deriving stock (LogState -> LogState -> Bool
(LogState -> LogState -> Bool)
-> (LogState -> LogState -> Bool) -> Eq LogState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogState -> LogState -> Bool
== :: LogState -> LogState -> Bool
$c/= :: LogState -> LogState -> Bool
/= :: LogState -> LogState -> Bool
Eq, Int -> LogState -> ShowS
[LogState] -> ShowS
LogState -> String
(Int -> LogState -> ShowS)
-> (LogState -> String) -> ([LogState] -> ShowS) -> Show LogState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogState -> ShowS
showsPrec :: Int -> LogState -> ShowS
$cshow :: LogState -> String
show :: LogState -> String
$cshowList :: [LogState] -> ShowS
showList :: [LogState] -> ShowS
Show)

-- Do not export the constructor
newtype LogStateHandle = LogStateHandle { LogStateHandle -> IORef LogState
unLogStateHandle ∷ IORef.IORef LogState }


newtype LogTime = LogTime { LogTime -> Text
unLogTime ∷ Text }
  deriving stock (LogTime -> LogTime -> Bool
(LogTime -> LogTime -> Bool)
-> (LogTime -> LogTime -> Bool) -> Eq LogTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogTime -> LogTime -> Bool
== :: LogTime -> LogTime -> Bool
$c/= :: LogTime -> LogTime -> Bool
/= :: LogTime -> LogTime -> Bool
Eq, Int -> LogTime -> ShowS
[LogTime] -> ShowS
LogTime -> String
(Int -> LogTime -> ShowS)
-> (LogTime -> String) -> ([LogTime] -> ShowS) -> Show LogTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogTime -> ShowS
showsPrec :: Int -> LogTime -> ShowS
$cshow :: LogTime -> String
show :: LogTime -> String
$cshowList :: [LogTime] -> ShowS
showList :: [LogTime] -> ShowS
Show)

newtype ThreadId = ThreadId { ThreadId -> Text
unThreadId ∷ Text }
  deriving stock (ThreadId -> ThreadId -> Bool
(ThreadId -> ThreadId -> Bool)
-> (ThreadId -> ThreadId -> Bool) -> Eq ThreadId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ThreadId -> ThreadId -> Bool
== :: ThreadId -> ThreadId -> Bool
$c/= :: ThreadId -> ThreadId -> Bool
/= :: ThreadId -> ThreadId -> Bool
Eq, Int -> ThreadId -> ShowS
[ThreadId] -> ShowS
ThreadId -> String
(Int -> ThreadId -> ShowS)
-> (ThreadId -> String) -> ([ThreadId] -> ShowS) -> Show ThreadId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThreadId -> ShowS
showsPrec :: Int -> ThreadId -> ShowS
$cshow :: ThreadId -> String
show :: ThreadId -> String
$cshowList :: [ThreadId] -> ShowS
showList :: [ThreadId] -> ShowS
Show)

type LogMessage = (LogTime, ML.LogLevel, ML.Loc, ThreadId, Text)


-- * Helpers

getTimeForLog ∷ MonadIO m ⇒ m LogTime
getTimeForLog :: forall (m :: * -> *). MonadIO m => m LogTime
getTimeForLog = Text -> LogTime
LogTime (Text -> LogTime) -> (UTCTime -> Text) -> UTCTime -> LogTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text) -> (UTCTime -> String) -> UTCTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> String
forall t. ISO8601 t => t -> String
iso8601Show (UTCTime -> LogTime) -> m UTCTime -> m LogTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime


logStrToText ∷ ML.ToLogStr msg ⇒ msg → Text
logStrToText :: forall msg. ToLogStr msg => msg -> Text
logStrToText = ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (msg -> ByteString) -> msg -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> ByteString
ML.fromLogStr (LogStr -> ByteString) -> (msg -> LogStr) -> msg -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. msg -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
ML.toLogStr