{-# LANGUAGE TemplateHaskell #-}
module System.Wlog.MemoryQueue
( Sized(..)
, MemoryQueue(..)
, newMemoryQueue
, popLast
, pushFront
, queueToList
, mqMemSize
, mqLimit
) where
import Universum
import Data.Sequence (ViewR (..), viewr, (<|))
import Lens.Micro.Platform (makeLenses)
import qualified Data.Text as T
class Sized e where
getSize :: e -> Word64
instance Sized Text where
getSize = fromIntegral . (* 16) . T.length
data MemoryQueue a = MemoryQueue
{ _mqLimit :: !Word64
, _mqMemSize :: !Word64
, _mqQueue :: !(Seq a)
} deriving (Show)
makeLenses ''MemoryQueue
newMemoryQueue :: (Sized a) => Word64 -> MemoryQueue a
newMemoryQueue _mqLimit = MemoryQueue { _mqMemSize = 0, _mqQueue = mempty, .. }
popLast :: (Sized a) => MemoryQueue a -> (Maybe a, MemoryQueue a)
popLast mq@MemoryQueue{..} = case viewr _mqQueue of
EmptyR -> (Nothing, mq)
rest :> popped ->
let newMemSize = _mqMemSize - getSize popped
in (Just popped, MemoryQueue{ _mqMemSize = newMemSize, _mqQueue = rest, .. })
pushFront :: (Sized a) => a -> MemoryQueue a -> MemoryQueue a
pushFront msg oldQueue =
let msgSize = getSize msg
newSize = _mqMemSize oldQueue + msgSize
in resize oldQueue {
_mqMemSize = newSize
, _mqQueue = msg <| _mqQueue oldQueue
}
where
resize :: Sized a => MemoryQueue a -> MemoryQueue a
resize theQueue = if _mqMemSize theQueue > _mqLimit theQueue
then (let (_, q') = popLast theQueue in resize $! q')
else theQueue
queueToList :: (Sized a) => MemoryQueue a -> [a]
queueToList = toList . view mqQueue