    {-# 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
        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
        arr <- listArray (0, n - 1) <$> replicateM n newMLogger
        return $
            MultiLogger
                { mlgrArray = arr
                , mlgrMBuffer = mbuf
                , mlgrBufSize = bufsize
                , mlgrFdRef = 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
        (i, _) <- 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, 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
    u Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1
            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 = Array Int MLogger
    mlgrArray Array Int MLogger -> Int -> MLogger
    forall i e. Ix i => Array i e -> i -> e
    ! Int
    j
        pushLog' logger 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
                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
                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.
        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))
        writeLogStr' ml 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