module System.Wlog.CanLog
( CanLog (..)
, WithLogger
, memoryLogs
, readMemoryLogs
, PureLogger (..)
, LogEvent (..)
, dispatchEvents
, runPureLog
, logDebug
, logError
, logInfo
, logNotice
, logWarning
, logMessage
) where
import Control.Concurrent (MVar, modifyMVar_, newMVar)
import Control.Monad.Base (MonadBase)
import Control.Monad.Except (ExceptT, MonadError)
import Control.Monad.Reader (MonadReader, ReaderT)
import qualified Control.Monad.RWS as RWSLazy
import qualified Control.Monad.RWS.Strict as RWSStrict
import Control.Monad.State (MonadState, StateT)
import Control.Monad.Trans (MonadTrans (lift))
import Control.Monad.Writer (MonadWriter (tell), WriterT (runWriterT))
import Data.Bifunctor (second)
import qualified Data.DList as DL (DList)
import Data.SafeCopy (base, deriveSafeCopySimple)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (getCurrentTime)
import System.IO.Unsafe (unsafePerformIO)
import System.Log.Logger (logM)
import Universum
import System.Wlog.Formatter (formatLogMessageColors)
import System.Wlog.LoggerName (LoggerName (..))
import System.Wlog.LoggerNameBox (HasLoggerName (..), LoggerNameBox (..))
import System.Wlog.MemoryQueue (MemoryQueue)
import qualified System.Wlog.MemoryQueue as MQ
import System.Wlog.Severity (Severity (..), convertSeverity)
type WithLogger m = (CanLog m, HasLoggerName m)
class Monad m => CanLog m where
dispatchMessage :: LoggerName -> Severity -> Text -> m ()
default dispatchMessage :: (MonadTrans t, t n ~ m, CanLog n)
=> LoggerName
-> Severity
-> Text
-> t n ()
dispatchMessage name sev t = lift $ dispatchMessage name sev t
type LogMemoryQueue = MemoryQueue Text
memoryLogs :: MVar (Maybe LogMemoryQueue)
memoryLogs = unsafePerformIO $ newMVar Nothing
readMemoryLogs :: (MonadIO m) => m [Text]
readMemoryLogs = do
liftIO (readMVar memoryLogs) <&> maybe (pure []) MQ.toList
instance CanLog IO where
dispatchMessage
(loggerName -> name)
(convertSeverity -> prior)
msg
= logM name prior (T.unpack msg)
instance CanLog m => CanLog (LoggerNameBox m)
instance CanLog m => CanLog (ReaderT r m)
instance CanLog m => CanLog (StateT s m)
instance CanLog m => CanLog (ExceptT s m)
instance (CanLog m, Monoid w) => CanLog (RWSLazy.RWST r w s m)
instance (CanLog m, Monoid w) => CanLog (RWSStrict.RWST r w s m)
data LogEvent = LogEvent
{ leLoggerName :: !LoggerName
, leSeverity :: !Severity
, leMessage :: !Text
} deriving (Show)
deriveSafeCopySimple 0 'base ''LogEvent
newtype PureLogger m a = PureLogger
{ runPureLogger :: WriterT (DL.DList LogEvent) m a
} deriving (Functor, Applicative, Monad, MonadTrans, MonadWriter (DL.DList LogEvent),
MonadBase b, MonadState s, MonadReader r, MonadError e, HasLoggerName)
instance Monad m => CanLog (PureLogger m) where
dispatchMessage leLoggerName leSeverity leMessage = tell [LogEvent{..}]
runPureLog :: Monad m => PureLogger m a -> m (a, [LogEvent])
runPureLog = fmap (second toList) . runWriterT . runPureLogger
dispatchEvents :: WithLogger m => [LogEvent] -> m ()
dispatchEvents = mapM_ dispatchLogEvent
where
dispatchLogEvent (LogEvent name sev t) = dispatchMessage name sev t
logDebug, logInfo, logNotice, logWarning, logError
:: WithLogger m
=> Text -> m ()
logDebug = logMessage Debug
logInfo = logMessage Info
logNotice = logMessage Notice
logWarning = logMessage Warning
logError = logMessage Error
logMessage
:: WithLogger m
=> Severity
-> Text
-> m ()
logMessage severity t = do
name <- getLoggerName
dispatchMessage name severity t
!() <- pure $ unsafePerformIO $ do
curTime <- getCurrentTime
let formatted = formatLogMessageColors name severity curTime t
modifyMVar_ memoryLogs (pure . (MQ.pushFront formatted <$>))
pure ()