{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module System.Log.FastLogger.LoggerSet (
    -- * Creating a logger set
    LoggerSet,
    newFileLoggerSet,
    newFileLoggerSetN,
    newStdoutLoggerSet,
    newStdoutLoggerSetN,
    newStderrLoggerSet,
    newStderrLoggerSetN,
    newLoggerSet,
    newFDLoggerSet,

    -- * Renewing and removing a logger set
    renewLoggerSet,
    rmLoggerSet,

    -- * Writing a log message
    pushLogStr,
    pushLogStrLn,

    -- * Flushing buffered log messages
    flushLogStr,

    -- * Misc
    replaceLoggerSet,
) where

import Control.Concurrent (getNumCapabilities)
import Control.Debounce (debounceAction, defaultDebounceSettings, mkDebounce, debounceThreadName)

import System.Log.FastLogger.FileIO
import System.Log.FastLogger.IO
import System.Log.FastLogger.Imports
import System.Log.FastLogger.LogStr
import System.Log.FastLogger.MultiLogger (MultiLogger)
import qualified System.Log.FastLogger.MultiLogger as M
import System.Log.FastLogger.SingleLogger (SingleLogger)
import qualified System.Log.FastLogger.SingleLogger as S
import System.Log.FastLogger.Write

----------------------------------------------------------------

data Logger = SL SingleLogger | ML MultiLogger

----------------------------------------------------------------

-- | A set of loggers.
--   The number of loggers is the capabilities of GHC RTS.
--   You can specify it with \"+RTS -N\<x\>\".
--   A buffer is prepared for each capability.
data LoggerSet = LoggerSet
    { LoggerSet -> Maybe FilePath
lgrsetFilePath :: Maybe FilePath
    , LoggerSet -> IORef FD
lgrsetFdRef :: IORef FD
    , LoggerSet -> Logger
lgrsetLogger :: Logger
    , LoggerSet -> IO ()
lgrsetDebounce :: IO ()
    }

-- | Creating a new 'LoggerSet' using a file.
--
-- Uses `numCapabilties` many buffers, which will result in log
-- output that is not ordered by time (see `newFileLoggerSetN`).
newFileLoggerSet :: BufSize -> FilePath -> IO LoggerSet
newFileLoggerSet :: Int -> FilePath -> IO LoggerSet
newFileLoggerSet Int
size FilePath
file = FilePath -> IO FD
openFileFD FilePath
file IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet Int
size Maybe Int
forall a. Maybe a
Nothing (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
file)

-- | Creating a new 'LoggerSet' using a file, using only the given number of capabilites.
--
-- Giving @mn = Just 1@ scales less well on multi-core machines,
-- but provides time-ordered output.
newFileLoggerSetN :: BufSize -> Maybe Int -> FilePath -> IO LoggerSet
newFileLoggerSetN :: Int -> Maybe Int -> FilePath -> IO LoggerSet
newFileLoggerSetN Int
size Maybe Int
mn FilePath
file = FilePath -> IO FD
openFileFD FilePath
file IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet Int
size Maybe Int
mn (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
file)

-- | Creating a new 'LoggerSet' using stdout.
newStdoutLoggerSet :: BufSize -> IO LoggerSet
newStdoutLoggerSet :: Int -> IO LoggerSet
newStdoutLoggerSet Int
size = IO FD
getStdoutFD IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet Int
size Maybe Int
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing

-- | Creating a new 'LoggerSet' using stdout, with the given number of buffers
-- (see `newFileLoggerSetN`).
newStdoutLoggerSetN :: BufSize -> Maybe Int -> IO LoggerSet
newStdoutLoggerSetN :: Int -> Maybe Int -> IO LoggerSet
newStdoutLoggerSetN Int
size Maybe Int
mn = IO FD
getStdoutFD IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet Int
size Maybe Int
mn Maybe FilePath
forall a. Maybe a
Nothing

-- | Creating a new 'LoggerSet' using stderr.
newStderrLoggerSet :: BufSize -> IO LoggerSet
newStderrLoggerSet :: Int -> IO LoggerSet
newStderrLoggerSet Int
size = IO FD
getStderrFD IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet Int
size Maybe Int
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing

-- | Creating a new 'LoggerSet' using stderr, with the given number of buffers
-- (see `newFileLoggerSetN`).
newStderrLoggerSetN :: BufSize -> Maybe Int -> IO LoggerSet
newStderrLoggerSetN :: Int -> Maybe Int -> IO LoggerSet
newStderrLoggerSetN Int
size Maybe Int
mn = IO FD
getStderrFD IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet Int
size Maybe Int
mn Maybe FilePath
forall a. Maybe a
Nothing

{-# DEPRECATED newLoggerSet "Use newFileLoggerSet etc instead" #-}

-- | Creating a new 'LoggerSet'.
--   If 'Nothing' is specified to the second argument,
--   stdout is used.
--   Please note that the minimum 'BufSize' is 1.
newLoggerSet :: BufSize -> Maybe Int -> Maybe FilePath -> IO LoggerSet
newLoggerSet :: Int -> Maybe Int -> Maybe FilePath -> IO LoggerSet
newLoggerSet Int
size Maybe Int
mn = IO LoggerSet
-> (FilePath -> IO LoggerSet) -> Maybe FilePath -> IO LoggerSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> IO LoggerSet
newStdoutLoggerSet Int
size) (Int -> Maybe Int -> FilePath -> IO LoggerSet
newFileLoggerSetN Int
size Maybe Int
mn)

-- | Creating a new 'LoggerSet' using a FD.
newFDLoggerSet :: BufSize -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet :: Int -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet Int
size Maybe Int
mn Maybe FilePath
mfile FD
fd = do
    Int
n <- case Maybe Int
mn of
        Just Int
n' -> Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n'
        Maybe Int
Nothing -> IO Int
getNumCapabilities
    IORef FD
fdref <- FD -> IO (IORef FD)
forall a. a -> IO (IORef a)
newIORef FD
fd
    let bufsiz :: Int
bufsiz = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
size
    Logger
logger <-
        if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Maybe Int
mn Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
            then
                SingleLogger -> Logger
SL (SingleLogger -> Logger) -> IO SingleLogger -> IO Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IORef FD -> IO SingleLogger
S.newSingleLogger Int
bufsiz IORef FD
fdref
            else do
                MultiLogger -> Logger
ML (MultiLogger -> Logger) -> IO MultiLogger -> IO Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> IORef FD -> IO MultiLogger
M.newMultiLogger Int
n Int
bufsiz IORef FD
fdref
    IO ()
flush <-
        DebounceSettings -> IO (IO ())
mkDebounce
            DebounceSettings
defaultDebounceSettings
                { debounceAction = flushLogStrRaw logger
                , debounceThreadName = "Loggerset of FastLogger (Debounce)"
                }
    LoggerSet -> IO LoggerSet
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LoggerSet -> IO LoggerSet) -> LoggerSet -> IO LoggerSet
forall a b. (a -> b) -> a -> b
$
        LoggerSet
            { lgrsetFilePath :: Maybe FilePath
lgrsetFilePath = Maybe FilePath
mfile
            , lgrsetFdRef :: IORef FD
lgrsetFdRef = IORef FD
fdref
            , lgrsetLogger :: Logger
lgrsetLogger = Logger
logger
            , lgrsetDebounce :: IO ()
lgrsetDebounce = IO ()
flush
            }

-- | Writing a log message to the corresponding buffer.
--   If the buffer becomes full, the log messages in the buffer
--   are written to its corresponding file, stdout, or stderr.
pushLogStr :: LoggerSet -> LogStr -> IO ()
pushLogStr :: LoggerSet -> LogStr -> IO ()
pushLogStr LoggerSet{Maybe FilePath
IO ()
IORef FD
Logger
lgrsetFilePath :: LoggerSet -> Maybe FilePath
lgrsetFdRef :: LoggerSet -> IORef FD
lgrsetLogger :: LoggerSet -> Logger
lgrsetDebounce :: LoggerSet -> IO ()
lgrsetFilePath :: Maybe FilePath
lgrsetFdRef :: IORef FD
lgrsetLogger :: Logger
lgrsetDebounce :: IO ()
..} LogStr
logmsg = case Logger
lgrsetLogger of
    SL SingleLogger
sl -> do
        SingleLogger -> LogStr -> IO ()
forall a. Loggers a => a -> LogStr -> IO ()
pushLog SingleLogger
sl LogStr
logmsg
        IO ()
lgrsetDebounce
    ML MultiLogger
ml -> do
        MultiLogger -> LogStr -> IO ()
forall a. Loggers a => a -> LogStr -> IO ()
pushLog MultiLogger
ml LogStr
logmsg
        IO ()
lgrsetDebounce

-- | Same as 'pushLogStr' but also appends a newline.
pushLogStrLn :: LoggerSet -> LogStr -> IO ()
pushLogStrLn :: LoggerSet -> LogStr -> IO ()
pushLogStrLn LoggerSet
loggerSet LogStr
logStr = LoggerSet -> LogStr -> IO ()
pushLogStr LoggerSet
loggerSet (LogStr
logStr LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\n")

-- | Flushing log messages in buffers.
--   This function must be called explicitly when the program is
--   being terminated.
--
--   Note: Since version 2.1.6, this function does not need to be
--   explicitly called, as every push includes an auto-debounced flush
--   courtesy of the auto-update package. Since version 2.2.2, this
--   function can be used to force flushing outside of the debounced
--   flush calls.
flushLogStr :: LoggerSet -> IO ()
flushLogStr :: LoggerSet -> IO ()
flushLogStr LoggerSet{Maybe FilePath
IO ()
IORef FD
Logger
lgrsetFilePath :: LoggerSet -> Maybe FilePath
lgrsetFdRef :: LoggerSet -> IORef FD
lgrsetLogger :: LoggerSet -> Logger
lgrsetDebounce :: LoggerSet -> IO ()
lgrsetFilePath :: Maybe FilePath
lgrsetFdRef :: IORef FD
lgrsetLogger :: Logger
lgrsetDebounce :: IO ()
..} = Logger -> IO ()
flushLogStrRaw Logger
lgrsetLogger

flushLogStrRaw :: Logger -> IO ()
flushLogStrRaw :: Logger -> IO ()
flushLogStrRaw (SL SingleLogger
sl) = SingleLogger -> IO ()
forall a. Loggers a => a -> IO ()
flushAllLog SingleLogger
sl
flushLogStrRaw (ML MultiLogger
ml) = MultiLogger -> IO ()
forall a. Loggers a => a -> IO ()
flushAllLog MultiLogger
ml

-- | Renewing the internal file information in 'LoggerSet'.
--   This does nothing for stdout and stderr.
renewLoggerSet :: LoggerSet -> IO ()
renewLoggerSet :: LoggerSet -> IO ()
renewLoggerSet LoggerSet{Maybe FilePath
IO ()
IORef FD
Logger
lgrsetFilePath :: LoggerSet -> Maybe FilePath
lgrsetFdRef :: LoggerSet -> IORef FD
lgrsetLogger :: LoggerSet -> Logger
lgrsetDebounce :: LoggerSet -> IO ()
lgrsetFilePath :: Maybe FilePath
lgrsetFdRef :: IORef FD
lgrsetLogger :: Logger
lgrsetDebounce :: IO ()
..} = case Maybe FilePath
lgrsetFilePath of
    Maybe FilePath
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just FilePath
file -> do
        FD
newfd <- FilePath -> IO FD
openFileFD FilePath
file
        FD
oldfd <- IORef FD -> (FD -> (FD, FD)) -> IO FD
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef FD
lgrsetFdRef (\FD
fd -> (FD
newfd, FD
fd))
        FD -> IO ()
closeFD FD
oldfd

-- | Flushing the buffers, closing the internal file information
--   and freeing the buffers.
rmLoggerSet :: LoggerSet -> IO ()
rmLoggerSet :: LoggerSet -> IO ()
rmLoggerSet LoggerSet{Maybe FilePath
IO ()
IORef FD
Logger
lgrsetFilePath :: LoggerSet -> Maybe FilePath
lgrsetFdRef :: LoggerSet -> IORef FD
lgrsetLogger :: LoggerSet -> Logger
lgrsetDebounce :: LoggerSet -> IO ()
lgrsetFilePath :: Maybe FilePath
lgrsetFdRef :: IORef FD
lgrsetLogger :: Logger
lgrsetDebounce :: IO ()
..} = do
    FD
fd <- IORef FD -> IO FD
forall a. IORef a -> IO a
readIORef IORef FD
lgrsetFdRef
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FD -> Bool
isFDValid FD
fd) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        case Logger
lgrsetLogger of
            SL SingleLogger
sl -> SingleLogger -> IO ()
forall a. Loggers a => a -> IO ()
stopLoggers SingleLogger
sl
            ML MultiLogger
ml -> MultiLogger -> IO ()
forall a. Loggers a => a -> IO ()
stopLoggers MultiLogger
ml
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust Maybe FilePath
lgrsetFilePath) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FD -> IO ()
closeFD FD
fd
        IORef FD -> FD -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef FD
lgrsetFdRef FD
invalidFD

-- | Replacing the file path in 'LoggerSet' and returning a new
--   'LoggerSet' and the old file path.
replaceLoggerSet :: LoggerSet -> FilePath -> (LoggerSet, Maybe FilePath)
replaceLoggerSet :: LoggerSet -> FilePath -> (LoggerSet, Maybe FilePath)
replaceLoggerSet lgrset :: LoggerSet
lgrset@LoggerSet{Maybe FilePath
IO ()
IORef FD
Logger
lgrsetFilePath :: LoggerSet -> Maybe FilePath
lgrsetFdRef :: LoggerSet -> IORef FD
lgrsetLogger :: LoggerSet -> Logger
lgrsetDebounce :: LoggerSet -> IO ()
lgrsetFilePath :: Maybe FilePath
lgrsetFdRef :: IORef FD
lgrsetLogger :: Logger
lgrsetDebounce :: IO ()
..} FilePath
new_file_path =
    (LoggerSet
lgrset{lgrsetFilePath = Just new_file_path}, Maybe FilePath
lgrsetFilePath)