{-# LANGUAGE RecordWildCards #-}

module System.Log.FastLogger.MultiLogger (
    MultiLogger,
    newMultiLogger,
) where

import Control.Concurrent (
    MVar,
    myThreadId,
    newMVar,
    takeMVar,
    threadCapability,
    withMVar,
 )
import Data.Array (Array, bounds, listArray, (!))

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

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

newtype MLogger = MLogger
    { MLogger -> IORef LogStr
lgrRef :: IORef LogStr
    }

-- | A scale but non-time-ordered logger.
data MultiLogger = MultiLogger
    { MultiLogger -> Array Int MLogger
mlgrArray :: Array Int MLogger
    , MultiLogger -> MVar Buffer
mlgrMBuffer :: MVar Buffer
    , MultiLogger -> Int
mlgrBufSize :: BufSize
    , MultiLogger -> IORef FD
mlgrFdRef :: IORef FD
    }

instance Loggers MultiLogger where
    stopLoggers :: MultiLogger -> IO ()
stopLoggers = MultiLogger -> IO ()
System.Log.FastLogger.MultiLogger.stopLoggers
    pushLog :: MultiLogger -> LogStr -> IO ()
pushLog = MultiLogger -> LogStr -> IO ()
System.Log.FastLogger.MultiLogger.pushLog
    flushAllLog :: MultiLogger -> IO ()
flushAllLog = MultiLogger -> IO ()
System.Log.FastLogger.MultiLogger.flushAllLog

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

newMLogger :: IO MLogger
newMLogger :: IO MLogger
newMLogger = IORef LogStr -> MLogger
MLogger (IORef LogStr -> MLogger) -> IO (IORef LogStr) -> IO MLogger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LogStr -> IO (IORef LogStr)
forall a. a -> IO (IORef a)
newIORef LogStr
forall a. Monoid a => a
mempty

-- | Creating `MultiLogger`.
--   The first argument is the number of the internal builders.
newMultiLogger :: Int -> BufSize -> IORef FD -> IO MultiLogger
newMultiLogger :: Int -> Int -> IORef FD -> IO MultiLogger
newMultiLogger Int
n Int
bufsize IORef FD
fdref = do
    MVar Buffer
mbuf <- Int -> IO Buffer
getBuffer Int
bufsize IO Buffer -> (Buffer -> IO (MVar Buffer)) -> IO (MVar Buffer)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Buffer -> IO (MVar Buffer)
forall a. a -> IO (MVar a)
newMVar
    Array Int MLogger
arr <- (Int, Int) -> [MLogger] -> Array Int MLogger
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([MLogger] -> Array Int MLogger)
-> IO [MLogger] -> IO (Array Int MLogger)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO MLogger -> IO [MLogger]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n IO MLogger
newMLogger
    MultiLogger -> IO MultiLogger
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MultiLogger -> IO MultiLogger) -> MultiLogger -> IO MultiLogger
forall a b. (a -> b) -> a -> b
$
        MultiLogger
            { mlgrArray :: Array Int MLogger
mlgrArray = Array Int MLogger
arr
            , mlgrMBuffer :: MVar Buffer
mlgrMBuffer = MVar Buffer
mbuf
            , mlgrBufSize :: Int
mlgrBufSize = Int
bufsize
            , mlgrFdRef :: IORef FD
mlgrFdRef = IORef FD
fdref
            }

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

pushLog :: MultiLogger -> LogStr -> IO ()
pushLog :: MultiLogger -> LogStr -> IO ()
pushLog ml :: MultiLogger
ml@MultiLogger{Int
Array Int MLogger
MVar Buffer
IORef FD
mlgrArray :: MultiLogger -> Array Int MLogger
mlgrMBuffer :: MultiLogger -> MVar Buffer
mlgrBufSize :: MultiLogger -> Int
mlgrFdRef :: MultiLogger -> IORef FD
mlgrArray :: Array Int MLogger
mlgrMBuffer :: MVar Buffer
mlgrBufSize :: Int
mlgrFdRef :: IORef FD
..} LogStr
logmsg = do
    (Int
i, Bool
_) <- IO ThreadId
myThreadId IO ThreadId -> (ThreadId -> IO (Int, Bool)) -> IO (Int, Bool)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ThreadId -> IO (Int, Bool)
threadCapability
    -- The number of capability could be dynamically changed.
    -- So, let's check the upper boundary of the array.
    let u :: Int
u = (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ Array Int MLogger -> (Int, Int)
forall i e. Array i e -> (i, i)
bounds Array Int MLogger
mlgrArray
        lim :: Int
lim = Int
u Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        j :: Int
j
            | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lim = Int
i
            | Bool
otherwise = Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
lim
    let logger :: MLogger
logger = Array Int MLogger
mlgrArray Array Int MLogger -> Int -> MLogger
forall i e. Ix i => Array i e -> i -> e
! Int
j
    MLogger -> LogStr -> IO ()
pushLog' MLogger
logger LogStr
logmsg
  where
    pushLog' :: MLogger -> LogStr -> IO ()
pushLog' logger :: MLogger
logger@MLogger{IORef LogStr
lgrRef :: MLogger -> IORef LogStr
lgrRef :: IORef LogStr
..} nlogmsg :: LogStr
nlogmsg@(LogStr Int
nlen Builder
_)
        | Int
nlen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
mlgrBufSize = do
            MultiLogger -> MLogger -> IO ()
flushLog MultiLogger
ml MLogger
logger
            -- Make sure we have a large enough buffer to hold the entire
            -- contents, thereby allowing for a single write system call and
            -- avoiding interleaving. This does not address the possibility
            -- of write not writing the entire buffer at once.
            MultiLogger -> LogStr -> IO ()
writeBigLogStr' MultiLogger
ml LogStr
nlogmsg
        | Bool
otherwise = do
            IO ()
action <- IORef LogStr -> (LogStr -> (LogStr, IO ())) -> IO (IO ())
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef LogStr
lgrRef LogStr -> (LogStr, IO ())
checkBuf
            IO ()
action
      where
        checkBuf :: LogStr -> (LogStr, IO ())
checkBuf ologmsg :: LogStr
ologmsg@(LogStr Int
olen Builder
_)
            | Int
mlgrBufSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
olen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nlen = (LogStr
nlogmsg, MultiLogger -> LogStr -> IO ()
writeLogStr' MultiLogger
ml LogStr
ologmsg)
            | Bool
otherwise = (LogStr
ologmsg LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
nlogmsg, () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

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

flushAllLog :: MultiLogger -> IO ()
flushAllLog :: MultiLogger -> IO ()
flushAllLog ml :: MultiLogger
ml@MultiLogger{Int
Array Int MLogger
MVar Buffer
IORef FD
mlgrArray :: MultiLogger -> Array Int MLogger
mlgrMBuffer :: MultiLogger -> MVar Buffer
mlgrBufSize :: MultiLogger -> Int
mlgrFdRef :: MultiLogger -> IORef FD
mlgrArray :: Array Int MLogger
mlgrMBuffer :: MVar Buffer
mlgrBufSize :: Int
mlgrFdRef :: IORef FD
..} = do
    let flushIt :: Int -> IO ()
flushIt Int
i = MultiLogger -> MLogger -> IO ()
flushLog MultiLogger
ml (Array Int MLogger
mlgrArray Array Int MLogger -> Int -> MLogger
forall i e. Ix i => Array i e -> i -> e
! Int
i)
        (Int
l, Int
u) = Array Int MLogger -> (Int, Int)
forall i e. Array i e -> (i, i)
bounds Array Int MLogger
mlgrArray
        nums :: [Int]
nums = [Int
l .. Int
u]
    (Int -> IO ()) -> [Int] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> IO ()
flushIt [Int]
nums

flushLog :: MultiLogger -> MLogger -> IO ()
flushLog :: MultiLogger -> MLogger -> IO ()
flushLog MultiLogger
ml MLogger{IORef LogStr
lgrRef :: MLogger -> IORef LogStr
lgrRef :: IORef LogStr
..} = do
    -- If a special buffer is prepared for flusher, this MVar could
    -- be removed. But such a code does not contribute logging speed
    -- according to experiment. And even with the special buffer,
    -- there is no grantee that this function is exclusively called
    -- for a buffer. So, we use MVar here.
    -- This is safe and speed penalty can be ignored.
    LogStr
old <- IORef LogStr -> (LogStr -> (LogStr, LogStr)) -> IO LogStr
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef LogStr
lgrRef (\LogStr
old -> (LogStr
forall a. Monoid a => a
mempty, LogStr
old))
    MultiLogger -> LogStr -> IO ()
writeLogStr' MultiLogger
ml LogStr
old

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

stopLoggers :: MultiLogger -> IO ()
stopLoggers :: MultiLogger -> IO ()
stopLoggers ml :: MultiLogger
ml@MultiLogger{Int
Array Int MLogger
MVar Buffer
IORef FD
mlgrArray :: MultiLogger -> Array Int MLogger
mlgrMBuffer :: MultiLogger -> MVar Buffer
mlgrBufSize :: MultiLogger -> Int
mlgrFdRef :: MultiLogger -> IORef FD
mlgrArray :: Array Int MLogger
mlgrMBuffer :: MVar Buffer
mlgrBufSize :: Int
mlgrFdRef :: IORef FD
..} = do
    MultiLogger -> IO ()
System.Log.FastLogger.MultiLogger.flushAllLog MultiLogger
ml
    MVar Buffer -> IO Buffer
forall a. MVar a -> IO a
takeMVar MVar Buffer
mlgrMBuffer IO Buffer -> (Buffer -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Buffer -> IO ()
freeBuffer

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

writeLogStr' :: MultiLogger -> LogStr -> IO ()
writeLogStr' :: MultiLogger -> LogStr -> IO ()
writeLogStr' MultiLogger{Int
Array Int MLogger
MVar Buffer
IORef FD
mlgrArray :: MultiLogger -> Array Int MLogger
mlgrMBuffer :: MultiLogger -> MVar Buffer
mlgrBufSize :: MultiLogger -> Int
mlgrFdRef :: MultiLogger -> IORef FD
mlgrArray :: Array Int MLogger
mlgrMBuffer :: MVar Buffer
mlgrBufSize :: Int
mlgrFdRef :: IORef FD
..} LogStr
logstr =
    MVar Buffer -> (Buffer -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Buffer
mlgrMBuffer ((Buffer -> IO ()) -> IO ()) -> (Buffer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Buffer
buf -> Buffer -> IORef FD -> LogStr -> IO ()
writeLogStr Buffer
buf IORef FD
mlgrFdRef LogStr
logstr

writeBigLogStr' :: MultiLogger -> LogStr -> IO ()
writeBigLogStr' :: MultiLogger -> LogStr -> IO ()
writeBigLogStr' MultiLogger{Int
Array Int MLogger
MVar Buffer
IORef FD
mlgrArray :: MultiLogger -> Array Int MLogger
mlgrMBuffer :: MultiLogger -> MVar Buffer
mlgrBufSize :: MultiLogger -> Int
mlgrFdRef :: MultiLogger -> IORef FD
mlgrArray :: Array Int MLogger
mlgrMBuffer :: MVar Buffer
mlgrBufSize :: Int
mlgrFdRef :: IORef FD
..} LogStr
logstr =
    MVar Buffer -> (Buffer -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Buffer
mlgrMBuffer ((Buffer -> IO ()) -> IO ()) -> (Buffer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Buffer
_ -> IORef FD -> LogStr -> IO ()
writeBigLogStr IORef FD
mlgrFdRef LogStr
logstr