module Ribosome.Host.Interpreter.Log where

import qualified Data.Text as Text
import Exon (exon)
import qualified Log
import Log (
  Log (Log),
  LogMessage (LogMessage),
  Severity (Warn),
  dataLog,
  formatLogEntry,
  interceptDataLogConc,
  interpretLogDataLogConc,
  interpretLogNull,
  setLogLevel,
  )
import Path (Abs, File, Path, toFilePath)
import Polysemy.Chronos (ChronosTime)
import Polysemy.Log (interpretLogStderrLevelConc)
import Polysemy.Log.Handle (interpretDataLogHandleWith)
import Polysemy.Log.Log (interpretDataLog)
import System.IO (Handle, IOMode (AppendMode), hClose, openFile)

import Ribosome.Host.Api.Effect (nvimEcho)
import Ribosome.Host.Class.Msgpack.Encode (toMsgpack)
import qualified Ribosome.Host.Data.HostConfig as HostConfig
import Ribosome.Host.Data.HostConfig (LogConfig (LogConfig))
import Ribosome.Host.Data.Report (LogReport (LogReport), Report (Report), prefixReportContext')
import Ribosome.Host.Effect.Log (FileLog, StderrLog, fileLog, stderrLog)
import qualified Ribosome.Host.Effect.Reports as Reports
import Ribosome.Host.Effect.Reports (Reports)
import Ribosome.Host.Effect.Rpc (Rpc)
import Ribosome.Host.Effect.UserError (UserError, userError)

echoError ::
  Show e =>
  Members [Rpc !! e, UserError, Log] r =>
  Severity ->
  Text ->
  Severity ->
  Sem r ()
echoError :: forall e (r :: EffectRow).
(Show e, Members '[Rpc !! e, UserError, Log] r) =>
Severity -> Text -> Severity -> Sem r ()
echoError Severity
minSeverity Text
err Severity
severity | Severity
severity Severity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
>= Severity
minSeverity =
  Text -> Severity -> Sem r (Maybe [Text])
forall (r :: EffectRow).
Member UserError r =>
Text -> Severity -> Sem r (Maybe [Text])
userError Text
err Severity
severity Sem r (Maybe [Text]) -> (Maybe [Text] -> Sem r ()) -> Sem r ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Text] -> Sem r ()) -> Maybe [Text] -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \ [Text]
msg ->
    [Object] -> Bool -> Map Text Object -> Sem (Rpc : r) ()
forall (r :: EffectRow).
Member Rpc r =>
[Object] -> Bool -> Map Text Object -> Sem r ()
nvimEcho [forall a. MsgpackEncode a => a -> Object
toMsgpack @[_] [Text]
msg] Bool
True Map Text Object
forall a. Monoid a => a
mempty Sem (Rpc : r) () -> (e -> Sem r ()) -> Sem r ()
forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member (Resumable err eff) r =>
Sem (eff : r) a -> (err -> Sem r a) -> Sem r a
!! \ e
e' ->
      Text -> Sem r ()
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.error [exon|Couldn't echo handler error: #{show e'}|]
echoError Severity
_ Text
_ Severity
_ =
  Sem r ()
forall (f :: * -> *). Applicative f => f ()
unit

logLogReport ::
  Show e =>
  Members [Rpc !! e, Reports, UserError, Log] r =>
  Severity ->
  LogReport ->
  Sem r ()
logLogReport :: forall e (r :: EffectRow).
(Show e, Members '[Rpc !! e, Reports, UserError, Log] r) =>
Severity -> LogReport -> Sem r ()
logLogReport Severity
minSeverity (LogReport msg :: Report
msg@(Report Text
user [Text]
log Severity
severity) Bool
echo Bool
store ReportContext
context) =
  (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    Severity -> Text -> Sem r ()
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Severity -> Text -> Sem r ()
Log.log Severity
severity (Text -> [Text] -> Text
Text.intercalate Text
"\n" (Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (ReportContext -> Maybe Text
prefixReportContext' ReportContext
context) [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
log))
    Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
store (ReportContext -> Report -> Sem r ()
forall (r :: EffectRow).
Member Reports r =>
ReportContext -> Report -> Sem r ()
Reports.storeReport ReportContext
context Report
msg)
    Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
echo (Severity -> Text -> Severity -> Sem r ()
forall e (r :: EffectRow).
(Show e, Members '[Rpc !! e, UserError, Log] r) =>
Severity -> Text -> Severity -> Sem r ()
echoError Severity
minSeverity Text
user Severity
severity)

interpretDataLogRpc ::
  Show e =>
  Members [Reader LogConfig, Rpc !! e, Reports, UserError, Log, Resource, Race, Async, Embed IO] r =>
  InterpreterFor (DataLog LogReport) r
interpretDataLogRpc :: forall e (r :: EffectRow).
(Show e,
 Members
   '[Reader LogConfig, Rpc !! e, Reports, UserError, Log, Resource,
     Race, Async, Embed IO]
   r) =>
InterpreterFor (DataLog LogReport) r
interpretDataLogRpc Sem (DataLog LogReport : r) a
sem = do
  LogConfig {Bool
Maybe (Path Abs File)
Severity
$sel:dataLogConc:LogConfig :: LogConfig -> Bool
$sel:logLevelFile:LogConfig :: LogConfig -> Severity
$sel:logLevelStderr:LogConfig :: LogConfig -> Severity
$sel:logLevelEcho:LogConfig :: LogConfig -> Severity
$sel:logFile:LogConfig :: LogConfig -> Maybe (Path Abs File)
dataLogConc :: Bool
logLevelFile :: Severity
logLevelStderr :: Severity
logLevelEcho :: Severity
logFile :: Maybe (Path Abs File)
..} <- Sem r LogConfig
forall i (r :: EffectRow). Member (Reader i) r => Sem r i
ask
  (LogReport -> Sem r ()) -> InterpreterFor (DataLog LogReport) r
forall a (r :: EffectRow).
(a -> Sem r ()) -> InterpreterFor (DataLog a) r
interpretDataLog (Severity -> LogReport -> Sem r ()
forall e (r :: EffectRow).
(Show e, Members '[Rpc !! e, Reports, UserError, Log] r) =>
Severity -> LogReport -> Sem r ()
logLogReport Severity
logLevelEcho) ((if Bool
dataLogConc then Int
-> Sem (DataLog LogReport : r) a -> Sem (DataLog LogReport : r) a
forall msg (r :: EffectRow) a.
Members '[DataLog msg, Resource, Async, Race, Embed IO] r =>
Int -> Sem r a -> Sem r a
interceptDataLogConc Int
64 else Sem (DataLog LogReport : r) a -> Sem (DataLog LogReport : r) a
forall a. a -> a
id) Sem (DataLog LogReport : r) a
sem)

interpretLogRpc ::
  Members [Log, DataLog LogReport] r =>
  InterpreterFor Log r
interpretLogRpc :: forall (r :: EffectRow).
Members '[Log, DataLog LogReport] r =>
InterpreterFor Log r
interpretLogRpc =
  (forall (rInitial :: EffectRow) x. Log (Sem rInitial) x -> Sem r x)
-> Sem (Log : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
    Log (LogMessage Severity
severity Text
msg) -> do
      LogReport -> Sem r ()
forall a (r :: EffectRow). Member (DataLog a) r => a -> Sem r ()
dataLog (Report -> Bool -> Bool -> ReportContext -> LogReport
LogReport (HasCallStack => Text -> [Text] -> Severity -> Report
Text -> [Text] -> Severity -> Report
Report Text
msg [Text
Item [Text]
msg] Severity
severity) Bool
True (Severity
severity Severity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
>= Severity
Warn) ReportContext
forall a. Monoid a => a
mempty)

interpretLogStderrFile ::
  Members [StderrLog, FileLog] r =>
  InterpreterFor Log r
interpretLogStderrFile :: forall (r :: EffectRow).
Members '[StderrLog, FileLog] r =>
InterpreterFor Log r
interpretLogStderrFile =
  (forall (rInitial :: EffectRow) x. Log (Sem rInitial) x -> Sem r x)
-> Sem (Log : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
    Log LogMessage
m ->
      Sem (Log : r) () -> Sem r ()
forall (r :: EffectRow). Member FileLog r => InterpreterFor Log r
fileLog (Log (Sem (Log : r)) () -> Sem (Log : r) ()
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member e r =>
e (Sem r) a -> Sem r a
send (LogMessage -> Log (Sem (Log : r)) ()
forall (a :: * -> *). HasCallStack => LogMessage -> Log a ()
Log LogMessage
m)) Sem r () -> Sem r () -> Sem r ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Sem (Log : r) () -> Sem r ()
forall (r :: EffectRow). Member StderrLog r => InterpreterFor Log r
stderrLog (Log (Sem (Log : r)) () -> Sem (Log : r) ()
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member e r =>
e (Sem r) a -> Sem r a
send (LogMessage -> Log (Sem (Log : r)) ()
forall (a :: * -> *). HasCallStack => LogMessage -> Log a ()
Log LogMessage
m))

interpretLogHandleLevel ::
  Members [Resource, ChronosTime, Race, Async, Embed IO] r =>
  Handle ->
  Maybe Severity ->
  InterpreterFor Log r
interpretLogHandleLevel :: forall (r :: EffectRow).
Members '[Resource, ChronosTime, Race, Async, Embed IO] r =>
Handle -> Maybe Severity -> InterpreterFor Log r
interpretLogHandleLevel Handle
handle Maybe Severity
level =
  Handle
-> (LogEntry LogMessage -> Text)
-> InterpreterFor (DataLog (LogEntry LogMessage)) r
forall (r :: EffectRow) a.
Member (Embed IO) r =>
Handle -> (a -> Text) -> InterpreterFor (DataLog a) r
interpretDataLogHandleWith Handle
handle LogEntry LogMessage -> Text
formatLogEntry (Sem (DataLog (LogEntry LogMessage) : r) a -> Sem r a)
-> (Sem (Log : r) a -> Sem (DataLog (LogEntry LogMessage) : r) a)
-> Sem (Log : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Maybe Severity
-> Sem (DataLog (LogEntry LogMessage) : r) a
-> Sem (DataLog (LogEntry LogMessage) : r) a
forall (r :: EffectRow) a.
Member (DataLog (LogEntry LogMessage)) r =>
Maybe Severity -> Sem r a -> Sem r a
setLogLevel Maybe Severity
level (Sem (DataLog (LogEntry LogMessage) : r) a
 -> Sem (DataLog (LogEntry LogMessage) : r) a)
-> (Sem (Log : r) a -> Sem (DataLog (LogEntry LogMessage) : r) a)
-> Sem (Log : r) a
-> Sem (DataLog (LogEntry LogMessage) : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> InterpreterFor Log (DataLog (LogEntry LogMessage) : r)
forall (r :: EffectRow).
Members
  '[DataLog (LogEntry LogMessage), Resource, Async, Race, Embed IO]
  r =>
Int -> InterpreterFor Log r
interpretLogDataLogConc Int
64 (Sem (Log : DataLog (LogEntry LogMessage) : r) a
 -> Sem (DataLog (LogEntry LogMessage) : r) a)
-> (Sem (Log : r) a
    -> Sem (Log : DataLog (LogEntry LogMessage) : r) a)
-> Sem (Log : r) a
-> Sem (DataLog (LogEntry LogMessage) : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem (Log : r) a -> Sem (Log : DataLog (LogEntry LogMessage) : r) a
forall (e2 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder
{-# inline interpretLogHandleLevel #-}

interpretLogFileLevel ::
  Members [Resource, ChronosTime, Race, Async, Embed IO] r =>
  Maybe Severity ->
  Path Abs File ->
  InterpreterFor Log r
interpretLogFileLevel :: forall (r :: EffectRow).
Members '[Resource, ChronosTime, Race, Async, Embed IO] r =>
Maybe Severity -> Path Abs File -> InterpreterFor Log r
interpretLogFileLevel Maybe Severity
level Path Abs File
path Sem (Log : r) a
sem =
  Sem r Handle
-> (Handle -> Sem r ()) -> (Handle -> Sem r a) -> Sem r a
forall (r :: EffectRow) a c b.
Member Resource r =>
Sem r a -> (a -> Sem r c) -> (a -> Sem r b) -> Sem r b
bracket Sem r Handle
acquire (IO () -> Sem r ()
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem r ()) -> (Handle -> IO ()) -> Handle -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO ()
hClose) \ Handle
handle ->
    Handle -> Maybe Severity -> InterpreterFor Log r
forall (r :: EffectRow).
Members '[Resource, ChronosTime, Race, Async, Embed IO] r =>
Handle -> Maybe Severity -> InterpreterFor Log r
interpretLogHandleLevel Handle
handle Maybe Severity
level Sem (Log : r) a
sem
  where
    acquire :: Sem r Handle
acquire =
      IO Handle -> Sem r Handle
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (String -> IOMode -> IO Handle
openFile (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
path) IOMode
AppendMode)
{-# inline interpretLogFileLevel #-}

interpretLogs ::
  Members [Reader LogConfig, Resource, ChronosTime, Race, Async, Embed IO] r =>
  InterpretersFor [StderrLog, FileLog] r
interpretLogs :: forall (r :: EffectRow).
Members
  '[Reader LogConfig, Resource, ChronosTime, Race, Async, Embed IO]
  r =>
InterpretersFor '[StderrLog, FileLog] r
interpretLogs Sem (Append '[StderrLog, FileLog] r) a
sem =
  Sem r LogConfig
forall i (r :: EffectRow). Member (Reader i) r => Sem r i
ask Sem r LogConfig -> (LogConfig -> Sem r a) -> Sem r a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ LogConfig {Bool
Maybe (Path Abs File)
Severity
dataLogConc :: Bool
logLevelFile :: Severity
logLevelStderr :: Severity
logLevelEcho :: Severity
logFile :: Maybe (Path Abs File)
$sel:dataLogConc:LogConfig :: LogConfig -> Bool
$sel:logLevelFile:LogConfig :: LogConfig -> Severity
$sel:logLevelStderr:LogConfig :: LogConfig -> Severity
$sel:logLevelEcho:LogConfig :: LogConfig -> Severity
$sel:logFile:LogConfig :: LogConfig -> Maybe (Path Abs File)
..} ->
    (Sem (Log : r) a -> Sem r a)
-> (Path Abs File -> Sem (Log : r) a -> Sem r a)
-> Maybe (Path Abs File)
-> Sem (Log : r) a
-> Sem r a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Sem (Log : r) a -> Sem r a
forall (r :: EffectRow). InterpreterFor Log r
interpretLogNull (\ Path Abs File
f -> Maybe Severity -> Path Abs File -> InterpreterFor Log r
forall (r :: EffectRow).
Members '[Resource, ChronosTime, Race, Async, Embed IO] r =>
Maybe Severity -> Path Abs File -> InterpreterFor Log r
interpretLogFileLevel (Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
logLevelFile) Path Abs File
f) Maybe (Path Abs File)
logFile (Sem (Log : r) a -> Sem r a) -> Sem (Log : r) a -> Sem r a
forall a b. (a -> b) -> a -> b
$
    forall {k1} (k2 :: k1) (e :: (* -> *) -> * -> *) (r :: EffectRow)
       a.
Sem (Tagged k2 e : r) a -> Sem (e : r) a
forall (k2 :: Symbol) (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem (Tagged k2 e : r) a -> Sem (e : r) a
untag @"file" (Sem (FileLog : r) a -> Sem (Log : r) a)
-> Sem (FileLog : r) a -> Sem (Log : r) a
forall a b. (a -> b) -> a -> b
$
    Maybe Severity -> InterpreterFor Log (FileLog : r)
forall (r :: EffectRow).
Members '[Resource, Async, Race, Embed IO] r =>
Maybe Severity -> InterpreterFor Log r
interpretLogStderrLevelConc (Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
logLevelStderr) (Sem (Log : FileLog : r) a -> Sem (FileLog : r) a)
-> Sem (Log : FileLog : r) a -> Sem (FileLog : r) a
forall a b. (a -> b) -> a -> b
$
    forall {k1} (k2 :: k1) (e :: (* -> *) -> * -> *) (r :: EffectRow)
       a.
Sem (Tagged k2 e : r) a -> Sem (e : r) a
forall (k2 :: Symbol) (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem (Tagged k2 e : r) a -> Sem (e : r) a
untag @"stderr" Sem (StderrLog : FileLog : r) a
Sem (Append '[StderrLog, FileLog] r) a
sem