{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Arbor.Monad.Logger
( logDebug
, logInfo
, logWarn
, logError
, logDebug'
, logInfo'
, logWarn'
, logError'
, pushLogMessage
, withStdOutTimedFastLogger
, runTimedLogT
, runLogT
, runTimedFastLoggerLoggingT
, Logger(..)
, LogLevel(..)
, LoggingT(..)
, MonadLogger(..)
, TimedFastLogger(..)
) where
import Arbor.Monad.Logger.Types (Logger (..))
import Control.Monad.IO.Class
import Control.Monad.Logger hiding (logDebug, logError, logInfo, logWarn)
import System.Log.FastLogger
import qualified Control.Monad.Logger as L
import qualified Data.ByteString.Char8 as BS
import qualified Data.Text as T
logDebug :: MonadLogger m => String -> m ()
logDebug = logDebug'
{-# INLINE logDebug #-}
logInfo :: MonadLogger m => String -> m ()
logInfo = logInfo'
{-# INLINE logInfo #-}
logWarn :: MonadLogger m => String -> m ()
logWarn = logWarn'
{-# INLINE logWarn #-}
logError :: MonadLogger m => String -> m ()
logError = logError'
{-# INLINE logError #-}
logDebug' :: (MonadLogger m, ToLogStr s) => s -> m ()
logDebug' = L.logWithoutLoc "" LevelDebug
{-# INLINE logDebug' #-}
logInfo' :: (MonadLogger m, ToLogStr s) => s -> m ()
logInfo' = L.logWithoutLoc "" LevelInfo
{-# INLINE logInfo' #-}
logWarn' :: (MonadLogger m, ToLogStr s) => s -> m ()
logWarn' = L.logWithoutLoc "" LevelWarn
{-# INLINE logWarn' #-}
logError' :: (MonadLogger m, ToLogStr s) => s -> m ()
logError' = L.logWithoutLoc "" LevelError
{-# INLINE logError' #-}
pushLogMessage :: (ToLogStr s) => TimedFastLogger -> LogLevel -> s -> IO ()
pushLogMessage t l s = t (defaultTimedLogStr defaultLoc "" l (toLogStr s))
defaultTimedLogStr :: Loc
-> LogSource
-> LogLevel
-> LogStr
-> FormattedTime
#if MIN_VERSION_fast_logger(0, 2, 0)
-> LogStr
#else
-> BS.ByteString
#endif
defaultTimedLogStr loc src level msg time =
#if MIN_VERSION_fast_logger(0, 2, 0)
"[" `mappend` defaultLogLevelStr level `mappend`
(if T.null src
then mempty
else "#" `mappend` toLogStr src) `mappend`
"] " `mappend` "[" `mappend` toLogStr time `mappend` "] " `mappend`
msg `mappend`
(if isDefaultLoc loc
then "\n"
else
" @(" `mappend`
toLogStr (BS.pack (fileLocStr loc)) `mappend`
")\n")
#else
BS.concat
[ BS.pack "["
, case level of
LevelOther t -> encodeUtf8 t
_ -> encodeUtf8 $ pack $ drop 5 $ show level
, if T.null src
then BS.empty
else encodeUtf8 $ '#' `T.cons` src
, BS.pack "] "
, BS.pack "["
, time
, BS.pack "] "
, case msg of
LS s -> encodeUtf8 $ pack s
LB b -> b
, BS.pack " @("
, encodeUtf8 $ pack (fileLocStr loc)
, BS.pack ")\n"
]
#endif
fileLocStr :: Loc -> String
fileLocStr loc = loc_package loc ++ ':' : loc_module loc ++
' ' : loc_filename loc ++ ':' : line loc ++ ':' : char loc
where line = show . fst . loc_start
char = show . snd . loc_start
defaultLogLevelStr :: LogLevel -> LogStr
defaultLogLevelStr level = case level of
LevelOther t -> toLogStr t
_ -> toLogStr $ BS.pack $ drop 5 $ show level
isDefaultLoc :: Loc -> Bool
isDefaultLoc (Loc "<unknown>" "<unknown>" "<unknown>" (0,0) (0,0)) = True
isDefaultLoc _ = False
withStdOutTimedFastLogger :: (TimedFastLogger -> IO a) -> IO a
withStdOutTimedFastLogger f = do
tc <- newTimeCache "%Y-%m-%d %T"
withTimedFastLogger tc (LogStdout defaultBufSize) $ \logger -> f logger
runLogT :: MonadIO m => Logger -> LoggingT m a -> m a
runLogT (Logger lgr lvl) = runTimedLogT lvl lgr
runTimedLogT :: MonadIO m => LogLevel -> TimedFastLogger -> LoggingT m a -> m a
runTimedLogT logLevel logger =
runTimedFastLoggerLoggingT logger . filterLogger (\_ lvl -> lvl >= logLevel)
runTimedFastLoggerLoggingT :: TimedFastLogger -> LoggingT m a -> m a
runTimedFastLoggerLoggingT tfl m = L.runLoggingT m $ \a b c d -> tfl (defaultTimedLogStr a b c d)