{-# 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 Control.Monad.Trans (MonadTrans (lift))
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 (..))
import qualified Data.DList as DL (DList, snoc)
data LogEvent = LogEvent
{ leLoggerName :: !LoggerName
, leSeverity :: !Severity
, leMessage :: !Text
} deriving (Show)
newtype PureLogger m a = PureLogger
{ runPureLogger :: StateT (DL.DList LogEvent) m a
} deriving (Functor, Applicative, Monad, MonadTrans, MonadState (DL.DList LogEvent),
MonadThrow, HasLoggerName)
instance Monad m => CanLog (PureLogger m) where
dispatchMessage leLoggerName leSeverity leMessage = modify' (flip DL.snoc LogEvent{..})
instance MFunctor PureLogger where
hoist f = PureLogger . hoist f . runPureLogger
runPureLog :: Functor m => PureLogger m a -> m (a, [LogEvent])
runPureLog = fmap (second toList) . flip runStateT 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 (DL.DList 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