{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Effectful.Logger.Utils
  ( -- * Namespace
    Namespace (..),
    displayNamespace,

    -- * Levels
    LogLevel (..),

    -- * Formatter
    LogFormatter (..),
    defaultLogFormatter,
    LocStrategy (..),
    formatLog,

    -- * Misc
    logStrToText,
    logStrToBs,
  )
where

import Control.DeepSeq (NFData)
import Data.ByteString (ByteString)
import Data.ByteString.Builder (Builder)
import Data.Foldable (Foldable (foldMap'))
#if MIN_VERSION_base(4, 18, 0)
import Data.Functor ((<&>))
#endif
import Data.Sequence (Seq)
import Data.Sequence qualified as Seq
import Data.String (IsString (fromString))
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TEnc
import Data.Text.Encoding.Error qualified as TEncError
import Effectful (Eff, (:>))
import Effectful.Concurrent (Concurrent)
import Effectful.Concurrent qualified as CC
#if MIN_VERSION_base(4, 18, 0)
import Effectful.Concurrent.Static qualified as Thread
#endif
import Effectful.Time.Dynamic (Time)
import Effectful.Time.Dynamic qualified as Time
import GHC.Generics (Generic)
#if MIN_VERSION_base(4, 17, 0)
import GHC.IsList (IsList (Item, fromList, toList))
#else
import GHC.Exts (IsList (Item, fromList, toList))
#endif
import GHC.Stack (HasCallStack)
import Language.Haskell.TH (Loc (loc_filename, loc_start))
import Language.Haskell.TH.Syntax (Lift (lift, liftTyped))
import Optics.Core
  ( A_Lens,
    An_Iso,
    LabelOptic (labelOptic),
    iso,
    lensVL,
    view,
    (%),
    (^.),
    _1,
    _2,
  )
import System.Log.FastLogger (LogStr, ToLogStr (toLogStr))
import System.Log.FastLogger qualified as FL

-- | Logging namespace.
--
-- @since 0.1
newtype Namespace = MkNamespace
  { -- | @since 0.1
    Namespace -> Seq Text
unNamespace :: Seq Text
  }
  deriving stock
    ( -- | @since 0.1
      Namespace -> Namespace -> Bool
(Namespace -> Namespace -> Bool)
-> (Namespace -> Namespace -> Bool) -> Eq Namespace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Namespace -> Namespace -> Bool
== :: Namespace -> Namespace -> Bool
$c/= :: Namespace -> Namespace -> Bool
/= :: Namespace -> Namespace -> Bool
Eq,
      -- | @since 0.1
      (forall x. Namespace -> Rep Namespace x)
-> (forall x. Rep Namespace x -> Namespace) -> Generic Namespace
forall x. Rep Namespace x -> Namespace
forall x. Namespace -> Rep Namespace x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Namespace -> Rep Namespace x
from :: forall x. Namespace -> Rep Namespace x
$cto :: forall x. Rep Namespace x -> Namespace
to :: forall x. Rep Namespace x -> Namespace
Generic,
      -- | @since 0.1
      Int -> Namespace -> ShowS
[Namespace] -> ShowS
Namespace -> String
(Int -> Namespace -> ShowS)
-> (Namespace -> String)
-> ([Namespace] -> ShowS)
-> Show Namespace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Namespace -> ShowS
showsPrec :: Int -> Namespace -> ShowS
$cshow :: Namespace -> String
show :: Namespace -> String
$cshowList :: [Namespace] -> ShowS
showList :: [Namespace] -> ShowS
Show
    )
  deriving
    ( -- | @since 0.1
      Semigroup Namespace
Namespace
Semigroup Namespace =>
Namespace
-> (Namespace -> Namespace -> Namespace)
-> ([Namespace] -> Namespace)
-> Monoid Namespace
[Namespace] -> Namespace
Namespace -> Namespace -> Namespace
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Namespace
mempty :: Namespace
$cmappend :: Namespace -> Namespace -> Namespace
mappend :: Namespace -> Namespace -> Namespace
$cmconcat :: [Namespace] -> Namespace
mconcat :: [Namespace] -> Namespace
Monoid,
      -- | @since 0.1
      NonEmpty Namespace -> Namespace
Namespace -> Namespace -> Namespace
(Namespace -> Namespace -> Namespace)
-> (NonEmpty Namespace -> Namespace)
-> (forall b. Integral b => b -> Namespace -> Namespace)
-> Semigroup Namespace
forall b. Integral b => b -> Namespace -> Namespace
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Namespace -> Namespace -> Namespace
<> :: Namespace -> Namespace -> Namespace
$csconcat :: NonEmpty Namespace -> Namespace
sconcat :: NonEmpty Namespace -> Namespace
$cstimes :: forall b. Integral b => b -> Namespace -> Namespace
stimes :: forall b. Integral b => b -> Namespace -> Namespace
Semigroup
    )
    via (Seq Text)
  deriving anyclass
    ( -- | @since 0.1
      Namespace -> ()
(Namespace -> ()) -> NFData Namespace
forall a. (a -> ()) -> NFData a
$crnf :: Namespace -> ()
rnf :: Namespace -> ()
NFData
    )

-- | @since 0.1
instance
  (k ~ An_Iso, a ~ Seq Text, b ~ Seq Text) =>
  LabelOptic "unNamespace" k Namespace Namespace a b
  where
  labelOptic :: Optic k NoIx Namespace Namespace a b
labelOptic = (Namespace -> a) -> (b -> Namespace) -> Iso Namespace Namespace a b
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(MkNamespace Seq Text
ns) -> a
Seq Text
ns) b -> Namespace
Seq Text -> Namespace
MkNamespace
  {-# INLINE labelOptic #-}

-- | @since 0.1
instance IsString Namespace where
  fromString :: String -> Namespace
fromString = Seq Text -> Namespace
MkNamespace (Seq Text -> Namespace)
-> (String -> Seq Text) -> String -> Namespace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Seq Text
forall a. a -> Seq a
Seq.singleton (Text -> Seq Text) -> (String -> Text) -> String -> Seq Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

-- | @since 0.1
instance IsList Namespace where
  type Item Namespace = Text
  fromList :: [Item Namespace] -> Namespace
fromList = Seq Text -> Namespace
MkNamespace (Seq Text -> Namespace)
-> ([Text] -> Seq Text) -> [Text] -> Namespace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Item (Seq Text)] -> Seq Text
[Text] -> Seq Text
forall l. IsList l => [Item l] -> l
fromList
  toList :: Namespace -> [Item Namespace]
toList = Seq Text -> [Item (Seq Text)]
Seq Text -> [Text]
forall l. IsList l => l -> [Item l]
toList (Seq Text -> [Text])
-> (Namespace -> Seq Text) -> Namespace -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Namespace -> Seq Text
unNamespace

displayNamespace :: Namespace -> Text
displayNamespace :: Namespace -> Text
displayNamespace =
  (Text -> Text) -> Seq Text -> Text
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' Text -> Text
forall a. a -> a
id
    (Seq Text -> Text) -> (Namespace -> Seq Text) -> Namespace -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Seq Text -> Seq Text
forall a. a -> Seq a -> Seq a
Seq.intersperse Text
"."
    (Seq Text -> Seq Text)
-> (Namespace -> Seq Text) -> Namespace -> Seq Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.unNamespace)

-- | Determines how we log location data.
--
-- @since 0.1
data LocStrategy
  = -- | Logs the location with filename, line, col.
    --
    -- @since 0.1
    LocPartial !Loc
  | -- | Logs the location with filename.
    --
    -- @since 0.1
    LocStable !Loc
  | -- | No location logging.
    --
    -- @since 0.1
    LocNone
  deriving stock
    ( -- | @since 0.1
      LocStrategy -> LocStrategy -> Bool
(LocStrategy -> LocStrategy -> Bool)
-> (LocStrategy -> LocStrategy -> Bool) -> Eq LocStrategy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LocStrategy -> LocStrategy -> Bool
== :: LocStrategy -> LocStrategy -> Bool
$c/= :: LocStrategy -> LocStrategy -> Bool
/= :: LocStrategy -> LocStrategy -> Bool
Eq,
      -- | @since 0.1
      (forall x. LocStrategy -> Rep LocStrategy x)
-> (forall x. Rep LocStrategy x -> LocStrategy)
-> Generic LocStrategy
forall x. Rep LocStrategy x -> LocStrategy
forall x. LocStrategy -> Rep LocStrategy x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LocStrategy -> Rep LocStrategy x
from :: forall x. LocStrategy -> Rep LocStrategy x
$cto :: forall x. Rep LocStrategy x -> LocStrategy
to :: forall x. Rep LocStrategy x -> LocStrategy
Generic,
      -- | @since 0.1
      Int -> LocStrategy -> ShowS
[LocStrategy] -> ShowS
LocStrategy -> String
(Int -> LocStrategy -> ShowS)
-> (LocStrategy -> String)
-> ([LocStrategy] -> ShowS)
-> Show LocStrategy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LocStrategy -> ShowS
showsPrec :: Int -> LocStrategy -> ShowS
$cshow :: LocStrategy -> String
show :: LocStrategy -> String
$cshowList :: [LocStrategy] -> ShowS
showList :: [LocStrategy] -> ShowS
Show
    )

-- | Formatter for logs.
--
-- @since 0.1
data LogFormatter = MkLogFormatter
  { -- | How to log the code location.
    --
    -- @since 0.1
    LogFormatter -> LocStrategy
locStrategy :: !LocStrategy,
    -- | If true, append a newline.
    --
    -- @since 0.1
    LogFormatter -> Bool
newline :: !Bool,
    -- | Whether to include the thread's label set by 'Thread.labelThread'.
    -- Falls back to the thread's 'Thread.ThreadId' when the label has not been set.
    --
    -- @since 0.1
    LogFormatter -> Bool
threadLabel :: !Bool,
    -- | Whether to include the timezone in the timestamp.
    --
    -- @since 0.1
    LogFormatter -> Bool
timezone :: !Bool
  }
  deriving stock
    ( -- | @since 0.1
      LogFormatter -> LogFormatter -> Bool
(LogFormatter -> LogFormatter -> Bool)
-> (LogFormatter -> LogFormatter -> Bool) -> Eq LogFormatter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogFormatter -> LogFormatter -> Bool
== :: LogFormatter -> LogFormatter -> Bool
$c/= :: LogFormatter -> LogFormatter -> Bool
/= :: LogFormatter -> LogFormatter -> Bool
Eq,
      -- | @since 0.1
      (forall x. LogFormatter -> Rep LogFormatter x)
-> (forall x. Rep LogFormatter x -> LogFormatter)
-> Generic LogFormatter
forall x. Rep LogFormatter x -> LogFormatter
forall x. LogFormatter -> Rep LogFormatter x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LogFormatter -> Rep LogFormatter x
from :: forall x. LogFormatter -> Rep LogFormatter x
$cto :: forall x. Rep LogFormatter x -> LogFormatter
to :: forall x. Rep LogFormatter x -> LogFormatter
Generic,
      -- | @since 0.1
      Int -> LogFormatter -> ShowS
[LogFormatter] -> ShowS
LogFormatter -> String
(Int -> LogFormatter -> ShowS)
-> (LogFormatter -> String)
-> ([LogFormatter] -> ShowS)
-> Show LogFormatter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogFormatter -> ShowS
showsPrec :: Int -> LogFormatter -> ShowS
$cshow :: LogFormatter -> String
show :: LogFormatter -> String
$cshowList :: [LogFormatter] -> ShowS
showList :: [LogFormatter] -> ShowS
Show
    )

-- | @since 0.1
instance
  (k ~ A_Lens, a ~ LocStrategy, b ~ LocStrategy) =>
  LabelOptic "locStrategy" k LogFormatter LogFormatter a b
  where
  labelOptic :: Optic k NoIx LogFormatter LogFormatter a b
labelOptic = LensVL LogFormatter LogFormatter a b
-> Lens LogFormatter LogFormatter a b
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL LogFormatter LogFormatter a b
 -> Lens LogFormatter LogFormatter a b)
-> LensVL LogFormatter LogFormatter a b
-> Lens LogFormatter LogFormatter a b
forall a b. (a -> b) -> a -> b
$ \a -> f b
f (MkLogFormatter LocStrategy
a1 Bool
a2 Bool
a3 Bool
a4) ->
    (LocStrategy -> LogFormatter) -> f LocStrategy -> f LogFormatter
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (\LocStrategy
b -> LocStrategy -> Bool -> Bool -> Bool -> LogFormatter
MkLogFormatter LocStrategy
b Bool
a2 Bool
a3 Bool
a4)
      (a -> f b
f a
LocStrategy
a1)
  {-# INLINE labelOptic #-}

-- | @since 0.1
instance
  (k ~ A_Lens, a ~ Bool, b ~ Bool) =>
  LabelOptic "newline" k LogFormatter LogFormatter a b
  where
  labelOptic :: Optic k NoIx LogFormatter LogFormatter a b
labelOptic = LensVL LogFormatter LogFormatter a b
-> Lens LogFormatter LogFormatter a b
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL LogFormatter LogFormatter a b
 -> Lens LogFormatter LogFormatter a b)
-> LensVL LogFormatter LogFormatter a b
-> Lens LogFormatter LogFormatter a b
forall a b. (a -> b) -> a -> b
$ \a -> f b
f (MkLogFormatter LocStrategy
a1 Bool
a2 Bool
a3 Bool
a4) ->
    (Bool -> LogFormatter) -> f Bool -> f LogFormatter
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (\Bool
b -> LocStrategy -> Bool -> Bool -> Bool -> LogFormatter
MkLogFormatter LocStrategy
a1 Bool
b Bool
a3 Bool
a4)
      (a -> f b
f a
Bool
a2)
  {-# INLINE labelOptic #-}

-- | @since 0.1
instance
  (k ~ A_Lens, a ~ Bool, b ~ Bool) =>
  LabelOptic "threadLabel" k LogFormatter LogFormatter a b
  where
  labelOptic :: Optic k NoIx LogFormatter LogFormatter a b
labelOptic = LensVL LogFormatter LogFormatter a b
-> Lens LogFormatter LogFormatter a b
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL LogFormatter LogFormatter a b
 -> Lens LogFormatter LogFormatter a b)
-> LensVL LogFormatter LogFormatter a b
-> Lens LogFormatter LogFormatter a b
forall a b. (a -> b) -> a -> b
$ \a -> f b
f (MkLogFormatter LocStrategy
a1 Bool
a2 Bool
a3 Bool
a4) ->
    (Bool -> LogFormatter) -> f Bool -> f LogFormatter
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (\Bool
b -> LocStrategy -> Bool -> Bool -> Bool -> LogFormatter
MkLogFormatter LocStrategy
a1 Bool
a2 Bool
b Bool
a4)
      (a -> f b
f a
Bool
a3)
  {-# INLINE labelOptic #-}

-- | @since 0.1
instance
  (k ~ A_Lens, a ~ Bool, b ~ Bool) =>
  LabelOptic "timezone" k LogFormatter LogFormatter a b
  where
  labelOptic :: Optic k NoIx LogFormatter LogFormatter a b
labelOptic = LensVL LogFormatter LogFormatter a b
-> Lens LogFormatter LogFormatter a b
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL LogFormatter LogFormatter a b
 -> Lens LogFormatter LogFormatter a b)
-> LensVL LogFormatter LogFormatter a b
-> Lens LogFormatter LogFormatter a b
forall a b. (a -> b) -> a -> b
$ \a -> f b
f (MkLogFormatter LocStrategy
a1 Bool
a2 Bool
a3 Bool
a4) ->
    (Bool -> LogFormatter) -> f Bool -> f LogFormatter
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (\Bool
b -> LocStrategy -> Bool -> Bool -> Bool -> LogFormatter
MkLogFormatter LocStrategy
a1 Bool
a2 Bool
a3 Bool
b)
      (a -> f b
f a
Bool
a4)
  {-# INLINE labelOptic #-}

-- | 'LogFormatter' with:
--
-- @
-- 'locStrategy' = 'LocPartial' loc
-- 'newline' = 'True'
-- 'threadLabel' = 'False'
-- 'timezone' = 'False'
-- @
--
-- @since 0.1
defaultLogFormatter :: Loc -> LogFormatter
defaultLogFormatter :: Loc -> LogFormatter
defaultLogFormatter Loc
loc =
  MkLogFormatter
    { locStrategy :: LocStrategy
locStrategy = Loc -> LocStrategy
LocPartial Loc
loc,
      newline :: Bool
newline = Bool
True,
      threadLabel :: Bool
threadLabel = Bool
False,
      timezone :: Bool
timezone = Bool
False
    }

-- | Produces a formatted 'LogStr'.
--
-- @since 0.1
formatLog ::
  ( Concurrent :> es,
    HasCallStack,
    Time :> es,
    ToLogStr msg
  ) =>
  Maybe Namespace ->
  LogFormatter ->
  LogLevel ->
  msg ->
  Eff es LogStr
formatLog :: forall (es :: [Effect]) msg.
(Concurrent :> es, HasCallStack, Time :> es, ToLogStr msg) =>
Maybe Namespace -> LogFormatter -> LogLevel -> msg -> Eff es LogStr
formatLog Maybe Namespace
mNamespace LogFormatter
formatter LogLevel
lvl msg
msg = do
  timestampTxt <- Eff es LogStr
timeFn
  let namespaceTxt = case Maybe Namespace
mNamespace of
        Maybe Namespace
Nothing -> LogStr
""
        Just Namespace
namespace -> LogStr -> LogStr
brackets (LogStr -> LogStr) -> LogStr -> LogStr
forall a b. (a -> b) -> a -> b
$ Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Text -> LogStr) -> Text -> LogStr
forall a b. (a -> b) -> a -> b
$ Namespace -> Text
displayNamespace Namespace
namespace
  threadLbl <-
    if formatter ^. #threadLabel
      then getThreadLabel
      else pure ""
  let locTxt = case LogFormatter
formatter LogFormatter
-> Optic' A_Lens NoIx LogFormatter LocStrategy -> LocStrategy
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx LogFormatter LocStrategy
#locStrategy of
        LocPartial Loc
loc -> (LogStr -> LogStr
brackets (LogStr -> LogStr) -> (Loc -> LogStr) -> Loc -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Builder -> LogStr) -> (Loc -> Builder) -> Loc -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> Builder
partialLoc) Loc
loc
        LocStable Loc
loc -> (LogStr -> LogStr
brackets (LogStr -> LogStr) -> (Loc -> LogStr) -> Loc -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Builder -> LogStr) -> (Loc -> Builder) -> Loc -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> Builder
stableLoc) Loc
loc
        LocStrategy
LocNone -> LogStr
""
      lvlTxt = Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Text -> LogStr) -> Text -> LogStr
forall a b. (a -> b) -> a -> b
$ LogLevel -> Text
showLevel LogLevel
lvl
      msgTxt = msg -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr msg
msg
      newline'
        | LogFormatter
formatter LogFormatter -> Optic' A_Lens NoIx LogFormatter Bool -> Bool
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx LogFormatter Bool
#newline = LogStr
"\n"
        | Bool
otherwise = LogStr
""
      formatted =
        [LogStr] -> LogStr
forall a. Monoid a => [a] -> a
mconcat
          [ LogStr -> LogStr
brackets LogStr
timestampTxt,
            LogStr
threadLbl,
            LogStr
namespaceTxt,
            LogStr
locTxt,
            LogStr -> LogStr
brackets LogStr
lvlTxt,
            LogStr
" ",
            LogStr
msgTxt,
            LogStr
newline'
          ]
  pure formatted
  where
    timeFn :: Eff es LogStr
timeFn
      | LogFormatter
formatter LogFormatter -> Optic' A_Lens NoIx LogFormatter Bool -> Bool
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx LogFormatter Bool
#timezone =
          String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> LogStr) -> Eff es String -> Eff es LogStr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff es String
forall (es :: [Effect]).
(HasCallStack, Time :> es) =>
Eff es String
Time.getSystemZonedTimeString
      | Bool
otherwise =
          String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> LogStr) -> Eff es String -> Eff es LogStr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff es String
forall (es :: [Effect]).
(HasCallStack, Time :> es) =>
Eff es String
Time.getSystemTimeString

{- ORMOLU_DISABLE -}

-- | Retrieves the thread label or thread id, if the former has not been set.
getThreadLabel :: (Concurrent :> es, HasCallStack) => Eff es LogStr
getThreadLabel :: forall (es :: [Effect]).
(Concurrent :> es, HasCallStack) =>
Eff es LogStr
getThreadLabel = do
#if MIN_VERSION_base(4, 18, 0)
  tid <- Eff es ThreadId
forall (es :: [Effect]). (Concurrent :> es) => Eff es ThreadId
CC.myThreadId
  Thread.threadLabel tid <&> \case
    Just String
label -> String -> LogStr
bracketsLogStr String
label
    Maybe String
Nothing -> String -> LogStr
bracketsLogStr (String -> LogStr) -> String -> LogStr
forall a b. (a -> b) -> a -> b
$ ThreadId -> String
forall a. Show a => a -> String
show ThreadId
tid
#else
  bracketsLogStr . show <$> CC.myThreadId
#endif
  where
    bracketsLogStr :: String -> LogStr
bracketsLogStr = LogStr -> LogStr
brackets (LogStr -> LogStr) -> (String -> LogStr) -> String -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr

{- ORMOLU_ENABLE -}

partialLoc :: Loc -> Builder
partialLoc :: Loc -> Builder
partialLoc Loc
loc =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ String -> Builder
forall a. IsString a => String -> a
fromString (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ Optic' A_Lens NoIx Loc String -> Loc -> String
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx Loc String
#loc_filename Loc
loc,
      Builder
":" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Loc -> Builder
mkLine Loc
loc,
      Builder
":" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Loc -> Builder
mkChar Loc
loc
    ]
  where
    mkLine :: Loc -> Builder
mkLine = String -> Builder
forall a. IsString a => String -> a
fromString (String -> Builder) -> (Loc -> String) -> Loc -> Builder
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
. Optic' A_Lens NoIx Loc Int -> Loc -> Int
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Optic A_Lens NoIx Loc Loc CharPos CharPos
#loc_start Optic A_Lens NoIx Loc Loc CharPos CharPos
-> Optic A_Lens NoIx CharPos CharPos Int Int
-> Optic' A_Lens NoIx Loc Int
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 A_Lens NoIx CharPos CharPos Int Int
forall s t a b. Field1 s t a b => Lens s t a b
_1)
    mkChar :: Loc -> Builder
mkChar = String -> Builder
forall a. IsString a => String -> a
fromString (String -> Builder) -> (Loc -> String) -> Loc -> Builder
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
. Optic' A_Lens NoIx Loc Int -> Loc -> Int
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Optic A_Lens NoIx Loc Loc CharPos CharPos
#loc_start Optic A_Lens NoIx Loc Loc CharPos CharPos
-> Optic A_Lens NoIx CharPos CharPos Int Int
-> Optic' A_Lens NoIx Loc Int
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 A_Lens NoIx CharPos CharPos Int Int
forall s t a b. Field2 s t a b => Lens s t a b
_2)

stableLoc :: Loc -> Builder
stableLoc :: Loc -> Builder
stableLoc Loc
loc = String -> Builder
forall a. IsString a => String -> a
fromString (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ Optic' A_Lens NoIx Loc String -> Loc -> String
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx Loc String
#loc_filename Loc
loc

showLevel :: LogLevel -> Text
showLevel :: LogLevel -> Text
showLevel LogLevel
LevelTrace = Text
"Trace"
showLevel LogLevel
LevelDebug = Text
"Debug"
showLevel LogLevel
LevelInfo = Text
"Info"
showLevel LogLevel
LevelWarn = Text
"Warn"
showLevel LogLevel
LevelError = Text
"Error"
showLevel LogLevel
LevelFatal = Text
"Fatal"
showLevel (LevelOther Text
txt) = Text
txt

-- LogStr uses ByteString's Builder internally, so we might as well use it
-- for constants.
brackets :: LogStr -> LogStr
brackets :: LogStr -> LogStr
brackets LogStr
m = Builder -> LogStr
cLogStr Builder
"[" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
m LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> Builder -> LogStr
cLogStr Builder
"]"

cLogStr :: Builder -> LogStr
cLogStr :: Builder -> LogStr
cLogStr = forall msg. ToLogStr msg => msg -> LogStr
toLogStr @Builder

-- | @since 0.1
logStrToBs :: LogStr -> ByteString
logStrToBs :: LogStr -> ByteString
logStrToBs = LogStr -> ByteString
FL.fromLogStr

-- | @since 0.1
logStrToText :: LogStr -> Text
logStrToText :: LogStr -> Text
logStrToText = OnDecodeError -> ByteString -> Text
TEnc.decodeUtf8With OnDecodeError
TEncError.lenientDecode (ByteString -> Text) -> (LogStr -> ByteString) -> LogStr -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> ByteString
FL.fromLogStr

-- | @since 0.1
data LogLevel
  = -- | @since 0.1
    LevelTrace
  | -- | @since 0.1
    LevelDebug
  | -- | @since 0.1
    LevelInfo
  | -- | @since 0.1
    LevelWarn
  | -- | @since 0.1
    LevelError
  | -- | @since 0.1
    LevelFatal
  | -- | @since 0.1
    LevelOther Text
  deriving stock
    ( -- | @since 0.1
      LogLevel -> LogLevel -> Bool
(LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool) -> Eq LogLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogLevel -> LogLevel -> Bool
== :: LogLevel -> LogLevel -> Bool
$c/= :: LogLevel -> LogLevel -> Bool
/= :: LogLevel -> LogLevel -> Bool
Eq,
      -- | @since 0.1
      (forall x. LogLevel -> Rep LogLevel x)
-> (forall x. Rep LogLevel x -> LogLevel) -> Generic LogLevel
forall x. Rep LogLevel x -> LogLevel
forall x. LogLevel -> Rep LogLevel x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LogLevel -> Rep LogLevel x
from :: forall x. LogLevel -> Rep LogLevel x
$cto :: forall x. Rep LogLevel x -> LogLevel
to :: forall x. Rep LogLevel x -> LogLevel
Generic,
      -- | @since 0.1
      Int -> LogLevel -> ShowS
[LogLevel] -> ShowS
LogLevel -> String
(Int -> LogLevel -> ShowS)
-> (LogLevel -> String) -> ([LogLevel] -> ShowS) -> Show LogLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogLevel -> ShowS
showsPrec :: Int -> LogLevel -> ShowS
$cshow :: LogLevel -> String
show :: LogLevel -> String
$cshowList :: [LogLevel] -> ShowS
showList :: [LogLevel] -> ShowS
Show,
      -- | @since 0.1
      ReadPrec [LogLevel]
ReadPrec LogLevel
Int -> ReadS LogLevel
ReadS [LogLevel]
(Int -> ReadS LogLevel)
-> ReadS [LogLevel]
-> ReadPrec LogLevel
-> ReadPrec [LogLevel]
-> Read LogLevel
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS LogLevel
readsPrec :: Int -> ReadS LogLevel
$creadList :: ReadS [LogLevel]
readList :: ReadS [LogLevel]
$creadPrec :: ReadPrec LogLevel
readPrec :: ReadPrec LogLevel
$creadListPrec :: ReadPrec [LogLevel]
readListPrec :: ReadPrec [LogLevel]
Read,
      -- | @since 0.1
      Eq LogLevel
Eq LogLevel =>
(LogLevel -> LogLevel -> Ordering)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> LogLevel)
-> (LogLevel -> LogLevel -> LogLevel)
-> Ord LogLevel
LogLevel -> LogLevel -> Bool
LogLevel -> LogLevel -> Ordering
LogLevel -> LogLevel -> LogLevel
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 :: LogLevel -> LogLevel -> Ordering
compare :: LogLevel -> LogLevel -> Ordering
$c< :: LogLevel -> LogLevel -> Bool
< :: LogLevel -> LogLevel -> Bool
$c<= :: LogLevel -> LogLevel -> Bool
<= :: LogLevel -> LogLevel -> Bool
$c> :: LogLevel -> LogLevel -> Bool
> :: LogLevel -> LogLevel -> Bool
$c>= :: LogLevel -> LogLevel -> Bool
>= :: LogLevel -> LogLevel -> Bool
$cmax :: LogLevel -> LogLevel -> LogLevel
max :: LogLevel -> LogLevel -> LogLevel
$cmin :: LogLevel -> LogLevel -> LogLevel
min :: LogLevel -> LogLevel -> LogLevel
Ord
    )
  deriving anyclass
    ( -- | @since 0.1
      LogLevel -> ()
(LogLevel -> ()) -> NFData LogLevel
forall a. (a -> ()) -> NFData a
$crnf :: LogLevel -> ()
rnf :: LogLevel -> ()
NFData
    )

-- | @since 0.1
instance Lift LogLevel where
  lift :: forall (m :: * -> *). Quote m => LogLevel -> m Exp
lift LogLevel
LevelTrace = [|LevelTrace|]
  lift LogLevel
LevelDebug = [|LevelDebug|]
  lift LogLevel
LevelInfo = [|LevelInfo|]
  lift LogLevel
LevelWarn = [|LevelWarn|]
  lift LogLevel
LevelError = [|LevelError|]
  lift LogLevel
LevelFatal = [|LevelFatal|]
  lift (LevelOther Text
x) = [|LevelOther $ pack $(String -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
x)|]

  liftTyped :: forall (m :: * -> *). Quote m => LogLevel -> Code m LogLevel
liftTyped LogLevel
LevelTrace = [||LogLevel
LevelTrace||]
  liftTyped LogLevel
LevelDebug = [||LogLevel
LevelDebug||]
  liftTyped LogLevel
LevelInfo = [||LogLevel
LevelInfo||]
  liftTyped LogLevel
LevelWarn = [||LogLevel
LevelWarn||]
  liftTyped LogLevel
LevelError = [||LogLevel
LevelError||]
  liftTyped LogLevel
LevelFatal = [||LogLevel
LevelFatal||]
  liftTyped (LevelOther Text
x) = [||Text -> LogLevel
LevelOther (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack $$(String -> Code m String
forall t (m :: * -> *). (Lift t, Quote m) => t -> Code m t
forall (m :: * -> *). Quote m => String -> Code m String
liftTyped (String -> Code m String) -> String -> Code m String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
x)||]