{-# LANGUAGE TemplateHaskell #-}

-- | Provides logging effect and utilities..
--
-- @since 0.1
module Effects.Logger
  ( -- * Effect
    MonadLogger (..),

    -- * Levels
    LogLevel (..),
    levelTrace,
    levelFatal,

    -- ** Logging functions

    -- *** Levels
    logTrace,
    MLogger.logDebug,
    MLogger.logInfo,
    MLogger.logWarn,
    MLogger.logError,
    MLogger.logOther,
    logFatal,

    -- *** Level checks
    guardLevel,
    shouldLog,

    -- * Formatting
    LogFormatter (..),
    Utils.defaultLogFormatter,
    LocStrategy (..),
    formatLog,

    -- * Optics

    -- ** LogLevels
    _LevelTrace,
    _LevelInfo,
    _LevelDebug,
    _LevelWarn,
    _LevelError,
    _LevelOther,
    _LevelFatal,

    -- * Reexports
    LogStr,
    Loc,
  )
where

import Control.Monad (when)
import Control.Monad.Logger
  ( LogLevel (LevelDebug, LevelError, LevelInfo, LevelOther, LevelWarn),
    LogStr,
    MonadLogger (monadLoggerLog),
    ToLogStr,
    liftLoc,
  )
import Control.Monad.Logger qualified as MLogger
import Data.Text (Text)
import Data.Text qualified as T
import Data.Word (Word8)
import Effects.Concurrent.Thread (MonadThread)
import Effects.Logger.Utils
  ( LocStrategy (LocNone, LocPartial, LocStable),
    LogFormatter (MkLogFormatter, locStrategy, newline, threadLabel, timezone),
  )
import Effects.Logger.Utils qualified as Utils
import Effects.Time (MonadTime)
import GHC.Stack (HasCallStack)
import Language.Haskell.TH (Loc)
import Language.Haskell.TH.Syntax (Exp, Lift (lift), Q, Quasi (qLocation))
import Optics.Core
  ( Prism',
    preview,
    prism,
  )

-- | Produces a formatted 'LogStr'.
--
-- __Example__
--
-- @
-- -- [timestamp][thread_label][code_loc][level] msg
-- [2022-02-08 10:20:05][thread-label][filename:1:2][Warn] msg
-- @
--
-- @since 0.1
formatLog ::
  ( HasCallStack,
    MonadThread m,
    MonadTime m,
    ToLogStr msg
  ) =>
  -- | Formatter to use.
  LogFormatter ->
  -- | The level in which to log.
  LogLevel ->
  -- | Message.
  msg ->
  -- | Formatted LogStr.
  m LogStr
formatLog :: forall (m :: * -> *) msg.
(HasCallStack, MonadThread m, MonadTime m, ToLogStr msg) =>
LogFormatter -> LogLevel -> msg -> m LogStr
formatLog = Maybe Namespace -> LogFormatter -> LogLevel -> msg -> m LogStr
forall (m :: * -> *) msg.
(HasCallStack, MonadThread m, MonadTime m, ToLogStr msg) =>
Maybe Namespace -> LogFormatter -> LogLevel -> msg -> m LogStr
Utils.formatLog Maybe Namespace
forall a. Maybe a
Nothing
{-# INLINEABLE formatLog #-}

-- Vendored from monad-logger
logTH :: LogLevel -> Q Exp
logTH :: LogLevel -> Q Exp
logTH LogLevel
level =
  [|
    monadLoggerLog $(Q Loc
forall (m :: * -> *). Quasi m => m Loc
qLocation Q Loc -> (Loc -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Loc -> Q Exp
liftLoc) (T.pack "") $(LogLevel -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => LogLevel -> m Exp
lift LogLevel
level)
      . (id :: Text -> Text)
    |]

-- | @since 0.1
levelTrace :: LogLevel
levelTrace :: LogLevel
levelTrace = Text -> LogLevel
LevelOther Text
"Trace"

-- | @since 0.1
levelFatal :: LogLevel
levelFatal :: LogLevel
levelFatal = Text -> LogLevel
LevelOther Text
"Fatal"

-- | @since 0.1
logTrace :: Q Exp
logTrace :: Q Exp
logTrace = LogLevel -> Q Exp
logTH LogLevel
levelTrace

-- | @since 0.1
logFatal :: Q Exp
logFatal :: Q Exp
logFatal = LogLevel -> Q Exp
logTH LogLevel
levelFatal

-- | @guardLevel configLvl lvl m@ runs @m@ iff @'shouldLog' configLvl lvl@.
-- This can be useful for writing a logging function e.g.
--
-- @
--   -- logs msg to file iff configLogLevel <= lvl e.g.
--   -- configLogLevel := 'LevelWarn'
--   -- lvl            := 'LevelError'
--   logMsg lvl msg = do
--   configLogLevel <- getConfigLogLevel -- e.g. ReaderT Env
--   guardLevel configLogLevel lvl $ do
--     logToFile msg
-- @
--
-- @since 0.1
guardLevel ::
  (Applicative f) =>
  -- | The configured log level to check against.
  LogLevel ->
  -- | The log level for this action.
  LogLevel ->
  -- | The logging action to run if the level passes.
  f () ->
  f ()
guardLevel :: forall (f :: * -> *).
Applicative f =>
LogLevel -> LogLevel -> f () -> f ()
guardLevel LogLevel
configLvl LogLevel
lvl = Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel -> LogLevel -> Bool
shouldLog LogLevel
configLvl LogLevel
lvl)
{-# INLINEABLE guardLevel #-}

-- | @shouldLog configLvl lvl@ returns true iff @configLvl <= lvl@. Uses
-- LogLevel's built-in ordering with special cases for "Trace"
-- (@LevelOther "Trace"@) and "Fatal" (@LevelOther "Fatal"@). The ad-hoc
-- ordering is thus:
--
-- @
--   LevelOther \"Trace\"
--     < LevelDebug
--     < LevelInfo
--     < LevelWarn
--     < LevelError
--     < LevelOther \"Fatal\"
--     < LevelOther \"\<any\>\"
-- @
--
-- In other words, 'LogLevel'\'s usual 'Ord' is respected, with the additional
-- cases. Note that any other @LevelOther "custom"@ sit at the the highest
-- level and compare via Text's 'Ord', just like 'LogLevel'\'s usual 'Ord'.
--
-- @since 0.1
shouldLog ::
  -- | The configured log level to check against.
  LogLevel ->
  -- | Level for this log
  LogLevel ->
  -- | Whether we should log
  Bool
shouldLog :: LogLevel -> LogLevel -> Bool
shouldLog LogLevel
configLvl LogLevel
lvl =
  -- If both are LevelOther and not Trace/Fatal then we need to compare
  -- labels, as that is how Ord works.
  case (Optic' A_Prism NoIx LogLevel Text -> LogLevel -> Maybe Text
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Optic' A_Prism NoIx LogLevel Text
_LevelOther LogLevel
configLvl, Optic' A_Prism NoIx LogLevel Text -> LogLevel -> Maybe Text
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Optic' A_Prism NoIx LogLevel Text
_LevelOther LogLevel
lvl) of
    (Just Text
configTxt, Just Text
lvlTxt)
      | Text -> Bool
forall {a}. (Eq a, IsString a) => a -> Bool
isCustom Text
configTxt Bool -> Bool -> Bool
&& Text -> Bool
forall {a}. (Eq a, IsString a) => a -> Bool
isCustom Text
lvlTxt -> Text
configTxt Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
<= Text
lvlTxt
    (Maybe Text, Maybe Text)
_ -> LogLevel -> Word8
logLevelToWord LogLevel
configLvl Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= LogLevel -> Word8
logLevelToWord LogLevel
lvl
  where
    isCustom :: a -> Bool
isCustom a
t =
      a
t a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
"Trace" Bool -> Bool -> Bool
&& a
t a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
"Fatal"

-- | @since 0.1
_LevelTrace :: Prism' LogLevel ()
_LevelTrace :: Prism' LogLevel ()
_LevelTrace =
  (() -> LogLevel)
-> (LogLevel -> Either LogLevel ()) -> Prism' LogLevel ()
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism
    (LogLevel -> () -> LogLevel
forall a b. a -> b -> a
const LogLevel
levelTrace)
    ( \case
        LevelOther Text
"Trace" -> () -> Either LogLevel ()
forall a b. b -> Either a b
Right ()
        LogLevel
other -> LogLevel -> Either LogLevel ()
forall a b. a -> Either a b
Left LogLevel
other
    )
{-# INLINE _LevelTrace #-}

-- | @since 0.1
_LevelDebug :: Prism' LogLevel ()
_LevelDebug :: Prism' LogLevel ()
_LevelDebug =
  (() -> LogLevel)
-> (LogLevel -> Either LogLevel ()) -> Prism' LogLevel ()
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism
    (LogLevel -> () -> LogLevel
forall a b. a -> b -> a
const LogLevel
LevelDebug)
    ( \case
        LogLevel
LevelDebug -> () -> Either LogLevel ()
forall a b. b -> Either a b
Right ()
        LogLevel
other -> LogLevel -> Either LogLevel ()
forall a b. a -> Either a b
Left LogLevel
other
    )
{-# INLINE _LevelDebug #-}

-- | @since 0.1
_LevelInfo :: Prism' LogLevel ()
_LevelInfo :: Prism' LogLevel ()
_LevelInfo =
  (() -> LogLevel)
-> (LogLevel -> Either LogLevel ()) -> Prism' LogLevel ()
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism
    (LogLevel -> () -> LogLevel
forall a b. a -> b -> a
const LogLevel
LevelInfo)
    ( \case
        LogLevel
LevelInfo -> () -> Either LogLevel ()
forall a b. b -> Either a b
Right ()
        LogLevel
other -> LogLevel -> Either LogLevel ()
forall a b. a -> Either a b
Left LogLevel
other
    )
{-# INLINE _LevelInfo #-}

-- | @since 0.1
_LevelWarn :: Prism' LogLevel ()
_LevelWarn :: Prism' LogLevel ()
_LevelWarn =
  (() -> LogLevel)
-> (LogLevel -> Either LogLevel ()) -> Prism' LogLevel ()
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism
    (LogLevel -> () -> LogLevel
forall a b. a -> b -> a
const LogLevel
LevelWarn)
    ( \case
        LogLevel
LevelWarn -> () -> Either LogLevel ()
forall a b. b -> Either a b
Right ()
        LogLevel
other -> LogLevel -> Either LogLevel ()
forall a b. a -> Either a b
Left LogLevel
other
    )
{-# INLINE _LevelWarn #-}

-- | @since 0.1
_LevelError :: Prism' LogLevel ()
_LevelError :: Prism' LogLevel ()
_LevelError =
  (() -> LogLevel)
-> (LogLevel -> Either LogLevel ()) -> Prism' LogLevel ()
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism
    (LogLevel -> () -> LogLevel
forall a b. a -> b -> a
const LogLevel
LevelError)
    ( \case
        LogLevel
LevelError -> () -> Either LogLevel ()
forall a b. b -> Either a b
Right ()
        LogLevel
other -> LogLevel -> Either LogLevel ()
forall a b. a -> Either a b
Left LogLevel
other
    )
{-# INLINE _LevelError #-}

-- | @since 0.1
_LevelOther :: Prism' LogLevel Text
_LevelOther :: Optic' A_Prism NoIx LogLevel Text
_LevelOther =
  (Text -> LogLevel)
-> (LogLevel -> Either LogLevel Text)
-> Optic' A_Prism NoIx LogLevel Text
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism
    Text -> LogLevel
LevelOther
    ( \case
        LevelOther Text
l -> Text -> Either LogLevel Text
forall a b. b -> Either a b
Right Text
l
        LogLevel
other -> LogLevel -> Either LogLevel Text
forall a b. a -> Either a b
Left LogLevel
other
    )
{-# INLINE _LevelOther #-}

-- | @since 0.1
_LevelFatal :: Prism' LogLevel ()
_LevelFatal :: Prism' LogLevel ()
_LevelFatal =
  (() -> LogLevel)
-> (LogLevel -> Either LogLevel ()) -> Prism' LogLevel ()
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism
    (LogLevel -> () -> LogLevel
forall a b. a -> b -> a
const LogLevel
levelFatal)
    ( \case
        LevelOther Text
"Fatal" -> () -> Either LogLevel ()
forall a b. b -> Either a b
Right ()
        LogLevel
other -> LogLevel -> Either LogLevel ()
forall a b. a -> Either a b
Left LogLevel
other
    )
{-# INLINE _LevelFatal #-}

logLevelToWord :: LogLevel -> Word8
logLevelToWord :: LogLevel -> Word8
logLevelToWord (LevelOther Text
"Trace") = Word8
0
logLevelToWord LogLevel
LevelDebug = Word8
1
logLevelToWord LogLevel
LevelInfo = Word8
2
logLevelToWord LogLevel
LevelWarn = Word8
3
logLevelToWord LogLevel
LevelError = Word8
4
logLevelToWord (LevelOther Text
"Fatal") = Word8
5
logLevelToWord (LevelOther Text
_) = Word8
6