    {-# LANGUAGE RecordWildCards #-}

    module System.Log.FastLogger.SingleLogger (
        SingleLogger,
        newSingleLogger,
    ) where

    import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, takeMVar)
    import Control.Concurrent.STM
    import GHC.Conc.Sync (labelThread)

    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

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

    data Ent = F (MVar ()) Bool | L LogStr
    type Q = [Ent] -- writer queue

    -- | A non-scale but time-ordered logger.
    data SingleLogger = SingleLogger
        { SingleLogger -> IORef (LogStr, Q)
    slgrRef :: IORef (LogStr, Q)
        , SingleLogger -> Bool -> IO ()
    slgrFlush :: Bool -> IO () -- teminate if False
        , SingleLogger -> IO ()
    slgrWakeup :: IO ()
        , SingleLogger -> Buffer
    slgrBuffer :: Buffer
        , SingleLogger -> Int
    slgrBufSize :: BufSize
        , SingleLogger -> IORef FD
    slgrFdRef :: IORef FD
        }

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

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

    writer
        :: BufSize
        -> Buffer
        -> IORef FD
        -> TVar Int
        -> IORef (LogStr, Q)
        -> IO ()
    writer :: Int -> Buffer -> IORef FD -> TVar Int -> IORef (LogStr, Q) -> IO ()
    writer Int
    bufsize Buffer
    buf IORef FD
    fdref TVar Int
    tvar IORef (LogStr, Q)
    ref = Int -> IO ()
    loop (Int
    0 :: Int)
      where
        loop :: Int -> IO ()
    loop Int
    cnt = do
            cnt' <- STM Int -> IO Int
    forall a. STM a -> IO a
    atomically (STM Int -> IO Int) -> STM Int -> IO Int
    forall a b. (a -> b) -> a -> b
    $ do
                n <- TVar Int -> STM Int
    forall a. TVar a -> STM a
    readTVar TVar Int
    tvar
                check (n /= cnt)
                return n
            msgs <- reverse <$> atomicModifyIORef' ref (\(LogStr
    msg, Q
    q) -> ((LogStr
    msg, []), Q
    q))
            cont <- go msgs
            when cont $ loop cnt'
        go :: Q -> IO Bool
    go [] = Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
        go (F MVar ()
    mvar Bool
    cont : Q
    msgs) = do
            MVar () -> () -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar ()
    mvar ()
            if Bool
    cont then Q -> IO Bool
    go Q
    msgs else Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
        go (L msg :: LogStr
    msg@(LogStr Int
    len Builder
    _) : Q
    msgs)
            | Int
    len Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    bufsize = Buffer -> IORef FD -> LogStr -> IO ()
    writeLogStr Buffer
    buf IORef FD
    fdref LogStr
    msg IO () -> IO Bool -> IO Bool
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Q -> IO Bool
    go Q
    msgs
            | Bool
    otherwise = IORef FD -> LogStr -> IO ()
    writeBigLogStr IORef FD
    fdref LogStr
    msg IO () -> IO Bool -> IO Bool
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Q -> IO Bool
    go Q
    msgs

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

    -- | Creating `SingleLogger`.
    newSingleLogger :: BufSize -> IORef FD -> IO SingleLogger
    newSingleLogger :: Int -> IORef FD -> IO SingleLogger
    newSingleLogger Int
    bufsize IORef FD
    fdref = do
        tvar <- Int -> IO (TVar Int)
    forall a. a -> IO (TVar a)
    newTVarIO Int
    0
        ref <- newIORef (mempty, [])
        buf <- getBuffer bufsize
        tid <- forkIO $ writer bufsize buf fdref tvar ref
        labelThread tid "FastLogger single logger's writer"
        let wakeup = STM () -> IO ()
    forall a. STM a -> IO a
    atomically (STM () -> IO ()) -> STM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ TVar Int -> (Int -> Int) -> STM ()
    forall a. TVar a -> (a -> a) -> STM ()
    modifyTVar' TVar Int
    tvar (Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1)
            flush Bool
    cont = do
                mvar <- IO (MVar ())
    forall a. IO (MVar a)
    newEmptyMVar
                let fin = MVar () -> Bool -> Ent
    F MVar ()
    mvar Bool
    cont
                atomicModifyIORef' ref (\(LogStr
    old, Q
    q) -> ((LogStr
    forall a. Monoid a => a
    mempty, Ent
    fin Ent -> Q -> Q
    forall a. a -> [a] -> [a]
    : LogStr -> Ent
    L LogStr
    old Ent -> Q -> Q
    forall a. a -> [a] -> [a]
    : Q
    q), ()))
                wakeup
                takeMVar mvar
        return $
            SingleLogger
                { slgrRef = ref
                , slgrFlush = flush
                , slgrWakeup = wakeup
                , slgrBuffer = buf
                , slgrBufSize = bufsize
                , slgrFdRef = fdref
                }

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

    pushLog :: SingleLogger -> LogStr -> IO ()
    pushLog :: SingleLogger -> LogStr -> IO ()
    pushLog SingleLogger{Int
    IO ()
    Buffer
    IORef (LogStr, Q)
    IORef FD
    Bool -> IO ()
    slgrRef :: SingleLogger -> IORef (LogStr, Q)
    slgrFlush :: SingleLogger -> Bool -> IO ()
    slgrWakeup :: SingleLogger -> IO ()
    slgrBuffer :: SingleLogger -> Buffer
    slgrBufSize :: SingleLogger -> Int
    slgrFdRef :: SingleLogger -> IORef FD
    slgrRef :: IORef (LogStr, Q)
    slgrFlush :: Bool -> IO ()
    slgrWakeup :: IO ()
    slgrBuffer :: Buffer
    slgrBufSize :: Int
    slgrFdRef :: IORef FD
    ..} nlogmsg :: LogStr
    nlogmsg@(LogStr Int
    nlen Builder
    _)
        | Int
    nlen Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    slgrBufSize = do
            IORef (LogStr, Q) -> ((LogStr, Q) -> ((LogStr, Q), ())) -> IO ()
    forall a b. IORef a -> (a -> (a, b)) -> IO b
    atomicModifyIORef' IORef (LogStr, Q)
    slgrRef (\(LogStr
    old, Q
    q) -> ((LogStr
    forall a. Monoid a => a
    mempty, LogStr -> Ent
    L LogStr
    nlogmsg Ent -> Q -> Q
    forall a. a -> [a] -> [a]
    : LogStr -> Ent
    L LogStr
    old Ent -> Q -> Q
    forall a. a -> [a] -> [a]
    : Q
    q), ()))
            IO ()
    slgrWakeup
        | Bool
    otherwise = do
            wake <- IORef (LogStr, Q)
    -> ((LogStr, Q) -> ((LogStr, Q), Bool)) -> IO Bool
    forall a b. IORef a -> (a -> (a, b)) -> IO b
    atomicModifyIORef' IORef (LogStr, Q)
    slgrRef (LogStr, Q) -> ((LogStr, Q), Bool)
    checkBuf
            when wake slgrWakeup
      where
        checkBuf :: (LogStr, Q) -> ((LogStr, Q), Bool)
    checkBuf (ologmsg :: LogStr
    ologmsg@(LogStr Int
    olen Builder
    _), Q
    q)
            | Int
    slgrBufSize 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, LogStr -> Ent
    L LogStr
    ologmsg Ent -> Q -> Q
    forall a. a -> [a] -> [a]
    : Q
    q), Bool
    True)
            | Bool
    otherwise = ((LogStr
    ologmsg LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    nlogmsg, Q
    q), Bool
    False)

    flushAllLog :: SingleLogger -> IO ()
    flushAllLog :: SingleLogger -> IO ()
    flushAllLog SingleLogger{Int
    IO ()
    Buffer
    IORef (LogStr, Q)
    IORef FD
    Bool -> IO ()
    slgrRef :: SingleLogger -> IORef (LogStr, Q)
    slgrFlush :: SingleLogger -> Bool -> IO ()
    slgrWakeup :: SingleLogger -> IO ()
    slgrBuffer :: SingleLogger -> Buffer
    slgrBufSize :: SingleLogger -> Int
    slgrFdRef :: SingleLogger -> IORef FD
    slgrRef :: IORef (LogStr, Q)
    slgrFlush :: Bool -> IO ()
    slgrWakeup :: IO ()
    slgrBuffer :: Buffer
    slgrBufSize :: Int
    slgrFdRef :: IORef FD
    ..} = do
        IORef (LogStr, Q) -> ((LogStr, Q) -> ((LogStr, Q), ())) -> IO ()
    forall a b. IORef a -> (a -> (a, b)) -> IO b
    atomicModifyIORef' IORef (LogStr, Q)
    slgrRef (\(LogStr
    old, Q
    q) -> ((LogStr
    forall a. Monoid a => a
    mempty, LogStr -> Ent
    L LogStr
    old Ent -> Q -> Q
    forall a. a -> [a] -> [a]
    : Q
    q), ()))
        Bool -> IO ()
    slgrFlush Bool
    True

    stopLoggers :: SingleLogger -> IO ()
    stopLoggers :: SingleLogger -> IO ()
    stopLoggers SingleLogger{Int
    IO ()
    Buffer
    IORef (LogStr, Q)
    IORef FD
    Bool -> IO ()
    slgrRef :: SingleLogger -> IORef (LogStr, Q)
    slgrFlush :: SingleLogger -> Bool -> IO ()
    slgrWakeup :: SingleLogger -> IO ()
    slgrBuffer :: SingleLogger -> Buffer
    slgrBufSize :: SingleLogger -> Int
    slgrFdRef :: SingleLogger -> IORef FD
    slgrRef :: IORef (LogStr, Q)
    slgrFlush :: Bool -> IO ()
    slgrWakeup :: IO ()
    slgrBuffer :: Buffer
    slgrBufSize :: Int
    slgrFdRef :: IORef FD
    ..} = do
        Bool -> IO ()
    slgrFlush Bool
    False
        Buffer -> IO ()
    freeBuffer Buffer
    slgrBuffer