module System.Wlog.CanLog
( CanLog (..)
, WithLogger
, memoryLogs
, readMemoryLogs
, PureLogger (..)
, LogEvent (..)
, dispatchEvents
, runPureLog
, logDebug
, logError
, logInfo
, logNotice
, logWarning
, logMessage
) where
import Control.Monad.Base (MonadBase)
import Control.Monad.Except (ExceptT, MonadError)
import qualified Control.Monad.RWS as RWSLazy
import qualified Control.Monad.RWS.Strict as RWSStrict
import Control.Monad.Trans (MonadTrans (lift))
import Control.Monad.Writer (MonadWriter (tell), WriterT (runWriterT))
import qualified Data.DList as DL (DList)
import Data.SafeCopy (base, deriveSafeCopySimple)
import Data.Time (getCurrentTime)
import System.IO.Unsafe (unsafePerformIO)
import Universum
import System.Wlog.Formatter (formatLogMessageColors, getRoundedTime)
import System.Wlog.Logger (logM)
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 (..))
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,Maybe Int))
memoryLogs = unsafePerformIO $ newMVar Nothing
readMemoryLogs :: (MonadIO m) => m [Text]
readMemoryLogs = do
liftIO (readMVar memoryLogs) <&> maybe (pure []) (MQ.toList . fst)
instance CanLog IO where
dispatchMessage (loggerName -> name) prior msg = logM name prior 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
let formatted r = do
curTime <- maybe getCurrentTime getRoundedTime r
pure $ formatLogMessageColors name severity curTime t
let modif _ Nothing = pure Nothing
modif x (Just s) = Just <$> x s
modifyMVar_ memoryLogs $ modif $ \(q,rv) -> do
f <- formatted rv
pure $ (MQ.pushFront f q, rv)
pure ()