{-# LANGUAGE NamedFieldPuns #-}
module Data.Buffer
(
Buffer,
new,
push,
flush,
Settings,
defaultSettings,
write,
size,
frequencyInMicroSeconds,
)
where
import qualified Control.Concurrent.STM as STM
import qualified Control.Debounce as Debounce
import qualified Data.List.NonEmpty as NonEmpty
import GHC.Natural (Natural)
data Buffer a
= Buffer
{
push :: a -> IO (),
flush :: IO ()
}
data Settings a
= Settings
{
write :: NonEmpty.NonEmpty a -> IO (),
size :: Natural,
frequencyInMicroSeconds :: Int
}
defaultSettings :: Settings a
defaultSettings =
Settings
{ write = \_ -> pure (),
size = 1,
frequencyInMicroSeconds = 0
}
new :: Settings a -> IO (Buffer a)
new settings = do
queue <- STM.atomically $ STM.newTBQueue (fromIntegral (size settings))
let writeList xs = maybe (pure ()) (write settings) (NonEmpty.nonEmpty xs)
let flush = writeList =<< STM.atomically (STM.flushTBQueue queue)
scheduleFlush <-
Debounce.mkDebounce
Debounce.defaultDebounceSettings
{ Debounce.debounceAction = flush,
Debounce.debounceFreq = frequencyInMicroSeconds settings
}
let push x = do
overflow <- STM.atomically $ do
full <- STM.isFullTBQueue queue
toFlush <- if full then STM.flushTBQueue queue else pure []
STM.writeTBQueue queue x
pure toFlush
writeList overflow
scheduleFlush
pure Buffer {push, flush}