content: {-# 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
      { slgrRef :: IORef (LogStr, Q)
      , slgrFlush :: Bool -> IO () -- teminate if False
      , slgrWakeup :: IO ()
      , slgrBuffer :: Buffer
      , slgrBufSize :: BufSize
      , slgrFdRef :: IORef FD
      }
  
  instance Loggers SingleLogger where
      stopLoggers = System.Log.FastLogger.SingleLogger.stopLoggers
      pushLog = System.Log.FastLogger.SingleLogger.pushLog
      flushAllLog = System.Log.FastLogger.SingleLogger.flushAllLog
  
  ----------------------------------------------------------------
  
  writer
      :: BufSize
      -> Buffer
      -> IORef FD
      -> TVar Int
      -> IORef (LogStr, Q)
      -> IO ()
  writer bufsize buf fdref tvar ref = loop (0 :: Int)
    where
      loop cnt = do
          cnt' <- atomically $ do
              n <- readTVar tvar
              check (n /= cnt)
              return n
          msgs <- reverse <$> atomicModifyIORef' ref (\(msg, q) -> ((msg, []), q))
          cont <- go msgs
          when cont $ loop cnt'
      go [] = return True
      go (F mvar cont : msgs) = do
          putMVar mvar ()
          if cont then go msgs else return False
      go (L msg@(LogStr len _) : msgs)
          | len <= bufsize = writeLogStr buf fdref msg >> go msgs
          | otherwise = writeBigLogStr fdref msg >> go msgs
  
  ----------------------------------------------------------------
  
  -- | Creating `SingleLogger`.
  newSingleLogger :: BufSize -> IORef FD -> IO SingleLogger
  newSingleLogger bufsize fdref = do
      tvar <- newTVarIO 0
      ref <- newIORef (mempty, [])
      buf <- getBuffer bufsize
      tid <- forkIO $ writer bufsize buf fdref tvar ref
      labelThread tid "FastLogger single logger's writer"
      let wakeup = atomically $ modifyTVar' tvar (+ 1)
          flush cont = do
              mvar <- newEmptyMVar
              let fin = F mvar cont
              atomicModifyIORef' ref (\(old, q) -> ((mempty, fin : L old : q), ()))
              wakeup
              takeMVar mvar
      return $
          SingleLogger
              { slgrRef = ref
              , slgrFlush = flush
              , slgrWakeup = wakeup
              , slgrBuffer = buf
              , slgrBufSize = bufsize
              , slgrFdRef = fdref
              }
  
  ----------------------------------------------------------------
  
  pushLog :: SingleLogger -> LogStr -> IO ()
  pushLog SingleLogger{..} nlogmsg@(LogStr nlen _)
      | nlen > slgrBufSize = do
          atomicModifyIORef' slgrRef (\(old, q) -> ((mempty, L nlogmsg : L old : q), ()))
          slgrWakeup
      | otherwise = do
          wake <- atomicModifyIORef' slgrRef checkBuf
          when wake slgrWakeup
    where
      checkBuf (ologmsg@(LogStr olen _), q)
          | slgrBufSize < olen + nlen = ((nlogmsg, L ologmsg : q), True)
          | otherwise = ((ologmsg <> nlogmsg, q), False)
  
  flushAllLog :: SingleLogger -> IO ()
  flushAllLog SingleLogger{..} = do
      atomicModifyIORef' slgrRef (\(old, q) -> ((mempty, L old : q), ()))
      slgrFlush True
  
  stopLoggers :: SingleLogger -> IO ()
  stopLoggers SingleLogger{..} = do
      slgrFlush False
      freeBuffer slgrBuffer
  