{-# LANGUAGE RecordWildCards #-}

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

import Control.Concurrent (forkIO, newEmptyMVar, MVar, takeMVar, putMVar)
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

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

-- | A non-scale but time-ordered logger.
data SingleLogger = SingleLogger {
    SingleLogger -> IORef (LogStr, [LogStr])
slgrRef     :: IORef (LogStr
                         ,[LogStr])-- writer queue
  , SingleLogger -> IO ()
slgrKill    :: IO ()
  , 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, [LogStr]) -> MVar () -> IO ()
writer :: Int
-> Buffer
-> IORef FD
-> TVar Int
-> IORef (LogStr, [LogStr])
-> MVar ()
-> IO ()
writer Int
bufsize Buffer
buf IORef FD
fdref TVar Int
tvar IORef (LogStr, [LogStr])
ref MVar ()
mvar = Int -> IO ()
loop (Int
0 :: Int)
  where
    loop :: Int -> IO ()
loop Int
cnt = do
        Int
cnt' <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
            Int
n <- forall a. TVar a -> STM a
readTVar TVar Int
tvar
            Bool -> STM ()
check (Int
n forall a. Eq a => a -> a -> Bool
/= Int
cnt)
            forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
        [LogStr]
msgs <- forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (LogStr, [LogStr])
ref (\(LogStr
msg,[LogStr]
q) -> ((LogStr
msg,[]),[LogStr]
q))
        Bool
cont <- [LogStr] -> IO Bool
go [LogStr]
msgs
        if Bool
cont then
            Int -> IO ()
loop Int
cnt'
          else
            forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ()
    go :: [LogStr] -> IO Bool
go [] = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    go (msg :: LogStr
msg@(LogStr Int
len Builder
_):[LogStr]
msgs)
      | Int
len forall a. Ord a => a -> a -> Bool
<  Int
0       = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      | Int
len forall a. Ord a => a -> a -> Bool
<= Int
bufsize = Buffer -> IORef FD -> LogStr -> IO ()
writeLogStr Buffer
buf IORef FD
fdref LogStr
msg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [LogStr] -> IO Bool
go [LogStr]
msgs
      | Bool
otherwise      = IORef FD -> LogStr -> IO ()
writeBigLogStr  IORef FD
fdref LogStr
msg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [LogStr] -> IO Bool
go [LogStr]
msgs

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

-- | Creating `SingleLogger`.
newSingleLogger :: BufSize -> IORef FD -> IO SingleLogger
newSingleLogger :: Int -> IORef FD -> IO SingleLogger
newSingleLogger Int
bufsize IORef FD
fdref = do
    TVar Int
tvar <- forall a. a -> IO (TVar a)
newTVarIO Int
0
    IORef (LogStr, [LogStr])
ref <- forall a. a -> IO (IORef a)
newIORef (forall a. Monoid a => a
mempty,[])
    MVar ()
mvar <- forall a. IO (MVar a)
newEmptyMVar
    Buffer
buf <- Int -> IO Buffer
getBuffer Int
bufsize
    ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Int
-> Buffer
-> IORef FD
-> TVar Int
-> IORef (LogStr, [LogStr])
-> MVar ()
-> IO ()
writer Int
bufsize Buffer
buf IORef FD
fdref TVar Int
tvar IORef (LogStr, [LogStr])
ref MVar ()
mvar
    let wakeup :: IO ()
wakeup = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
tvar (forall a. Num a => a -> a -> a
+ Int
1)
        kill :: IO ()
kill = do
            let fin :: LogStr
fin = Int -> Builder -> LogStr
LogStr (-Int
1) forall a. Monoid a => a
mempty
            forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (LogStr, [LogStr])
ref (\(LogStr
old,[LogStr]
q) -> ((forall a. Monoid a => a
mempty,LogStr
finforall a. a -> [a] -> [a]
:LogStr
oldforall a. a -> [a] -> [a]
:[LogStr]
q),()))
            IO ()
wakeup
            forall a. MVar a -> IO a
takeMVar MVar ()
mvar
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SingleLogger {
        slgrRef :: IORef (LogStr, [LogStr])
slgrRef     = IORef (LogStr, [LogStr])
ref
      , slgrKill :: IO ()
slgrKill    = IO ()
kill
      , slgrWakeup :: IO ()
slgrWakeup  = IO ()
wakeup
      , slgrBuffer :: Buffer
slgrBuffer  = Buffer
buf
      , slgrBufSize :: Int
slgrBufSize = Int
bufsize
      , slgrFdRef :: IORef FD
slgrFdRef   = IORef FD
fdref
      }

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

pushLog :: SingleLogger -> LogStr -> IO ()
pushLog :: SingleLogger -> LogStr -> IO ()
pushLog SingleLogger{Int
IO ()
Buffer
IORef (LogStr, [LogStr])
IORef FD
slgrFdRef :: IORef FD
slgrBufSize :: Int
slgrBuffer :: Buffer
slgrWakeup :: IO ()
slgrKill :: IO ()
slgrRef :: IORef (LogStr, [LogStr])
slgrFdRef :: SingleLogger -> IORef FD
slgrBufSize :: SingleLogger -> Int
slgrBuffer :: SingleLogger -> Buffer
slgrWakeup :: SingleLogger -> IO ()
slgrKill :: SingleLogger -> IO ()
slgrRef :: SingleLogger -> IORef (LogStr, [LogStr])
..} nlogmsg :: LogStr
nlogmsg@(LogStr Int
nlen Builder
_)
  | Int
nlen forall a. Ord a => a -> a -> Bool
> Int
slgrBufSize = do
        forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (LogStr, [LogStr])
slgrRef (\(LogStr
old,[LogStr]
q) -> ((forall a. Monoid a => a
mempty,LogStr
nlogmsgforall a. a -> [a] -> [a]
:LogStr
oldforall a. a -> [a] -> [a]
:[LogStr]
q),()))
        IO ()
slgrWakeup
  | Bool
otherwise = do
        Bool
wake <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (LogStr, [LogStr])
slgrRef (LogStr, [LogStr]) -> ((LogStr, [LogStr]), Bool)
checkBuf
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wake IO ()
slgrWakeup
  where
    checkBuf :: (LogStr, [LogStr]) -> ((LogStr, [LogStr]), Bool)
checkBuf (ologmsg :: LogStr
ologmsg@(LogStr Int
olen Builder
_),[LogStr]
q)
      | Int
slgrBufSize forall a. Ord a => a -> a -> Bool
< Int
olen forall a. Num a => a -> a -> a
+ Int
nlen = ((LogStr
nlogmsg, LogStr
nlogmsgforall a. a -> [a] -> [a]
:[LogStr]
q), Bool
True)
      | Bool
otherwise                 = ((LogStr
ologmsg forall a. Semigroup a => a -> a -> a
<> LogStr
nlogmsg, [LogStr]
q), Bool
False)

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

stopLoggers :: SingleLogger -> IO ()
stopLoggers :: SingleLogger -> IO ()
stopLoggers SingleLogger{Int
IO ()
Buffer
IORef (LogStr, [LogStr])
IORef FD
slgrFdRef :: IORef FD
slgrBufSize :: Int
slgrBuffer :: Buffer
slgrWakeup :: IO ()
slgrKill :: IO ()
slgrRef :: IORef (LogStr, [LogStr])
slgrFdRef :: SingleLogger -> IORef FD
slgrBufSize :: SingleLogger -> Int
slgrBuffer :: SingleLogger -> Buffer
slgrWakeup :: SingleLogger -> IO ()
slgrKill :: SingleLogger -> IO ()
slgrRef :: SingleLogger -> IORef (LogStr, [LogStr])
..} = do
    IO ()
slgrKill
    Buffer -> IO ()
freeBuffer Buffer
slgrBuffer