module Polysemy.Http.Log where

import Colog.Core (LogAction(LogAction), Severity, cmapM)
import qualified Colog.Core as Severity (Severity(Error, Info, Debug, Warning))
import qualified Colog.Polysemy as Colog (Log, log)
import Colog.Polysemy.Effect (runLogAction)
import qualified Data.ByteString.Char8 as BS8
import GHC.Stack (SrcLoc(SrcLoc), popCallStack, srcLocModule, srcLocStartLine)
import System.Console.ANSI (Color (..), ColorIntensity (Vivid), ConsoleLayer (Foreground), SGR (..), setSGRCode)

import Polysemy.Http.Data.Log (Log(..))

data Message =
  Message {
    Message -> Severity
msgSeverity :: !Severity,
    Message -> CallStack
msgStack :: !CallStack,
    Message -> Text
msgText :: !Text
  }

showSeverity :: Severity -> Text
showSeverity :: Severity -> Text
showSeverity = \case
  Severity.Debug -> Color -> Text -> Text
color Color
Green "[Debug]   "
  Severity.Info -> Color -> Text -> Text
color Color
Blue "[Info]    "
  Severity.Warning -> Color -> Text -> Text
color Color
Yellow "[Warning] "
  Severity.Error -> Color -> Text -> Text
color Color
Red "[Error]   "
 where
   color :: Color -> Text -> Text
   color :: Color -> Text -> Text
color c :: Color
c txt :: Text
txt =
     String -> Text
forall a. ToText a => a -> Text
toText ([SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
c]) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
     Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
     String -> Text
forall a. ToText a => a -> Text
toText ([SGR] -> String
setSGRCode [SGR
Reset])

showSourceLoc :: CallStack -> Text
showSourceLoc :: CallStack -> Text
showSourceLoc cs :: CallStack
cs =
  Text -> Text
forall a. (Semigroup a, IsString a) => a -> a
square Text
showCallStack
  where
    showCallStack :: Text
    showCallStack :: Text
showCallStack = case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs of
      [] -> "<unknown loc>"
      [(name :: String
name, loc :: SrcLoc
loc)] -> String -> SrcLoc -> Text
showLoc String
name SrcLoc
loc
      (_, loc :: SrcLoc
loc) : (callerName :: String
callerName, _) : _ -> String -> SrcLoc -> Text
showLoc String
callerName SrcLoc
loc
    square :: a -> a
square t :: a
t = "[" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
t a -> a -> a
forall a. Semigroup a => a -> a -> a
<> "] "
    showLoc :: String -> SrcLoc -> Text
    showLoc :: String -> SrcLoc -> Text
showLoc name :: String
name SrcLoc{..} =
      String -> Text
forall a. ToText a => a -> Text
toText String
srcLocModule Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText String
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
srcLocStartLine

fmtRichMessageDefault :: Message -> IO Text
fmtRichMessageDefault :: Message -> IO Text
fmtRichMessageDefault =
  Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> (Message -> Text) -> Message -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Text
formatRichMessage
  where
    formatRichMessage :: Message -> Text
    formatRichMessage :: Message -> Text
formatRichMessage Message{..} =
        Severity -> Text
showSeverity Severity
msgSeverity
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CallStack -> Text
showSourceLoc CallStack
msgStack
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msgText

logByteStringStdout :: LogAction IO ByteString
logByteStringStdout :: LogAction IO ByteString
logByteStringStdout = (ByteString -> IO ()) -> LogAction IO ByteString
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ByteString -> IO ()
BS8.putStrLn

richMessageAction :: LogAction IO Message
richMessageAction :: LogAction IO Message
richMessageAction =
    (Message -> IO ByteString)
-> LogAction IO ByteString -> LogAction IO Message
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LogAction m b -> LogAction m a
cmapM ((Text -> ByteString) -> IO Text -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (IO Text -> IO ByteString)
-> (Message -> IO Text) -> Message -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> IO Text
fmtRichMessageDefault) LogAction IO ByteString
logByteStringStdout
{-# INLINE richMessageAction #-}

log ::
  HasCallStack =>
  Member (Colog.Log Message) r =>
  Severity ->
  Text ->
  Sem r ()
log :: Severity -> Text -> Sem r ()
log severity :: Severity
severity text :: Text
text =
  Message -> Sem r ()
forall msg (r :: [(* -> *) -> * -> *]).
Member (Log msg) r =>
msg -> Sem r ()
Colog.log (Severity -> CallStack -> Text -> Message
Message Severity
severity CallStack
stack Text
text)
  where
    stack :: CallStack
stack =
      CallStack -> CallStack
popCallStack (CallStack -> CallStack
popCallStack CallStack
HasCallStack => CallStack
callStack)

-- |No-op interpreter for 'Log'
interpretLogNull ::
  InterpreterFor Log r
interpretLogNull :: Sem (Log : r) a -> Sem r a
interpretLogNull =
  (forall x (rInitial :: [(* -> *) -> * -> *]).
 Log (Sem rInitial) x -> Sem r x)
-> Sem (Log : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: [(* -> *) -> * -> *]).
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
    Debug _ -> Sem r x
forall (f :: * -> *). Applicative f => f ()
unit
    Info _ -> Sem r x
forall (f :: * -> *). Applicative f => f ()
unit
    Warn _ -> Sem r x
forall (f :: * -> *). Applicative f => f ()
unit
    Error _ -> Sem r x
forall (f :: * -> *). Applicative f => f ()
unit
    ErrorPlus _ _ -> Sem r x
forall (f :: * -> *). Applicative f => f ()
unit
{-# INLINE interpretLogNull #-}

runCologStdout ::
  Member (Embed IO) r =>
  InterpreterFor (Colog.Log Message) r
runCologStdout :: InterpreterFor (Log Message) r
runCologStdout =
  LogAction IO Message -> Sem (Log Message : r) a -> Sem r a
forall (m :: * -> *) msg (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
LogAction m msg -> Sem (Log msg : r) a -> Sem r a
runLogAction @IO LogAction IO Message
richMessageAction
{-# INLINE runCologStdout #-}

toColog ::
  HasCallStack =>
  Member (Colog.Log Message) r =>
  Sem (Log : r) a ->
  Sem r a
toColog :: Sem (Log : r) a -> Sem r a
toColog =
  (forall x (rInitial :: [(* -> *) -> * -> *]).
 Log (Sem rInitial) x -> Sem r x)
-> Sem (Log : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: [(* -> *) -> * -> *]).
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
    Debug msg ->
      Severity -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
(HasCallStack, Member (Log Message) r) =>
Severity -> Text -> Sem r ()
log Severity
Severity.Debug Text
msg
    Info msg ->
      Severity -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
(HasCallStack, Member (Log Message) r) =>
Severity -> Text -> Sem r ()
log Severity
Severity.Info Text
msg
    Warn msg ->
      Severity -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
(HasCallStack, Member (Log Message) r) =>
Severity -> Text -> Sem r ()
log Severity
Severity.Warning Text
msg
    Error msg ->
      Severity -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
(HasCallStack, Member (Log Message) r) =>
Severity -> Text -> Sem r ()
log Severity
Severity.Error Text
msg
    ErrorPlus msg detailed ->
      Severity -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
(HasCallStack, Member (Log Message) r) =>
Severity -> Text -> Sem r ()
log Severity
Severity.Error Text
msg Sem r () -> Sem r () -> Sem r ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Sem r ()) -> t Text -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Severity -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
(HasCallStack, Member (Log Message) r) =>
Severity -> Text -> Sem r ()
log Severity
Severity.Debug) t Text
detailed
{-# INLINE toColog #-}

-- |Default interpreter for 'Log' that uses 'Colog.Log' to print to stdout
interpretLogStdout ::
  Member (Embed IO) r =>
  Sem (Log : r) a ->
  Sem r a
interpretLogStdout :: Sem (Log : r) a -> Sem r a
interpretLogStdout =
  Sem (Log Message : r) a -> Sem r a
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
InterpreterFor (Log Message) r
runCologStdout (Sem (Log Message : r) a -> Sem r a)
-> (Sem (Log : r) a -> Sem (Log Message : r) a)
-> Sem (Log : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Log : Log Message : r) a -> Sem (Log Message : r) a
forall (r :: [(* -> *) -> * -> *]) a.
(HasCallStack, Member (Log Message) r) =>
Sem (Log : r) a -> Sem r a
toColog (Sem (Log : Log Message : r) a -> Sem (Log Message : r) a)
-> (Sem (Log : r) a -> Sem (Log : Log Message : r) a)
-> Sem (Log : r) a
-> Sem (Log Message : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Log : r) a -> Sem (Log : Log Message : r) a
forall (e2 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder
{-# INLINE interpretLogStdout #-}