-- | Provides namespaced logging functionality on top of 'MonadLogger'.
--
-- @since 0.1
module Effects.Logger.Namespace
  ( -- * Effect
    Utils.Namespace (..),
    addNamespace,

    -- * Constraint aliases
    HasNamespace,
    MonadLoggerNS,

    -- ** Logging functions

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

    -- * LogStr
    Utils.logStrToBs,
    Utils.logStrToText,

    -- * Optics

    -- ** LocStrategy
    _LocPartial,
    _LocStable,
    _LocNone,
  )
where

import Control.Monad.Logger
  ( LogLevel,
    LogStr,
    MonadLogger,
    ToLogStr,
  )
import Control.Monad.Reader.Class (MonadReader (local), asks)
import Data.Kind (Constraint, Type)
import Data.Sequence (Seq ((:|>)))
import Data.Text (Text)
import Effects.Concurrent.Thread (MonadThread)
import Effects.Logger.Utils
  ( LocStrategy (LocNone, LocPartial, LocStable),
    LogFormatter (MkLogFormatter, locStrategy, newline, threadLabel, timezone),
    Namespace,
  )
import Effects.Logger.Utils qualified as Utils
import Effects.Time (MonadTime)
import GHC.Stack (HasCallStack)
import Language.Haskell.TH (Loc)
import Optics.Core
  ( A_Getter,
    A_Setter,
    Is,
    LabelOptic',
    NoIx,
    Optic',
    Prism',
    Setter',
    castOptic,
    over',
    prism,
    view,
    (%),
  )

-- | Alias for constraints required to use namespaces.
type HasNamespace :: (Type -> Type) -> Type -> Type -> Constraint
type HasNamespace m env k =
  ( Is k A_Getter,
    Is k A_Setter,
    LabelOptic' "namespace" k env Namespace,
    MonadReader env m
  )

-- | Alias for HasNamespace and MonadLogger constraint.
type MonadLoggerNS :: (Type -> Type) -> Type -> Type -> Constraint
type MonadLoggerNS m env k = (HasNamespace m env k, MonadLogger m)

-- | Adds to the namespace.
--
-- @since 0.1
addNamespace ::
  forall m env a k.
  ( Is k A_Setter,
    LabelOptic' "namespace" k env Namespace,
    MonadReader env m
  ) =>
  Text ->
  m a ->
  m a
addNamespace :: forall (m :: * -> *) env a k.
(Is k A_Setter, LabelOptic' "namespace" k env Namespace,
 MonadReader env m) =>
Text -> m a -> m a
addNamespace Text
txt = (env -> env) -> m a -> m a
forall a. (env -> env) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Optic A_Setter NoIx env env (Seq Text) (Seq Text)
-> (Seq Text -> Seq Text) -> env -> env
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over' (Optic' k NoIx env Namespace -> Setter' env Namespace
castSet Optic' k NoIx env Namespace
#namespace Setter' env Namespace
-> Optic An_Iso NoIx Namespace Namespace (Seq Text) (Seq Text)
-> Optic A_Setter NoIx env env (Seq Text) (Seq Text)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic An_Iso NoIx Namespace Namespace (Seq Text) (Seq Text)
#unNamespace) (Seq Text -> Text -> Seq Text
forall a. Seq a -> a -> Seq a
:|> Text
txt))
  where
    -- See https://github.com/well-typed/optics/issues/368 for why this is
    -- necessary.
    castSet :: Optic' k NoIx env Namespace -> Setter' env Namespace
    castSet :: Optic' k NoIx env Namespace -> Setter' env Namespace
castSet = forall destKind srcKind (is :: IxList) s t a b.
Is srcKind destKind =>
Optic srcKind is s t a b -> Optic destKind is s t a b
castOptic @A_Setter @k @_ @env @env @Namespace @Namespace
{-# INLINEABLE addNamespace #-}

-- | @since 0.1
_LocPartial :: Prism' LocStrategy Loc
_LocPartial :: Prism' LocStrategy Loc
_LocPartial =
  (Loc -> LocStrategy)
-> (LocStrategy -> Either LocStrategy Loc)
-> Prism' LocStrategy Loc
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism
    Loc -> LocStrategy
LocPartial
    ( \case
        LocPartial Loc
loc -> Loc -> Either LocStrategy Loc
forall a b. b -> Either a b
Right Loc
loc
        LocStrategy
other -> LocStrategy -> Either LocStrategy Loc
forall a b. a -> Either a b
Left LocStrategy
other
    )
{-# INLINE _LocPartial #-}

-- | @since 0.1
_LocStable :: Prism' LocStrategy Loc
_LocStable :: Prism' LocStrategy Loc
_LocStable =
  (Loc -> LocStrategy)
-> (LocStrategy -> Either LocStrategy Loc)
-> Prism' LocStrategy Loc
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism
    Loc -> LocStrategy
LocStable
    ( \case
        LocStable Loc
loc -> Loc -> Either LocStrategy Loc
forall a b. b -> Either a b
Right Loc
loc
        LocStrategy
other -> LocStrategy -> Either LocStrategy Loc
forall a b. a -> Either a b
Left LocStrategy
other
    )
{-# INLINE _LocStable #-}

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

-- | Produces a formatted 'LogStr'.
--
-- __Example__
--
-- @
-- -- [timestamp][thread_label][namespace][code_loc][level] msg
-- [2022-02-08 10:20:05][thread-label][one.two][filename:1:2][Warn] msg
-- @
--
-- @since 0.1
formatLog ::
  forall m env msg k.
  ( HasCallStack,
    Is k A_Getter,
    LabelOptic' "namespace" k env Namespace,
    MonadReader env m,
    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 :: * -> *) env msg k.
(HasCallStack, Is k A_Getter,
 LabelOptic' "namespace" k env Namespace, MonadReader env m,
 MonadThread m, MonadTime m, ToLogStr msg) =>
LogFormatter -> LogLevel -> msg -> m LogStr
formatLog LogFormatter
formatter LogLevel
lvl msg
msg = do
  ns <- (env -> Namespace) -> m Namespace
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Optic' k NoIx env Namespace -> env -> Namespace
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' k NoIx env Namespace
#namespace)
  Utils.formatLog (Just ns) formatter lvl msg
{-# INLINEABLE formatLog #-}