{-# LANGUAGE OverloadedStrings #-}

module System.Log.FastLogger.LoggerSet (
  -- * Creating a logger set
    LoggerSet
  , newFileLoggerSet
  , newFileLoggerSetN
  , newStdoutLoggerSet
  , newStderrLoggerSet
  , newLoggerSet
  -- * Renewing and removing a logger set
  , renewLoggerSet
  , rmLoggerSet
  -- * Writing a log message
  , pushLogStr
  , pushLogStrLn
  -- * Flushing buffered log messages
  , flushLogStr
  -- * Misc
  , replaceLoggerSet
  ) where

import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceAction)
import Control.Concurrent (getNumCapabilities, myThreadId, threadCapability, takeMVar)
import Data.Array (Array, listArray, (!), bounds)

import System.Log.FastLogger.FileIO
import System.Log.FastLogger.IO
import System.Log.FastLogger.Imports
import System.Log.FastLogger.LogStr
import System.Log.FastLogger.Logger

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

-- | 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 (Maybe FilePath) (IORef FD) (Array Int Logger) (IO ())

-- | Creating a new 'LoggerSet' using a file.
newFileLoggerSet :: BufSize -> FilePath -> IO LoggerSet
newFileLoggerSet :: BufSize -> FilePath -> IO LoggerSet
newFileLoggerSet BufSize
size FilePath
file = FilePath -> IO FD
openFileFD FilePath
file IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BufSize -> Maybe BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe BufSize
forall a. Maybe a
Nothing (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
file)

-- | Creating a new 'LoggerSet' using a file.
newFileLoggerSetN :: BufSize -> Maybe Int -> FilePath -> IO LoggerSet
newFileLoggerSetN :: BufSize -> Maybe BufSize -> FilePath -> IO LoggerSet
newFileLoggerSetN BufSize
size Maybe BufSize
mn FilePath
file = FilePath -> IO FD
openFileFD FilePath
file IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BufSize -> Maybe BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe BufSize
mn (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
file)

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

-- | Creating a new 'LoggerSet' using stderr.
newStderrLoggerSet :: BufSize -> IO LoggerSet
newStderrLoggerSet :: BufSize -> IO LoggerSet
newStderrLoggerSet BufSize
size = IO FD
getStderrFD IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BufSize -> Maybe BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe BufSize
forall a. Maybe a
Nothing 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 :: BufSize -> Maybe BufSize -> Maybe FilePath -> IO LoggerSet
newLoggerSet BufSize
size Maybe BufSize
mn = IO LoggerSet
-> (FilePath -> IO LoggerSet) -> Maybe FilePath -> IO LoggerSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BufSize -> IO LoggerSet
newStdoutLoggerSet BufSize
size) (BufSize -> Maybe BufSize -> FilePath -> IO LoggerSet
newFileLoggerSetN BufSize
size Maybe BufSize
mn)

-- | Creating a new 'LoggerSet' using a FD.
newFDLoggerSet :: BufSize -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet :: BufSize -> Maybe BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe BufSize
mn Maybe FilePath
mfile FD
fd = do
    BufSize
n <- case Maybe BufSize
mn of
      Just BufSize
n' -> BufSize -> IO BufSize
forall (m :: * -> *) a. Monad m => a -> m a
return BufSize
n'
      Maybe BufSize
Nothing -> IO BufSize
getNumCapabilities
    [Logger]
loggers <- BufSize -> IO Logger -> IO [Logger]
forall (m :: * -> *) a. Applicative m => BufSize -> m a -> m [a]
replicateM BufSize
n (IO Logger -> IO [Logger]) -> IO Logger -> IO [Logger]
forall a b. (a -> b) -> a -> b
$ BufSize -> IO Logger
newLogger (BufSize -> BufSize -> BufSize
forall a. Ord a => a -> a -> a
max BufSize
1 BufSize
size)
    let arr :: Array BufSize Logger
arr = (BufSize, BufSize) -> [Logger] -> Array BufSize Logger
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (BufSize
0,BufSize
nBufSize -> BufSize -> BufSize
forall a. Num a => a -> a -> a
-BufSize
1) [Logger]
loggers
    IORef FD
fref <- FD -> IO (IORef FD)
forall a. a -> IO (IORef a)
newIORef FD
fd
    IO ()
flush <- DebounceSettings -> IO (IO ())
mkDebounce DebounceSettings
defaultDebounceSettings
        { debounceAction :: IO ()
debounceAction = IORef FD -> Array BufSize Logger -> IO ()
flushLogStrRaw IORef FD
fref Array BufSize Logger
arr
        }
    LoggerSet -> IO LoggerSet
forall (m :: * -> *) a. Monad m => a -> m a
return (LoggerSet -> IO LoggerSet) -> LoggerSet -> IO LoggerSet
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
-> IORef FD -> Array BufSize Logger -> IO () -> LoggerSet
LoggerSet Maybe FilePath
mfile IORef FD
fref Array BufSize Logger
arr 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
_ IORef FD
fdref Array BufSize Logger
arr IO ()
flush) LogStr
logmsg = do
    (BufSize
i, Bool
_) <- IO ThreadId
myThreadId IO ThreadId
-> (ThreadId -> IO (BufSize, Bool)) -> IO (BufSize, Bool)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ThreadId -> IO (BufSize, Bool)
threadCapability
    -- The number of capability could be dynamically changed.
    -- So, let's check the upper boundary of the array.
    let u :: BufSize
u = (BufSize, BufSize) -> BufSize
forall a b. (a, b) -> b
snd ((BufSize, BufSize) -> BufSize) -> (BufSize, BufSize) -> BufSize
forall a b. (a -> b) -> a -> b
$ Array BufSize Logger -> (BufSize, BufSize)
forall i e. Array i e -> (i, i)
bounds Array BufSize Logger
arr
        lim :: BufSize
lim = BufSize
u BufSize -> BufSize -> BufSize
forall a. Num a => a -> a -> a
+ BufSize
1
        j :: BufSize
j | BufSize
i BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
< BufSize
lim   = BufSize
i
          | Bool
otherwise = BufSize
i BufSize -> BufSize -> BufSize
forall a. Integral a => a -> a -> a
`mod` BufSize
lim
    let logger :: Logger
logger = Array BufSize Logger
arr Array BufSize Logger -> BufSize -> Logger
forall i e. Ix i => Array i e -> i -> e
! BufSize
j
    IORef FD -> Logger -> LogStr -> IO ()
pushLog IORef FD
fdref Logger
logger LogStr
logmsg
    IO ()
flush

-- | 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
_ IORef FD
fref Array BufSize Logger
arr IO ()
_) = IORef FD -> Array BufSize Logger -> IO ()
flushLogStrRaw IORef FD
fref Array BufSize Logger
arr

flushLogStrRaw :: IORef FD -> Array Int Logger -> IO ()
flushLogStrRaw :: IORef FD -> Array BufSize Logger -> IO ()
flushLogStrRaw IORef FD
fdref Array BufSize Logger
arr = do
    let (BufSize
l,BufSize
u) = Array BufSize Logger -> (BufSize, BufSize)
forall i e. Array i e -> (i, i)
bounds Array BufSize Logger
arr
    (BufSize -> IO ()) -> [BufSize] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BufSize -> IO ()
flushIt [BufSize
l .. BufSize
u]
  where
    flushIt :: BufSize -> IO ()
flushIt BufSize
i = IORef FD -> Logger -> IO ()
flushLog IORef FD
fdref (Array BufSize Logger
arr Array BufSize Logger -> BufSize -> Logger
forall i e. Ix i => Array i e -> i -> e
! BufSize
i)

-- | Renewing the internal file information in 'LoggerSet'.
--   This does nothing for stdout and stderr.
renewLoggerSet :: LoggerSet -> IO ()
renewLoggerSet :: LoggerSet -> IO ()
renewLoggerSet (LoggerSet Maybe FilePath
Nothing     IORef FD
_    Array BufSize Logger
_ IO ()
_) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
renewLoggerSet (LoggerSet (Just FilePath
file) IORef FD
fref Array BufSize Logger
_ IO ()
_) = 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
fref (\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
mfile IORef FD
fdref Array BufSize Logger
arr IO ()
_) = do
    FD
fd <- IORef FD -> IO FD
forall a. IORef a -> IO a
readIORef IORef FD
fdref
    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
        let (BufSize
l,BufSize
u) = Array BufSize Logger -> (BufSize, BufSize)
forall i e. Array i e -> (i, i)
bounds Array BufSize Logger
arr
        let nums :: [BufSize]
nums = [BufSize
l .. BufSize
u]
        (BufSize -> IO ()) -> [BufSize] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BufSize -> IO ()
flushIt [BufSize]
nums
        (BufSize -> IO ()) -> [BufSize] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BufSize -> IO ()
freeIt [BufSize]
nums
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust Maybe FilePath
mfile) (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
fdref FD
invalidFD
  where
    flushIt :: BufSize -> IO ()
flushIt BufSize
i = IORef FD -> Logger -> IO ()
flushLog IORef FD
fdref (Array BufSize Logger
arr Array BufSize Logger -> BufSize -> Logger
forall i e. Ix i => Array i e -> i -> e
! BufSize
i)
    freeIt :: BufSize -> IO ()
freeIt BufSize
i = do
        let (Logger BufSize
_ MVar Buffer
mbuf IORef LogStr
_) = Array BufSize Logger
arr Array BufSize Logger -> BufSize -> Logger
forall i e. Ix i => Array i e -> i -> e
! BufSize
i
        MVar Buffer -> IO Buffer
forall a. MVar a -> IO a
takeMVar MVar Buffer
mbuf IO Buffer -> (Buffer -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Buffer -> IO ()
freeBuffer

-- | 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 (LoggerSet Maybe FilePath
current_path IORef FD
a Array BufSize Logger
b IO ()
c) FilePath
new_file_path =
    (Maybe FilePath
-> IORef FD -> Array BufSize Logger -> IO () -> LoggerSet
LoggerSet (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
new_file_path) IORef FD
a Array BufSize Logger
b IO ()
c, Maybe FilePath
current_path)