{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
module System.Wlog.PureLogging
(
PureLogger (..)
, LogEvent (..)
, dispatchEvents
, logEvents
, runPureLog
, launchPureLog
, NamedPureLogger (..)
, runNamedPureLog
, launchNamedPureLog
, launchNamedPureLogWith
, usingNamedPureLogger
, logPureAction
) where
import Universum
import Control.Monad.Morph (MFunctor (..))
import Control.Monad.State.Strict (modify')
import Data.Sequence ((|>))
import System.Wlog.CanLog (CanLog (..), WithLogger)
import System.Wlog.HasLoggerName (HasLoggerName (..))
import System.Wlog.LoggerName (LoggerName (..))
import System.Wlog.LoggerNameBox (LoggerNameBox (..), usingLoggerName)
import System.Wlog.Severity (Severity (..))
data LogEvent = LogEvent
{ leLoggerName :: !LoggerName
, leSeverity :: !Severity
, leMessage :: !Text
} deriving (Show)
newtype PureLogger m a = PureLogger
{ runPureLogger :: StateT (Seq LogEvent) m a
} deriving (Functor, Applicative, Monad, MonadTrans, MonadState (Seq LogEvent),
MonadThrow, HasLoggerName)
instance Monad m => CanLog (PureLogger m) where
dispatchMessage leLoggerName leSeverity leMessage = modify' (|> LogEvent{..})
instance MFunctor PureLogger where
hoist f = PureLogger . hoist f . runPureLogger
runPureLog :: Functor m => PureLogger m a -> m (a, [LogEvent])
runPureLog = fmap (second toList) . usingStateT mempty . runPureLogger
dispatchEvents :: CanLog m => [LogEvent] -> m ()
dispatchEvents = mapM_ dispatchLogEvent
where
dispatchLogEvent (LogEvent name sev t) = dispatchMessage name sev t
logEvents :: WithLogger m => [LogEvent] -> m ()
logEvents events = do
logName <- askLoggerName
mapM_ (dispatchLogEvent logName) events
where
dispatchLogEvent logName (LogEvent _ sev t) = dispatchMessage logName sev t
launchPureLog
:: (CanLog n, Monad m)
=> (forall f. Functor f => m (f a) -> n (f b))
-> PureLogger m a
-> n b
launchPureLog hoist' action = do
(logs, res) <- hoist' $ swap <$> runPureLog action
res <$ dispatchEvents logs
newtype NamedPureLogger m a = NamedPureLogger
{ runNamedPureLogger :: PureLogger (LoggerNameBox m) a
} deriving (Functor, Applicative, Monad, MonadState (Seq LogEvent),
MonadThrow, HasLoggerName)
instance MonadTrans NamedPureLogger where
lift = NamedPureLogger . lift . lift
instance Monad m => CanLog (NamedPureLogger m) where
dispatchMessage name sev msg =
NamedPureLogger $ dispatchMessage name sev msg
instance MFunctor NamedPureLogger where
hoist f = NamedPureLogger . hoist (hoist f) . runNamedPureLogger
runNamedPureLog
:: (Monad m, HasLoggerName m)
=> NamedPureLogger m a -> m (a, [LogEvent])
runNamedPureLog (NamedPureLogger action) =
askLoggerName >>= (`usingLoggerName` runPureLog action)
launchNamedPureLog
:: (WithLogger n, Monad m)
=> (forall f. Functor f => m (f a) -> n (f b))
-> NamedPureLogger m a
-> n b
launchNamedPureLog hoist' namedPureLogger = do
name <- askLoggerName
(logs, res) <- hoist' $ swap <$> usingNamedPureLogger name namedPureLogger
res <$ dispatchEvents logs
launchNamedPureLogWith
:: (WithLogger n, Monad m)
=> (forall f. Functor f => m (f a) -> f b)
-> NamedPureLogger m a
-> n b
launchNamedPureLogWith hoist' = launchNamedPureLog (pure . hoist')
usingNamedPureLogger :: Functor m
=> LoggerName
-> NamedPureLogger m a
-> m (a, [LogEvent])
usingNamedPureLogger name (NamedPureLogger action) =
usingLoggerName name $ runPureLog action
logPureAction :: WithLogger m => NamedPureLogger m a -> m a
logPureAction namedPureLogger = do
loggerName <- askLoggerName
(a, events) <- usingNamedPureLogger loggerName namedPureLogger
a <$ dispatchEvents events