{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
module Control.Concurrent.STM.TBQueue (
TBQueue,
newTBQueue,
newTBQueueIO,
readTBQueue,
tryReadTBQueue,
flushTBQueue,
peekTBQueue,
tryPeekTBQueue,
writeTBQueue,
unGetTBQueue,
lengthTBQueue,
isEmptyTBQueue,
isFullTBQueue,
capacityTBQueue,
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (pure)
#endif
import Data.Array.Base
import Data.Maybe (isJust, isNothing)
import Data.Typeable (Typeable)
import GHC.Conc
import Numeric.Natural (Natural)
import Prelude hiding (read)
import Control.Concurrent.STM.TArray
data TBQueue a
= TBQueue {-# UNPACK #-} !(TVar Int)
{-# UNPACK #-} !(TVar Int)
{-# UNPACK #-} !(TArray Int (Maybe a))
{-# UNPACK #-} !Int
deriving Typeable
instance Eq (TBQueue a) where
TBQueue TVar Int
a TVar Int
_ TArray Int (Maybe a)
_ Int
_ == :: TBQueue a -> TBQueue a -> Bool
== TBQueue TVar Int
b TVar Int
_ TArray Int (Maybe a)
_ Int
_ = TVar Int
a forall a. Eq a => a -> a -> Bool
== TVar Int
b
incMod :: Int -> Int -> Int
incMod :: Int -> Int -> Int
incMod Int
x Int
cap = let y :: Int
y = Int
x forall a. Num a => a -> a -> a
+ Int
1 in if Int
y forall a. Eq a => a -> a -> Bool
== Int
cap then Int
0 else Int
y
decMod :: Int -> Int -> Int
decMod :: Int -> Int -> Int
decMod Int
x Int
cap = if Int
x forall a. Eq a => a -> a -> Bool
== Int
0 then Int
cap forall a. Num a => a -> a -> a
- Int
1 else Int
x forall a. Num a => a -> a -> a
- Int
1
newTBQueue :: Natural
-> STM (TBQueue a)
newTBQueue :: forall a. Natural -> STM (TBQueue a)
newTBQueue Natural
cap
| Natural
cap forall a. Ord a => a -> a -> Bool
<= Natural
0 = forall a. HasCallStack => [Char] -> a
error [Char]
"capacity has to be greater than 0"
| Natural
cap forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int) = forall a. HasCallStack => [Char] -> a
error [Char]
"capacity is too big"
| Bool
otherwise = do
TVar Int
rindex <- forall a. a -> STM (TVar a)
newTVar Int
0
TVar Int
windex <- forall a. a -> STM (TVar a)
newTVar Int
0
TArray Int (Maybe a)
elements <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0, Int
cap' forall a. Num a => a -> a -> a
- Int
1) forall a. Maybe a
Nothing
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a.
TVar Int -> TVar Int -> TArray Int (Maybe a) -> Int -> TBQueue a
TBQueue TVar Int
rindex TVar Int
windex TArray Int (Maybe a)
elements Int
cap')
where
cap' :: Int
cap' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
cap
newTBQueueIO :: Natural -> IO (TBQueue a)
newTBQueueIO :: forall a. Natural -> IO (TBQueue a)
newTBQueueIO Natural
cap
| Natural
cap forall a. Ord a => a -> a -> Bool
<= Natural
0 = forall a. HasCallStack => [Char] -> a
error [Char]
"capacity has to be greater than 0"
| Natural
cap forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int) = forall a. HasCallStack => [Char] -> a
error [Char]
"capacity is too big"
| Bool
otherwise = do
TVar Int
rindex <- forall a. a -> IO (TVar a)
newTVarIO Int
0
TVar Int
windex <- forall a. a -> IO (TVar a)
newTVarIO Int
0
TArray Int (Maybe a)
elements <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0, Int
cap' forall a. Num a => a -> a -> a
- Int
1) forall a. Maybe a
Nothing
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a.
TVar Int -> TVar Int -> TArray Int (Maybe a) -> Int -> TBQueue a
TBQueue TVar Int
rindex TVar Int
windex TArray Int (Maybe a)
elements Int
cap')
where
cap' :: Int
cap' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
cap
writeTBQueue :: TBQueue a -> a -> STM ()
writeTBQueue :: forall a. TBQueue a -> a -> STM ()
writeTBQueue (TBQueue TVar Int
_ TVar Int
windex TArray Int (Maybe a)
elements Int
cap) a
a = do
Int
w <- forall a. TVar a -> STM a
readTVar TVar Int
windex
Maybe a
ele <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead TArray Int (Maybe a)
elements Int
w
case Maybe a
ele of
Maybe a
Nothing -> forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite TArray Int (Maybe a)
elements Int
w (forall a. a -> Maybe a
Just a
a)
Just a
_ -> forall a. STM a
retry
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
windex forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int
incMod Int
w Int
cap
readTBQueue :: TBQueue a -> STM a
readTBQueue :: forall a. TBQueue a -> STM a
readTBQueue (TBQueue TVar Int
rindex TVar Int
_ TArray Int (Maybe a)
elements Int
cap) = do
Int
r <- forall a. TVar a -> STM a
readTVar TVar Int
rindex
Maybe a
ele <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead TArray Int (Maybe a)
elements Int
r
a
a <- case Maybe a
ele of
Maybe a
Nothing -> forall a. STM a
retry
Just a
a -> do
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite TArray Int (Maybe a)
elements Int
r forall a. Maybe a
Nothing
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
rindex forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int
incMod Int
r Int
cap
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
tryReadTBQueue :: TBQueue a -> STM (Maybe a)
tryReadTBQueue :: forall a. TBQueue a -> STM (Maybe a)
tryReadTBQueue TBQueue a
q = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just (forall a. TBQueue a -> STM a
readTBQueue TBQueue a
q) forall a. STM a -> STM a -> STM a
`orElse` forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
flushTBQueue :: forall a. TBQueue a -> STM [a]
flushTBQueue :: forall a. TBQueue a -> STM [a]
flushTBQueue (TBQueue TVar Int
_rindex TVar Int
windex TArray Int (Maybe a)
elements Int
cap) = do
Int
w <- forall a. TVar a -> STM a
readTVar TVar Int
windex
Int -> [a] -> STM [a]
go (Int -> Int -> Int
decMod Int
w Int
cap) []
where
go :: Int -> [a] -> STM [a]
go :: Int -> [a] -> STM [a]
go Int
i [a]
acc = do
Maybe a
ele <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead TArray Int (Maybe a)
elements Int
i
case Maybe a
ele of
Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
acc
Just a
a -> do
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite TArray Int (Maybe a)
elements Int
i forall a. Maybe a
Nothing
Int -> [a] -> STM [a]
go (Int -> Int -> Int
decMod Int
i Int
cap) (a
a forall a. a -> [a] -> [a]
: [a]
acc)
peekTBQueue :: TBQueue a -> STM a
peekTBQueue :: forall a. TBQueue a -> STM a
peekTBQueue (TBQueue TVar Int
rindex TVar Int
_ TArray Int (Maybe a)
elements Int
_) = do
Int
r <- forall a. TVar a -> STM a
readTVar TVar Int
rindex
Maybe a
ele <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead TArray Int (Maybe a)
elements Int
r
case Maybe a
ele of
Maybe a
Nothing -> forall a. STM a
retry
Just a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
tryPeekTBQueue :: TBQueue a -> STM (Maybe a)
tryPeekTBQueue :: forall a. TBQueue a -> STM (Maybe a)
tryPeekTBQueue TBQueue a
q = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just (forall a. TBQueue a -> STM a
peekTBQueue TBQueue a
q) forall a. STM a -> STM a -> STM a
`orElse` forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
unGetTBQueue :: TBQueue a -> a -> STM ()
unGetTBQueue :: forall a. TBQueue a -> a -> STM ()
unGetTBQueue (TBQueue TVar Int
rindex TVar Int
_ TArray Int (Maybe a)
elements Int
cap) a
a = do
Int
r <- forall a. TVar a -> STM a
readTVar TVar Int
rindex
Maybe a
ele <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead TArray Int (Maybe a)
elements Int
r
case Maybe a
ele of
Maybe a
Nothing -> forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite TArray Int (Maybe a)
elements Int
r (forall a. a -> Maybe a
Just a
a)
Just a
_ -> forall a. STM a
retry
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
rindex forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int
decMod Int
r Int
cap
lengthTBQueue :: TBQueue a -> STM Natural
lengthTBQueue :: forall a. TBQueue a -> STM Natural
lengthTBQueue (TBQueue TVar Int
rindex TVar Int
windex TArray Int (Maybe a)
elements Int
cap) = do
Int
r <- forall a. TVar a -> STM a
readTVar TVar Int
rindex
Int
w <- forall a. TVar a -> STM a
readTVar TVar Int
windex
if Int
w forall a. Eq a => a -> a -> Bool
== Int
r then do
Maybe a
ele <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead TArray Int (Maybe a)
elements Int
r
case Maybe a
ele of
Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Natural
0
Just a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cap
else do
let len' :: Int
len' = Int
w forall a. Num a => a -> a -> a
- Int
r
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall a b. (Integral a, Num b) => a -> b
fromIntegral (if Int
len' forall a. Ord a => a -> a -> Bool
< Int
0 then Int
len' forall a. Num a => a -> a -> a
+ Int
cap else Int
len')
isEmptyTBQueue :: TBQueue a -> STM Bool
isEmptyTBQueue :: forall a. TBQueue a -> STM Bool
isEmptyTBQueue (TBQueue TVar Int
rindex TVar Int
windex TArray Int (Maybe a)
elements Int
_) = do
Int
r <- forall a. TVar a -> STM a
readTVar TVar Int
rindex
Int
w <- forall a. TVar a -> STM a
readTVar TVar Int
windex
if Int
w forall a. Eq a => a -> a -> Bool
== Int
r then do
Maybe a
ele <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead TArray Int (Maybe a)
elements Int
r
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall a. Maybe a -> Bool
isNothing Maybe a
ele
else
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isFullTBQueue :: TBQueue a -> STM Bool
isFullTBQueue :: forall a. TBQueue a -> STM Bool
isFullTBQueue (TBQueue TVar Int
rindex TVar Int
windex TArray Int (Maybe a)
elements Int
_) = do
Int
r <- forall a. TVar a -> STM a
readTVar TVar Int
rindex
Int
w <- forall a. TVar a -> STM a
readTVar TVar Int
windex
if Int
w forall a. Eq a => a -> a -> Bool
== Int
r then do
Maybe a
ele <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead TArray Int (Maybe a)
elements Int
r
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall a. Maybe a -> Bool
isJust Maybe a
ele
else
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
capacityTBQueue :: TBQueue a -> Natural
capacityTBQueue :: forall a. TBQueue a -> Natural
capacityTBQueue (TBQueue TVar Int
_ TVar Int
_ TArray Int (Maybe a)
_ Int
cap) = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cap