{-# LANGUAGE RecordWildCards #-}

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


import Control.Concurrent (myThreadId, threadCapability, MVar, newMVar, withMVar, 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.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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO (MVar a)
newMVar
    Array Int MLogger
arr <- forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
nforall a. Num a => a -> a -> a
-Int
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n IO MLogger
newMLogger
    forall (m :: * -> *) a. Monad m => a -> m a
return 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
IORef FD
MVar Buffer
mlgrFdRef :: IORef FD
mlgrBufSize :: Int
mlgrMBuffer :: MVar Buffer
mlgrArray :: Array Int MLogger
mlgrFdRef :: MultiLogger -> IORef FD
mlgrBufSize :: MultiLogger -> Int
mlgrMBuffer :: MultiLogger -> MVar Buffer
mlgrArray :: MultiLogger -> Array Int MLogger
..} LogStr
logmsg = do
    (Int
i, Bool
_) <- IO ThreadId
myThreadId 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 = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall i e. Array i e -> (i, i)
bounds Array Int MLogger
mlgrArray
        lim :: Int
lim = Int
u forall a. Num a => a -> a -> a
+ Int
1
        j :: Int
j | Int
i forall a. Ord a => a -> a -> Bool
< Int
lim   = Int
i
          | Bool
otherwise = Int
i forall a. Integral a => a -> a -> a
`mod` Int
lim
    let logger :: MLogger
logger = Array Int MLogger
mlgrArray 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 :: IORef LogStr
lgrRef :: MLogger -> IORef LogStr
..} nlogmsg :: LogStr
nlogmsg@(LogStr Int
nlen Builder
_)
      | Int
nlen 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 <- 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 forall a. Ord a => a -> a -> Bool
< Int
olen forall a. Num a => a -> a -> a
+ Int
nlen = (LogStr
nlogmsg, MultiLogger -> LogStr -> IO ()
writeLogStr' MultiLogger
ml LogStr
ologmsg)
          | Bool
otherwise                 = (LogStr
ologmsg forall a. Semigroup a => a -> a -> a
<> LogStr
nlogmsg, forall (m :: * -> *) a. Monad m => a -> m a
return ())

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

flushAllLog :: MultiLogger -> IO ()
flushAllLog :: MultiLogger -> IO ()
flushAllLog ml :: MultiLogger
ml@MultiLogger{Int
Array Int MLogger
IORef FD
MVar Buffer
mlgrFdRef :: IORef FD
mlgrBufSize :: Int
mlgrMBuffer :: MVar Buffer
mlgrArray :: Array Int MLogger
mlgrFdRef :: MultiLogger -> IORef FD
mlgrBufSize :: MultiLogger -> Int
mlgrMBuffer :: MultiLogger -> MVar Buffer
mlgrArray :: MultiLogger -> Array Int MLogger
..} = do
    let flushIt :: Int -> IO ()
flushIt Int
i = MultiLogger -> MLogger -> IO ()
flushLog MultiLogger
ml (Array Int MLogger
mlgrArray forall i e. Ix i => Array i e -> i -> e
! Int
i)
        (Int
l,Int
u) = forall i e. Array i e -> (i, i)
bounds Array Int MLogger
mlgrArray
        nums :: [Int]
nums = [Int
l .. Int
u]
    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 :: IORef LogStr
lgrRef :: MLogger -> 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 <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef LogStr
lgrRef (\LogStr
old -> (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
IORef FD
MVar Buffer
mlgrFdRef :: IORef FD
mlgrBufSize :: Int
mlgrMBuffer :: MVar Buffer
mlgrArray :: Array Int MLogger
mlgrFdRef :: MultiLogger -> IORef FD
mlgrBufSize :: MultiLogger -> Int
mlgrMBuffer :: MultiLogger -> MVar Buffer
mlgrArray :: MultiLogger -> Array Int MLogger
..} = do
  MultiLogger -> IO ()
System.Log.FastLogger.MultiLogger.flushAllLog MultiLogger
ml
  forall a. MVar a -> IO a
takeMVar MVar Buffer
mlgrMBuffer 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
IORef FD
MVar Buffer
mlgrFdRef :: IORef FD
mlgrBufSize :: Int
mlgrMBuffer :: MVar Buffer
mlgrArray :: Array Int MLogger
mlgrFdRef :: MultiLogger -> IORef FD
mlgrBufSize :: MultiLogger -> Int
mlgrMBuffer :: MultiLogger -> MVar Buffer
mlgrArray :: MultiLogger -> Array Int MLogger
..} LogStr
logstr =
    forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Buffer
mlgrMBuffer 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
IORef FD
MVar Buffer
mlgrFdRef :: IORef FD
mlgrBufSize :: Int
mlgrMBuffer :: MVar Buffer
mlgrArray :: Array Int MLogger
mlgrFdRef :: MultiLogger -> IORef FD
mlgrBufSize :: MultiLogger -> Int
mlgrMBuffer :: MultiLogger -> MVar Buffer
mlgrArray :: MultiLogger -> Array Int MLogger
..} LogStr
logstr =
    forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Buffer
mlgrMBuffer forall a b. (a -> b) -> a -> b
$ \Buffer
_ -> IORef FD -> LogStr -> IO ()
writeBigLogStr IORef FD
mlgrFdRef LogStr
logstr