{-# LANGUAGE NamedFieldPuns #-}
module Control.Concurrent.BQueue
( BQueue
, newBQueue
, pushBQueue
, popBQueue
, takeBQueue
, flushBQueue
, lengthBQueue
) where
data BQueue a = BQueue
{ bqRead :: ![a]
, bqReadSize :: {-# UNPACK #-}!Int
, bqWrite :: ![a]
, bqWriteSize :: {-# UNPACK #-}!Int
, bqMaxSize :: {-# UNPACK #-}!Int
}
newBQueue :: Int
-> BQueue a
newBQueue bqMaxSize =
BQueue {bqRead = [], bqReadSize = 0, bqWrite = [], bqWriteSize = 0, bqMaxSize}
pushBQueue :: a -> BQueue a -> Maybe (BQueue a)
pushBQueue x bq@BQueue {bqWrite, bqWriteSize}
| bqReadSize bq + bqWriteSize < bqMaxSize bq =
Just bq {bqWrite = x : bqWrite, bqWriteSize = bqWriteSize + 1}
| otherwise = Nothing
popBQueue :: BQueue a -> Maybe (a, BQueue a)
popBQueue bq@BQueue {bqRead, bqReadSize, bqWrite, bqWriteSize} =
case bqRead of
(x:xs) -> Just (x, bq {bqRead = xs, bqReadSize = bqReadSize - 1})
[] ->
case reverse bqWrite of
(y:ys) ->
Just (y, bq {bqRead = ys, bqReadSize = bqWriteSize - 1, bqWrite = [], bqWriteSize = 0})
[] -> Nothing
flushBQueue :: BQueue a -> ([a], BQueue a)
flushBQueue bq = (bqRead bq ++ reverse (bqWrite bq), newBQueue (bqMaxSize bq))
takeBQueue :: Int -> BQueue a -> ([a], BQueue a)
takeBQueue i bq@BQueue {bqRead, bqReadSize, bqWrite, bqWriteSize}
| i < bqReadSize =
let (taken, leftover) = splitAt i bqRead
in (taken, bq {bqRead = leftover, bqReadSize = bqReadSize - max 0 i})
| i < totalSize =
let (taken, leftover) = splitAt i (bqRead ++ reverse bqWrite)
in (taken, bq {bqRead = leftover, bqReadSize = totalSize - i, bqWrite = [], bqWriteSize = 0})
| otherwise = flushBQueue bq
where
totalSize = bqReadSize + bqWriteSize
lengthBQueue :: BQueue a -> Int
lengthBQueue bq = bqReadSize bq + bqWriteSize bq