{-# LANGUAGE CPP #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE OverloadedStrings #-}
module Control.Logger.Simple
    ( withGlobalLogging, LogConfig(..)
    , setLogLevel, LogLevel(..)
    , logTrace, logDebug, logInfo, logNote, logWarn, logError
    , logFail
    , pureTrace, pureDebug, pureInfo, pureNote, pureWarn, pureError
    , showText, (<>)
    , monadLoggerAdapter, runSimpleLoggingT
    )
where

import Control.Exception
import Control.Monad
import Control.Monad.Trans
import Data.IORef
import System.IO.Unsafe
import System.Log.FastLogger
import qualified Data.Text as T
import qualified Data.Traversable as T
#if MIN_VERSION_base(4,9,0)
#else
import qualified GHC.SrcLoc as GHC
#endif
import qualified GHC.Stack as GHC
import qualified Control.Monad.Logger as ML

data Loggers
    = Loggers
    { Loggers -> Maybe (FastLogger, IO ())
l_file :: !(Maybe (FastLogger, IO ()))
    , Loggers -> Maybe (FastLogger, IO ())
l_stderr :: !(Maybe (FastLogger, IO ()))
    , Loggers -> IO FormattedTime
l_timeCache :: !(IO FormattedTime)
    }

data LogConfig
    = LogConfig
    { LogConfig -> Maybe FilePath
lc_file :: !(Maybe FilePath)
    , LogConfig -> Bool
lc_stderr :: !Bool
    }

data LogLevel
    = LogTrace
    | LogDebug
    | LogInfo
    | LogNote
    | LogWarn
    | LogError
    deriving (LogLevel -> LogLevel -> Bool
(LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool) -> Eq LogLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogLevel -> LogLevel -> Bool
$c/= :: LogLevel -> LogLevel -> Bool
== :: LogLevel -> LogLevel -> Bool
$c== :: LogLevel -> LogLevel -> Bool
Eq, Int -> LogLevel -> ShowS
[LogLevel] -> ShowS
LogLevel -> FilePath
(Int -> LogLevel -> ShowS)
-> (LogLevel -> FilePath) -> ([LogLevel] -> ShowS) -> Show LogLevel
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [LogLevel] -> ShowS
$cshowList :: [LogLevel] -> ShowS
show :: LogLevel -> FilePath
$cshow :: LogLevel -> FilePath
showsPrec :: Int -> LogLevel -> ShowS
$cshowsPrec :: Int -> LogLevel -> ShowS
Show, ReadPrec [LogLevel]
ReadPrec LogLevel
Int -> ReadS LogLevel
ReadS [LogLevel]
(Int -> ReadS LogLevel)
-> ReadS [LogLevel]
-> ReadPrec LogLevel
-> ReadPrec [LogLevel]
-> Read LogLevel
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LogLevel]
$creadListPrec :: ReadPrec [LogLevel]
readPrec :: ReadPrec LogLevel
$creadPrec :: ReadPrec LogLevel
readList :: ReadS [LogLevel]
$creadList :: ReadS [LogLevel]
readsPrec :: Int -> ReadS LogLevel
$creadsPrec :: Int -> ReadS LogLevel
Read, Eq LogLevel
Eq LogLevel
-> (LogLevel -> LogLevel -> Ordering)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> LogLevel)
-> (LogLevel -> LogLevel -> LogLevel)
-> Ord LogLevel
LogLevel -> LogLevel -> Bool
LogLevel -> LogLevel -> Ordering
LogLevel -> LogLevel -> LogLevel
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LogLevel -> LogLevel -> LogLevel
$cmin :: LogLevel -> LogLevel -> LogLevel
max :: LogLevel -> LogLevel -> LogLevel
$cmax :: LogLevel -> LogLevel -> LogLevel
>= :: LogLevel -> LogLevel -> Bool
$c>= :: LogLevel -> LogLevel -> Bool
> :: LogLevel -> LogLevel -> Bool
$c> :: LogLevel -> LogLevel -> Bool
<= :: LogLevel -> LogLevel -> Bool
$c<= :: LogLevel -> LogLevel -> Bool
< :: LogLevel -> LogLevel -> Bool
$c< :: LogLevel -> LogLevel -> Bool
compare :: LogLevel -> LogLevel -> Ordering
$ccompare :: LogLevel -> LogLevel -> Ordering
$cp1Ord :: Eq LogLevel
Ord)

showText :: Show a => a -> T.Text
showText :: a -> Text
showText = FilePath -> Text
T.pack (FilePath -> Text) -> (a -> FilePath) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FilePath
forall a. Show a => a -> FilePath
show

-- | Log with 'LogTrace' log level
logTrace :: (?callStack :: GHC.CallStack) => MonadIO m => T.Text -> m ()
logTrace :: Text -> m ()
logTrace = LogLevel -> CallStack -> LogStr -> m ()
forall (m :: * -> *).
MonadIO m =>
LogLevel -> CallStack -> LogStr -> m ()
doLogCs LogLevel
LogTrace ?callStack::CallStack
CallStack
?callStack (LogStr -> m ()) -> (Text -> LogStr) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr

-- | Log with 'LogDebug' log level
logDebug :: (?callStack :: GHC.CallStack) => MonadIO m => T.Text -> m ()
logDebug :: Text -> m ()
logDebug = LogLevel -> CallStack -> LogStr -> m ()
forall (m :: * -> *).
MonadIO m =>
LogLevel -> CallStack -> LogStr -> m ()
doLogCs LogLevel
LogDebug ?callStack::CallStack
CallStack
?callStack (LogStr -> m ()) -> (Text -> LogStr) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr

-- | Log with 'LogInfo' log level
logInfo :: (?callStack :: GHC.CallStack) => MonadIO m => T.Text -> m ()
logInfo :: Text -> m ()
logInfo = LogLevel -> CallStack -> LogStr -> m ()
forall (m :: * -> *).
MonadIO m =>
LogLevel -> CallStack -> LogStr -> m ()
doLogCs LogLevel
LogInfo ?callStack::CallStack
CallStack
?callStack (LogStr -> m ()) -> (Text -> LogStr) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr

-- | Log with 'LogNote' log level
logNote :: (?callStack :: GHC.CallStack) => MonadIO m => T.Text -> m ()
logNote :: Text -> m ()
logNote = LogLevel -> CallStack -> LogStr -> m ()
forall (m :: * -> *).
MonadIO m =>
LogLevel -> CallStack -> LogStr -> m ()
doLogCs LogLevel
LogNote ?callStack::CallStack
CallStack
?callStack (LogStr -> m ()) -> (Text -> LogStr) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr

-- | Log with 'LogWarn' log level
logWarn :: (?callStack :: GHC.CallStack) => MonadIO m => T.Text -> m ()
logWarn :: Text -> m ()
logWarn = LogLevel -> CallStack -> LogStr -> m ()
forall (m :: * -> *).
MonadIO m =>
LogLevel -> CallStack -> LogStr -> m ()
doLogCs LogLevel
LogWarn ?callStack::CallStack
CallStack
?callStack (LogStr -> m ()) -> (Text -> LogStr) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr

-- | Log with 'LogError' log level
logError :: (?callStack :: GHC.CallStack) => MonadIO m => T.Text -> m ()
logError :: Text -> m ()
logError = LogLevel -> CallStack -> LogStr -> m ()
forall (m :: * -> *).
MonadIO m =>
LogLevel -> CallStack -> LogStr -> m ()
doLogCs LogLevel
LogError ?callStack::CallStack
CallStack
?callStack (LogStr -> m ()) -> (Text -> LogStr) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr

-- | Log on error level and call 'fail'
logFail :: (?callStack :: GHC.CallStack, MonadFail m) => MonadIO m => T.Text -> m a
logFail :: Text -> m a
logFail Text
t =
    do LogLevel -> CallStack -> LogStr -> m ()
forall (m :: * -> *).
MonadIO m =>
LogLevel -> CallStack -> LogStr -> m ()
doLogCs LogLevel
LogError ?callStack::CallStack
CallStack
?callStack (Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr Text
t)
       FilePath -> m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (Text -> FilePath
T.unpack Text
t)

-- | Log with 'LogTrace' level when the given expression is evaluated
pureTrace :: (?callStack :: GHC.CallStack) => T.Text -> a -> a
pureTrace :: Text -> a -> a
pureTrace = LogLevel -> CallStack -> Text -> a -> a
forall a. LogLevel -> CallStack -> Text -> a -> a
doPureLog LogLevel
LogTrace ?callStack::CallStack
CallStack
?callStack

-- | Log with 'LogDebug' level when the given expression is evaluated
pureDebug :: (?callStack :: GHC.CallStack) => T.Text -> a -> a
pureDebug :: Text -> a -> a
pureDebug = LogLevel -> CallStack -> Text -> a -> a
forall a. LogLevel -> CallStack -> Text -> a -> a
doPureLog LogLevel
LogDebug ?callStack::CallStack
CallStack
?callStack

-- | Log with 'LogInfo' level when the given expression is evaluated
pureInfo :: (?callStack :: GHC.CallStack) => T.Text -> a -> a
pureInfo :: Text -> a -> a
pureInfo = LogLevel -> CallStack -> Text -> a -> a
forall a. LogLevel -> CallStack -> Text -> a -> a
doPureLog LogLevel
LogInfo ?callStack::CallStack
CallStack
?callStack

-- | Log with 'LogNote' level when the given expression is evaluated
pureNote :: (?callStack :: GHC.CallStack) => T.Text -> a -> a
pureNote :: Text -> a -> a
pureNote = LogLevel -> CallStack -> Text -> a -> a
forall a. LogLevel -> CallStack -> Text -> a -> a
doPureLog LogLevel
LogNote ?callStack::CallStack
CallStack
?callStack

-- | Log with 'LogWarn' level when the given expression is evaluated
pureWarn :: (?callStack :: GHC.CallStack) => T.Text -> a -> a
pureWarn :: Text -> a -> a
pureWarn = LogLevel -> CallStack -> Text -> a -> a
forall a. LogLevel -> CallStack -> Text -> a -> a
doPureLog LogLevel
LogWarn ?callStack::CallStack
CallStack
?callStack

-- | Log with 'LogError' level when the given expression is evaluated
pureError :: (?callStack :: GHC.CallStack) => T.Text -> a -> a
pureError :: Text -> a -> a
pureError = LogLevel -> CallStack -> Text -> a -> a
forall a. LogLevel -> CallStack -> Text -> a -> a
doPureLog LogLevel
LogError ?callStack::CallStack
CallStack
?callStack

doPureLog ::LogLevel -> GHC.CallStack -> T.Text -> a -> a
doPureLog :: LogLevel -> CallStack -> Text -> a -> a
doPureLog LogLevel
ll CallStack
cs Text
txt a
expr =
    IO () -> ()
forall a. IO a -> a
unsafePerformIO (LogLevel -> CallStack -> FastLogger
forall (m :: * -> *).
MonadIO m =>
LogLevel -> CallStack -> LogStr -> m ()
doLogCs LogLevel
ll CallStack
cs FastLogger -> FastLogger
forall a b. (a -> b) -> a -> b
$ Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr Text
txt) () -> a -> a
`seq` a
expr


doLog :: MonadIO m => LogLevel -> LogStr -> LogStr -> m ()
doLog :: LogLevel -> LogStr -> LogStr -> m ()
doLog LogLevel
ll LogStr
loc LogStr
txt =
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    IORef LogLevel -> IO LogLevel
forall a. IORef a -> IO a
readIORef IORef LogLevel
logLevel IO LogLevel -> (LogLevel -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \LogLevel
logLim ->
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
ll LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
logLim) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    do Loggers
lgrs <- IORef Loggers -> IO Loggers
forall a. IORef a -> IO a
readIORef IORef Loggers
loggers
       FormattedTime
time <- Loggers -> IO FormattedTime
l_timeCache Loggers
lgrs
       let msg :: LogStr
msg =
               LogStr
"[" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
renderLevel LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" "
               LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> FormattedTime -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr FormattedTime
time
               LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" "
               LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr LogStr
loc
               LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"] "
               LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr LogStr
txt
               LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\n"
       Maybe (FastLogger, IO ())
-> ((FastLogger, IO ()) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Loggers -> Maybe (FastLogger, IO ())
l_stderr Loggers
lgrs) (((FastLogger, IO ()) -> IO ()) -> IO ())
-> ((FastLogger, IO ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(FastLogger
writeLog, IO ()
_) -> FastLogger
writeLog (LogStr
renderColor LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
msg LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
resetColor)
       Maybe (FastLogger, IO ())
-> ((FastLogger, IO ()) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Loggers -> Maybe (FastLogger, IO ())
l_file Loggers
lgrs) (((FastLogger, IO ()) -> IO ()) -> IO ())
-> ((FastLogger, IO ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(FastLogger
writeLog, IO ()
_) -> FastLogger
writeLog LogStr
msg
    where
        renderLevel :: LogStr
renderLevel =
            case LogLevel
ll of
              LogLevel
LogTrace -> LogStr
"TRACE"
              LogLevel
LogDebug -> LogStr
"DEBUG"
              LogLevel
LogInfo -> LogStr
"INFO"
              LogLevel
LogNote -> LogStr
"NOTE"
              LogLevel
LogWarn -> LogStr
"WARN"
              LogLevel
LogError -> LogStr
"ERROR"
        resetColor :: LogStr
resetColor =
            LogStr
"\o33[0;0m"
        renderColor :: LogStr
renderColor =
            case LogLevel
ll of
              LogLevel
LogTrace -> LogStr
"\o33[0;30m"
              LogLevel
LogDebug -> LogStr
"\o33[0;34m"
              LogLevel
LogInfo -> LogStr
"\o33[0;34m"
              LogLevel
LogNote -> LogStr
"\o33[1;32m"
              LogLevel
LogWarn -> LogStr
"\o33[0;33m"
              LogLevel
LogError -> LogStr
"\o33[1;31m"

doLogCs :: MonadIO m => LogLevel -> GHC.CallStack -> LogStr -> m ()
doLogCs :: LogLevel -> CallStack -> LogStr -> m ()
doLogCs LogLevel
ll CallStack
cs LogStr
txt =
    do let loc :: FilePath
loc =
             case CallStack -> [(FilePath, SrcLoc)]
GHC.getCallStack CallStack
cs of
               ((FilePath
_, SrcLoc
l):[(FilePath, SrcLoc)]
_) ->
                 SrcLoc -> FilePath
GHC.srcLocFile SrcLoc
l FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
":" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show (SrcLoc -> Int
GHC.srcLocStartLine SrcLoc
l)
               [(FilePath, SrcLoc)]
_ -> FilePath
"unknown"
       LogLevel -> LogStr -> LogStr -> m ()
forall (m :: * -> *).
MonadIO m =>
LogLevel -> LogStr -> LogStr -> m ()
doLog LogLevel
ll (FilePath -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr FilePath
loc) LogStr
txt

loggers :: IORef Loggers
loggers :: IORef Loggers
loggers =
    IO (IORef Loggers) -> IORef Loggers
forall a. IO a -> a
unsafePerformIO (IO (IORef Loggers) -> IORef Loggers)
-> IO (IORef Loggers) -> IORef Loggers
forall a b. (a -> b) -> a -> b
$
    do IO FormattedTime
tc <- FormattedTime -> IO (IO FormattedTime)
newTimeCache FormattedTime
timeFormat
       Loggers -> IO (IORef Loggers)
forall a. a -> IO (IORef a)
newIORef (Maybe (FastLogger, IO ())
-> Maybe (FastLogger, IO ()) -> IO FormattedTime -> Loggers
Loggers Maybe (FastLogger, IO ())
forall a. Maybe a
Nothing Maybe (FastLogger, IO ())
forall a. Maybe a
Nothing IO FormattedTime
tc)
{-# NOINLINE loggers #-}

logLevel :: IORef LogLevel
logLevel :: IORef LogLevel
logLevel = IO (IORef LogLevel) -> IORef LogLevel
forall a. IO a -> a
unsafePerformIO (IO (IORef LogLevel) -> IORef LogLevel)
-> IO (IORef LogLevel) -> IORef LogLevel
forall a b. (a -> b) -> a -> b
$ LogLevel -> IO (IORef LogLevel)
forall a. a -> IO (IORef a)
newIORef LogLevel
LogDebug
{-# NOINLINE logLevel #-}

-- | Set the verbosity level. Messages at our higher than this level are
-- displayed.  It defaults to 'LogDebug'.
setLogLevel :: LogLevel -> IO ()
setLogLevel :: LogLevel -> IO ()
setLogLevel = IORef LogLevel -> LogLevel -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef LogLevel
logLevel

-- | Setup global logging. Wrap your 'main' function with this.
withGlobalLogging :: LogConfig -> IO a -> IO a
withGlobalLogging :: LogConfig -> IO a -> IO a
withGlobalLogging LogConfig
lc IO a
f =
    IO Loggers -> (Loggers -> IO ()) -> (Loggers -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Loggers
initLogger Loggers -> IO ()
flushLogger (IO a -> Loggers -> IO a
forall a b. a -> b -> a
const IO a
f)
    where
      flushLogger :: Loggers -> IO ()
flushLogger (Loggers Maybe (FastLogger, IO ())
a Maybe (FastLogger, IO ())
b IO FormattedTime
_) =
          do Maybe (FastLogger, IO ())
-> ((FastLogger, IO ()) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (FastLogger, IO ())
a (FastLogger, IO ()) -> IO ()
forall a b. (a, b) -> b
snd
             Maybe (FastLogger, IO ())
-> ((FastLogger, IO ()) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (FastLogger, IO ())
b (FastLogger, IO ()) -> IO ()
forall a b. (a, b) -> b
snd
      initLogger :: IO Loggers
initLogger =
          do Maybe (FastLogger, IO ())
fileLogger <-
                 ((FilePath -> IO (FastLogger, IO ()))
 -> Maybe FilePath -> IO (Maybe (FastLogger, IO ())))
-> Maybe FilePath
-> (FilePath -> IO (FastLogger, IO ()))
-> IO (Maybe (FastLogger, IO ()))
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FilePath -> IO (FastLogger, IO ()))
-> Maybe FilePath -> IO (Maybe (FastLogger, IO ()))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (LogConfig -> Maybe FilePath
lc_file LogConfig
lc) ((FilePath -> IO (FastLogger, IO ()))
 -> IO (Maybe (FastLogger, IO ())))
-> (FilePath -> IO (FastLogger, IO ()))
-> IO (Maybe (FastLogger, IO ()))
forall a b. (a -> b) -> a -> b
$ \FilePath
fp ->
                 do let spec :: FileLogSpec
spec =
                            FileLogSpec :: FilePath -> Integer -> Int -> FileLogSpec
FileLogSpec
                            { log_file :: FilePath
log_file = FilePath
fp
                            , log_file_size :: Integer
log_file_size = Integer
1024 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1024 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
50
                            , log_backup_number :: Int
log_backup_number = Int
5
                            }
                    LogType' LogStr -> IO (FastLogger, IO ())
forall v. LogType' v -> IO (v -> IO (), IO ())
newFastLogger (FileLogSpec -> Int -> LogType' LogStr
LogFile FileLogSpec
spec Int
defaultBufSize)
             Maybe (FastLogger, IO ())
stderrLogger <-
                 if LogConfig -> Bool
lc_stderr LogConfig
lc
                 then (FastLogger, IO ()) -> Maybe (FastLogger, IO ())
forall a. a -> Maybe a
Just ((FastLogger, IO ()) -> Maybe (FastLogger, IO ()))
-> IO (FastLogger, IO ()) -> IO (Maybe (FastLogger, IO ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LogType' LogStr -> IO (FastLogger, IO ())
forall v. LogType' v -> IO (v -> IO (), IO ())
newFastLogger (Int -> LogType' LogStr
LogStderr Int
defaultBufSize)
                 else Maybe (FastLogger, IO ()) -> IO (Maybe (FastLogger, IO ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (FastLogger, IO ())
forall a. Maybe a
Nothing
             IO FormattedTime
tc <- FormattedTime -> IO (IO FormattedTime)
newTimeCache FormattedTime
timeFormat
             let lgrs :: Loggers
lgrs = Maybe (FastLogger, IO ())
-> Maybe (FastLogger, IO ()) -> IO FormattedTime -> Loggers
Loggers Maybe (FastLogger, IO ())
fileLogger Maybe (FastLogger, IO ())
stderrLogger IO FormattedTime
tc
             IORef Loggers -> Loggers -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Loggers
loggers Loggers
lgrs
             Loggers -> IO Loggers
forall (f :: * -> *) a. Applicative f => a -> f a
pure Loggers
lgrs

timeFormat :: TimeFormat
timeFormat :: FormattedTime
timeFormat = FormattedTime
"%Y-%m-%d %T %z"

-- | An adapter to implemend `MonadLogger` instances for custom monad stacks
monadLoggerAdapter :: (ML.ToLogStr msg, MonadIO m) => ML.Loc -> ML.LogSource -> ML.LogLevel -> msg -> m ()
monadLoggerAdapter :: Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerAdapter Loc
loc Text
_ LogLevel
lvl msg
msg =
  LogLevel -> LogStr -> LogStr -> m ()
forall (m :: * -> *).
MonadIO m =>
LogLevel -> LogStr -> LogStr -> m ()
doLog LogLevel
level LogStr
location (msg -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr msg
msg)
  where
    location :: LogStr
location =
      FilePath -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (FilePath -> LogStr) -> FilePath -> LogStr
forall a b. (a -> b) -> a -> b
$ Loc -> FilePath
ML.loc_filename Loc
loc FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
":" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show ((Int, Int) -> Int
forall a b. (a, b) -> a
fst (Loc -> (Int, Int)
ML.loc_start Loc
loc))
    level :: LogLevel
level =
      case LogLevel
lvl of
        LogLevel
ML.LevelDebug -> LogLevel
LogDebug
        LogLevel
ML.LevelInfo -> LogLevel
LogInfo
        LogLevel
ML.LevelWarn -> LogLevel
LogWarn
        LogLevel
ML.LevelError -> LogLevel
LogError
        ML.LevelOther Text
_ -> LogLevel
LogTrace

-- | Runs a logging transformer stack using the simple logger as backend
runSimpleLoggingT :: MonadIO m => ML.LoggingT m a -> m a
runSimpleLoggingT :: LoggingT m a -> m a
runSimpleLoggingT = (LoggingT m a -> (Loc -> Text -> LogLevel -> FastLogger) -> m a)
-> (Loc -> Text -> LogLevel -> FastLogger) -> LoggingT m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT m a -> (Loc -> Text -> LogLevel -> FastLogger) -> m a
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> FastLogger) -> m a
ML.runLoggingT Loc -> Text -> LogLevel -> FastLogger
forall msg (m :: * -> *).
(ToLogStr msg, MonadIO m) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerAdapter