{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

{- HLINT ignore "Use let" -}

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

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

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 :: ()
  => Member (Embed IO) r
  => (e -> J.Value)
  -> Sem (DataLog e : r) a
  -> Sem r a
interpretDataLogToJsonStdout :: forall (r :: [Effect]) e a.
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)

logEntryToJson :: (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
      ]