{-# LANGUAGE UndecidableInstances #-}
module Control.Eff.Log.Writer
(
LogWriter(MkLogWriter, runLogWriter)
, SupportsLogger(..)
, noOpLogWriter
, debugTraceLogWriter
, PureLogWriter(..)
, listLogWriter
, CaptureLogs(..)
, CapturedLogsWriter
, runCapturedLogsWriter
, consoleLogWriter
, ioHandleLogWriter
, filteringLogWriter
, mappingLogWriter
, mappingLogWriterM
, ioLogWriter
, defaultIoLogWriter
) where
import Control.Eff
import Control.Eff.Log.Message
import Data.Default
import Debug.Trace
import GHC.Stack
import Control.Eff.Writer.Strict (Writer, tell, runListWriter)
import Data.Functor.Identity (Identity)
import Control.DeepSeq (deepseq)
import Data.Foldable (traverse_)
import System.IO
import Control.Monad ((>=>))
import Control.Lens
newtype LogWriter writerM = MkLogWriter
{ runLogWriter :: LogMessage -> writerM ()
}
instance Applicative w => Default (LogWriter w) where
def = MkLogWriter (const (pure ()))
class SupportsLogger h e where
liftLogWriter :: LogWriter h -> LogMessage -> Eff e ()
newtype PureLogWriter a = MkPureLogWriter { runPureLogWriter :: Identity a }
deriving (Functor, Applicative, Monad)
instance SupportsLogger PureLogWriter e where
liftLogWriter lw msg = deepseq (runPureLogWriter (runLogWriter lw msg)) (return ())
noOpLogWriter :: Applicative m => LogWriter m
noOpLogWriter = def
debugTraceLogWriter :: Monad h => LogWriter h
debugTraceLogWriter = MkLogWriter (traceM . renderLogMessage)
listLogWriter :: LogWriter CaptureLogs
listLogWriter = MkLogWriter (MkCaptureLogs . tell)
newtype CaptureLogs a = MkCaptureLogs { unCaptureLogs :: Eff '[CapturedLogsWriter] a }
deriving (Functor, Applicative, Monad)
instance Member CapturedLogsWriter e => SupportsLogger CaptureLogs e where
liftLogWriter lw = traverse_ (tell @LogMessage) . snd . run . runListWriter . unCaptureLogs . runLogWriter lw
runCapturedLogsWriter :: Eff (CapturedLogsWriter ': e) a -> Eff e (a, [LogMessage])
runCapturedLogsWriter = runListWriter
type CapturedLogsWriter = Writer LogMessage
ioLogWriter :: HasCallStack => (LogMessage-> IO ()) -> LogWriter IO
ioLogWriter = MkLogWriter
ioHandleLogWriter :: HasCallStack => Handle -> LogWriter IO
ioHandleLogWriter h = ioLogWriter (hPutStrLn h . renderLogMessage)
instance (Lifted IO e) => SupportsLogger IO e where
liftLogWriter = (lift . ) . runLogWriter
consoleLogWriter :: LogWriter IO
consoleLogWriter = ioLogWriter printLogMessage
defaultIoLogWriter :: String -> Facility -> LogWriter IO -> LogWriter IO
defaultIoLogWriter appName facility =
mappingLogWriterM
( setLogMessageThreadId
>=> setLogMessageTimestamp
>=> setLogMessageHostname
>=> pure
. set lmFacility facility
. set lmAppName (Just appName)
)
filteringLogWriter :: Monad e => LogPredicate -> LogWriter e -> LogWriter e
filteringLogWriter p lw = MkLogWriter (\msg -> if p msg then (runLogWriter lw msg) else return ())
mappingLogWriter :: (LogMessage -> LogMessage) -> LogWriter e -> LogWriter e
mappingLogWriter f lw = MkLogWriter (runLogWriter lw . f)
mappingLogWriterM :: Monad e => (LogMessage -> e LogMessage) -> LogWriter e -> LogWriter e
mappingLogWriterM f lw = MkLogWriter (f >=> runLogWriter lw)