{- HLINT ignore "Use let" -}

module HaskellWorks.Polysemy.Log
  ( interpretDataLogNoop,
    interpretDataLogLocalNoop,
    interpretDataLogToJsonStdout,
    logEntryToJson,
    logMessageToJson,

    annotateCs,
    logCs,

    setLogLevelFromEnv,
  ) where

import           Data.Aeson
import qualified Data.Aeson                               as J
import qualified Data.ByteString.Lazy                     as LBS
import qualified Data.Text                                as T
import qualified Data.Text.Encoding                       as T
import           Data.Time
import qualified GHC.Stack                                as GHC
import           HaskellWorks.Polysemy.System.Environment
import           HaskellWorks.Prelude
import           Polysemy
import           Polysemy.Internal.Tactics                (liftT)
import           Polysemy.Log
import qualified Polysemy.Log.Effect.DataLog              as Log
import           Polysemy.Time
import qualified Polysemy.Time                            as Time

interpretDataLogNoop :: forall a r. ()
  => InterpreterFor (DataLog a) r
interpretDataLogNoop :: forall a (r :: [Effect]) a. Sem (DataLog a : r) a -> Sem r a
interpretDataLogNoop =
  (a -> a) -> InterpreterFor (DataLog a) r
forall a (r :: [Effect]). (a -> a) -> InterpreterFor (DataLog a) r
interpretDataLogLocalNoop a -> a
forall a. a -> a
id

interpretDataLogLocalNoop :: forall a r. ()
  => (a -> a)
  -> InterpreterFor (DataLog a) r
interpretDataLogLocalNoop :: forall a (r :: [Effect]). (a -> a) -> InterpreterFor (DataLog a) r
interpretDataLogLocalNoop a -> a
context =
  (forall (rInitial :: [Effect]) x.
 DataLog a (Sem rInitial) x
 -> Tactical (DataLog a) (Sem rInitial) r x)
-> Sem (DataLog a : r) a -> Sem r a
forall (e :: Effect) (r :: [Effect]) a.
(forall (rInitial :: [Effect]) x.
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH \case
    Log.DataLog a
_ ->
      Sem r x -> Sem (WithTactics (DataLog a) f (Sem rInitial) r) (f x)
forall (m :: * -> *) (f :: * -> *) (r :: [Effect]) (e :: Effect) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT (x -> Sem r x
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    Log.Local a -> a
f Sem rInitial x
ma ->
      Sem r (f x)
-> Sem (WithTactics (DataLog a) f (Sem rInitial) r) (f x)
forall (e :: Effect) (r :: [Effect]) a. Sem r a -> Sem (e : r) a
raise (Sem r (f x)
 -> Sem (WithTactics (DataLog a) f (Sem rInitial) r) (f x))
-> (Sem (DataLog a : r) (f x) -> Sem r (f x))
-> Sem (DataLog a : r) (f x)
-> Sem (WithTactics (DataLog a) f (Sem rInitial) r) (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> InterpreterFor (DataLog a) r
forall a (r :: [Effect]). (a -> a) -> InterpreterFor (DataLog a) r
interpretDataLogLocalNoop (a -> a
f (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
context) (Sem (DataLog a : r) (f x)
 -> Sem (WithTactics (DataLog a) f (Sem rInitial) r) (f x))
-> Sem
     (WithTactics (DataLog a) f (Sem rInitial) r)
     (Sem (DataLog a : r) (f x))
-> Sem (WithTactics (DataLog a) f (Sem rInitial) r) (f x)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sem rInitial x
-> Sem
     (WithTactics (DataLog a) f (Sem rInitial) r)
     (Sem (DataLog a : r) (f x))
forall (m :: * -> *) a (e :: Effect) (f :: * -> *) (r :: [Effect]).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT Sem rInitial x
ma
{-# inline interpretDataLogLocalNoop #-}

interpretDataLogToJsonStdout :: forall e a r. ()
  => Member (Embed IO) r
  => (e -> J.Value)
  -> Sem (DataLog e : r) a
  -> Sem r a
interpretDataLogToJsonStdout :: forall e a (r :: [Effect]).
Member (Embed IO) r =>
(e -> Value) -> Sem (DataLog e : r) a -> Sem r a
interpretDataLogToJsonStdout e -> Value
toJson =
  (e -> Text) -> InterpreterFor (DataLog e) r
forall (r :: [Effect]) a.
Member (Embed IO) r =>
(a -> Text) -> InterpreterFor (DataLog a) r
interpretDataLogStdoutWith (ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> (e -> ByteString) -> e -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> (e -> ByteString) -> e -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode (Value -> ByteString) -> (e -> Value) -> e -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Value
toJson)

-- | Log a datalog message with the given severity and provided callstack.
annotateCs :: forall a r. ()
  => Member GhcTime r
  => CallStack
  -> a
  -> Sem r (LogEntry a)
annotateCs :: forall a (r :: [Effect]).
Member GhcTime r =>
CallStack -> a -> Sem r (LogEntry a)
annotateCs CallStack
cs a
msg = do
  UTCTime
time <- forall t d (r :: [Effect]). Member (Time t d) r => Sem r t
Time.now @UTCTime @Day
  LogEntry a -> Sem r (LogEntry a)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> UTCTime -> CallStack -> LogEntry a
forall a. a -> UTCTime -> CallStack -> LogEntry a
LogEntry a
msg UTCTime
time CallStack
cs)

-- | Log a text message with the given severity and provided callstack.
logCs :: ()
  => Members [Logger, GhcTime] r
  => CallStack
  -> Severity
  -> Text
  -> Sem r ()
logCs :: forall (r :: [Effect]).
Members '[Logger, GhcTime] r =>
CallStack -> Severity -> Text -> Sem r ()
logCs CallStack
cs Severity
severity Text
message =
  (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    DataLog (LogEntry LogMessage) (Sem r) () -> Sem r ()
forall (e :: Effect) (r :: [Effect]) a.
Member e r =>
e (Sem r) a -> Sem r a
send (DataLog (LogEntry LogMessage) (Sem r) () -> Sem r ())
-> (LogEntry LogMessage
    -> DataLog (LogEntry LogMessage) (Sem r) ())
-> LogEntry LogMessage
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogEntry LogMessage -> DataLog (LogEntry LogMessage) (Sem r) ()
forall a (b :: * -> *). a -> DataLog a b ()
DataLog (LogEntry LogMessage -> Sem r ())
-> Sem r (LogEntry LogMessage) -> Sem r ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CallStack -> LogMessage -> Sem r (LogEntry LogMessage)
forall a (r :: [Effect]).
Member GhcTime r =>
CallStack -> a -> Sem r (LogEntry a)
annotateCs CallStack
cs (Severity -> Text -> LogMessage
LogMessage Severity
severity Text
message)
{-# inline logCs #-}

logEntryToJson :: forall a. ()
  => (a -> Value)
  -> LogEntry a
  -> Value
logEntryToJson :: forall a. (a -> Value) -> LogEntry a -> Value
logEntryToJson a -> Value
aToJson (LogEntry a
value UTCTime
time CallStack
callstack) =
    [Pair] -> Value
object
      [ Key
"time" Key -> UTCTime -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTCTime
time
      , Key
"data" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= a -> Value
aToJson a
value
      , Key
"callstack" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ((String, SrcLoc) -> Value) -> [(String, SrcLoc)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, SrcLoc) -> Value
callsiteToJson (CallStack -> [(String, SrcLoc)]
GHC.getCallStack CallStack
callstack)
      ]
    where
      callsiteToJson :: ([Char], GHC.SrcLoc) -> Value
      callsiteToJson :: (String, SrcLoc) -> Value
callsiteToJson (String
caller, SrcLoc
srcLoc) =
        [Pair] -> Value
object
          [ Key
"caller"    Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
caller
          , Key
"package"   Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SrcLoc -> String
GHC.srcLocPackage SrcLoc
srcLoc
          , Key
"module"    Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SrcLoc -> String
GHC.srcLocModule SrcLoc
srcLoc
          , Key
"file"      Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SrcLoc -> String
GHC.srcLocFile SrcLoc
srcLoc
          , Key
"startLine" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SrcLoc -> Int
GHC.srcLocStartLine SrcLoc
srcLoc
          , Key
"startCol"  Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SrcLoc -> Int
GHC.srcLocStartCol SrcLoc
srcLoc
          , Key
"endLine"   Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SrcLoc -> Int
GHC.srcLocEndLine SrcLoc
srcLoc
          , Key
"endCol"    Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SrcLoc -> Int
GHC.srcLocEndCol SrcLoc
srcLoc
          ]

logMessageToJson :: LogMessage -> Value
logMessageToJson :: LogMessage -> Value
logMessageToJson (LogMessage Severity
severity Text
message) =
    [Pair] -> Value
object
      [ Key
"severity" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Severity -> String
forall a. Show a => a -> String
show Severity
severity
      , Key
"message"  Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
message
      ]

-- | Set the log level for the duration of the computation to the severity provided in the
-- environment variable of the given name or else the default severity for the duration of
-- the computation.
--
-- Values for the log level are case-insensitive and can be one of the following:
--
--   * trace
--   * debug
--   * info
--   * warn
--   * error
--   * crit
setLogLevelFromEnv :: ()
  => HasCallStack
  => Member (DataLog (LogEntry LogMessage)) r
  => Member (Embed IO) r
  => String
  -> Severity
  -> Sem r a
  -> Sem r a
setLogLevelFromEnv :: forall (r :: [Effect]) a.
(HasCallStack, Member Logger r, Member (Embed IO) r) =>
String -> Severity -> Sem r a -> Sem r a
setLogLevelFromEnv String
envVarName Severity
defaultSeverity Sem r a
f = do
  Maybe String
maybeSeverityString <- String -> Sem r (Maybe String)
forall (r :: [Effect]).
(HasCallStack, Member (Embed IO) r) =>
String -> Sem r (Maybe String)
lookupEnv String
envVarName

  let maybeSeverity :: Maybe Severity
maybeSeverity = Maybe String
maybeSeverityString Maybe String -> (String -> Maybe Severity) -> Maybe Severity
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Severity
parseSeverity (Text -> Maybe Severity)
-> (String -> Text) -> String -> Maybe Severity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

  Maybe Severity -> Sem r a -> Sem r a
forall (r :: [Effect]) a.
Member Logger r =>
Maybe Severity -> Sem r a -> Sem r a
setLogLevel (Maybe Severity
maybeSeverity Maybe Severity -> Maybe Severity -> Maybe Severity
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
defaultSeverity) Sem r a
f