module Control.Logging
( log
, warn
, debug
, errorL
, traceL
, traceShowL
, timedLog
, timedLog'
, timedDebug
, timedDebug'
, withStdoutLogging
, withStderrLogging
, flushLog
, setDebugLevel
, setLogFormat
) where
import Control.Exception.Lifted
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Trans.Control
import Data.AffineSpace
import Data.IORef
import Data.Monoid
import Data.Text as T
import Data.Thyme
import Debug.Trace
import Prelude hiding (log)
import System.IO.Unsafe
import System.Locale
import System.Log.FastLogger
logLevel :: IORef LogLevel
logLevel = unsafePerformIO $ newIORef LevelDebug
setDebugLevel :: LogLevel -> IO ()
setDebugLevel = atomicWriteIORef logLevel
logSet :: IORef LoggerSet
logSet = unsafePerformIO $
newIORef (error "Must call withStdoutLogging or withStderrLogging")
logFormat :: IORef String
logFormat = unsafePerformIO $ newIORef "%Y %b-%d %H:%M:%S%Q"
setLogFormat :: String -> IO ()
setLogFormat = atomicWriteIORef logFormat
logger :: ToLogStr msg => Loc -> LogSource -> LogLevel -> msg -> IO ()
logger _loc !src !lvl str = do
maxLvl <- readIORef logLevel
when (lvl >= maxLvl) $ do
now <- getCurrentTime
fmt <- readIORef logFormat
let stamp = formatTime defaultTimeLocale fmt now
set <- readIORef logSet
pushLogStr set
$ toLogStr (stamp ++ " " ++ renderLevel lvl
++ " " ++ renderSource src)
<> toLogStr str
<> toLogStr (pack "\n")
where
renderSource :: Text -> String
renderSource txt
| T.null txt = ""
| otherwise = unpack txt ++ ": "
renderLevel LevelDebug = "[DEBUG]"
renderLevel LevelInfo = "[INFO]"
renderLevel LevelWarn = "[WARN]"
renderLevel LevelError = "[ERROR]"
renderLevel (LevelOther txt) = "[" ++ unpack txt ++ "]"
withStdoutLogging :: (MonadBaseControl IO m, MonadIO m) => m a -> m a
withStdoutLogging f = do
liftIO $ do
set <- newStdoutLoggerSet defaultBufSize
atomicWriteIORef logSet set
f `finally` flushLog
withStderrLogging :: (MonadBaseControl IO m, MonadIO m) => m a -> m a
withStderrLogging f = do
liftIO $ do
set <- newStderrLoggerSet defaultBufSize
atomicWriteIORef logSet set
f `finally` flushLog
flushLog :: MonadIO m => m ()
flushLog = liftIO $ do
set <- readIORef logSet
flushLogStr set
instance MonadLogger IO where
monadLoggerLog = logger
log :: MonadLogger m => Text -> m ()
log = logInfoN
debug :: MonadLogger m => Text -> m ()
debug = logDebugN
warn :: MonadLogger m => Text -> m ()
warn = logWarnN
errorL :: Text -> a
errorL str = error (unsafePerformIO (logErrorN str) `seq` unpack str)
traceL :: Text -> a -> a
traceL str = trace (unsafePerformIO (logDebugN str) `seq` unpack str)
traceShowL :: Show a => a -> a1 -> a1
traceShowL x =
let s = show x
in trace (unsafePerformIO (logDebugN (pack s)) `seq` s)
doTimedLog :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)
=> (Text -> m ()) -> Bool -> Text -> m () -> m ()
doTimedLog logf wrapped msg f = do
start <- liftIO getCurrentTime
when wrapped $ logf $ msg <> "..."
f `catch` \e -> do
let str = show (e :: SomeException)
wrapup start $ pack $
if wrapped
then "...FAIL (" ++ str ++ ")"
else " (FAIL: " ++ str ++ ")"
throwIO e
wrapup start $ if wrapped then "...done" else ""
where
wrapup start m = do
end <- liftIO getCurrentTime
logf $ msg <> m <> " [" <> pack (show (end .-. start)) <> "]"
timedLog :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)
=> Text -> m () -> m ()
timedLog = doTimedLog log True
timedLog' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)
=> Text -> m () -> m ()
timedLog' = doTimedLog log False
timedDebug :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)
=> Text -> m () -> m ()
timedDebug = doTimedLog debug True
timedDebug' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)
=> Text -> m () -> m ()
timedDebug' = doTimedLog debug False