{-# LANGUAGE RecordWildCards #-}

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

import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, takeMVar)
import Control.Concurrent.STM

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
    _ <- forkIO $ writer bufsize buf fdref tvar ref
    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