{-# LANGUAGE TypeFamilies, CPP, BangPatterns #-}
module Data.Concurrent.Deque.Reference
(SimpleDeque(..),
newQ, nullQ, newBoundedQ, pushL, pushR, tryPopR, tryPopL, tryPushL, tryPushR,
_is_using_CAS
)
where
import Prelude hiding (length)
import qualified Data.Concurrent.Deque.Class as C
import Data.Sequence
import Data.IORef
#ifdef USE_CAS
#warning "abstract-deque: reference implementation using CAS..."
import Data.CAS (atomicModifyIORefCAS)
modify = atomicModifyIORefCAS
_is_using_CAS = True
#else
modify :: forall a b. IORef a -> (a -> (a, b)) -> IO b
modify = IORef a -> (a -> (a, b)) -> IO b
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef
_is_using_CAS :: Bool
_is_using_CAS = Bool
False
#endif
{-# INLINE modify #-}
modify :: IORef a -> (a -> (a, b)) -> IO b
_is_using_CAS :: Bool
data SimpleDeque elt = DQ {-# UNPACK #-} !Int !(IORef (Seq elt))
newQ :: IO (SimpleDeque elt)
newQ :: forall elt. IO (SimpleDeque elt)
newQ = do IORef (Seq elt)
r <- Seq elt -> IO (IORef (Seq elt))
forall a. a -> IO (IORef a)
newIORef Seq elt
forall a. Seq a
empty
SimpleDeque elt -> IO (SimpleDeque elt)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SimpleDeque elt -> IO (SimpleDeque elt))
-> SimpleDeque elt -> IO (SimpleDeque elt)
forall a b. (a -> b) -> a -> b
$! Int -> IORef (Seq elt) -> SimpleDeque elt
forall elt. Int -> IORef (Seq elt) -> SimpleDeque elt
DQ Int
0 IORef (Seq elt)
r
newBoundedQ :: Int -> IO (SimpleDeque elt)
newBoundedQ :: forall elt. Int -> IO (SimpleDeque elt)
newBoundedQ Int
lim =
do IORef (Seq elt)
r <- Seq elt -> IO (IORef (Seq elt))
forall a. a -> IO (IORef a)
newIORef Seq elt
forall a. Seq a
empty
SimpleDeque elt -> IO (SimpleDeque elt)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SimpleDeque elt -> IO (SimpleDeque elt))
-> SimpleDeque elt -> IO (SimpleDeque elt)
forall a b. (a -> b) -> a -> b
$! Int -> IORef (Seq elt) -> SimpleDeque elt
forall elt. Int -> IORef (Seq elt) -> SimpleDeque elt
DQ Int
lim IORef (Seq elt)
r
pushL :: SimpleDeque t -> t -> IO ()
pushL :: forall t. SimpleDeque t -> t -> IO ()
pushL (DQ Int
0 IORef (Seq t)
qr) !t
x = do
() <- IORef (Seq t) -> (Seq t -> (Seq t, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
modify IORef (Seq t)
qr Seq t -> (Seq t, ())
addleft
() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
addleft :: Seq t -> (Seq t, ())
addleft !Seq t
s = Seq t
extended Seq t -> (Seq t, ()) -> (Seq t, ())
forall a b. a -> b -> b
`seq` (Seq t, ())
pair
where extended :: Seq t
extended = t
x t -> Seq t -> Seq t
forall a. a -> Seq a -> Seq a
<| Seq t
s
pair :: (Seq t, ())
pair = (Seq t
extended, ())
pushL (DQ Int
n IORef (Seq t)
_) t
_ = [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"should not call pushL on Deque with size bound "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
tryPopR :: SimpleDeque a -> IO (Maybe a)
tryPopR :: forall a. SimpleDeque a -> IO (Maybe a)
tryPopR (DQ Int
_ IORef (Seq a)
qr) = IORef (Seq a) -> (Seq a -> (Seq a, Maybe a)) -> IO (Maybe a)
forall a b. IORef a -> (a -> (a, b)) -> IO b
modify IORef (Seq a)
qr ((Seq a -> (Seq a, Maybe a)) -> IO (Maybe a))
-> (Seq a -> (Seq a, Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \ Seq a
s ->
case Seq a -> ViewR a
forall a. Seq a -> ViewR a
viewr Seq a
s of
ViewR a
EmptyR -> (Seq a
forall a. Seq a
empty, Maybe a
forall a. Maybe a
Nothing)
Seq a
s' :> a
x -> (Seq a
s', a -> Maybe a
forall a. a -> Maybe a
Just a
x)
nullQ :: SimpleDeque elt -> IO Bool
nullQ :: forall elt. SimpleDeque elt -> IO Bool
nullQ (DQ Int
_ IORef (Seq elt)
qr) =
do Seq elt
s <- IORef (Seq elt) -> IO (Seq elt)
forall a. IORef a -> IO a
readIORef IORef (Seq elt)
qr
case Seq elt -> ViewR elt
forall a. Seq a -> ViewR a
viewr Seq elt
s of
ViewR elt
EmptyR -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Seq elt
_ :> elt
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
tryPopL :: SimpleDeque a -> IO (Maybe a)
tryPopL :: forall a. SimpleDeque a -> IO (Maybe a)
tryPopL (DQ Int
_ IORef (Seq a)
qr) = IORef (Seq a) -> (Seq a -> (Seq a, Maybe a)) -> IO (Maybe a)
forall a b. IORef a -> (a -> (a, b)) -> IO b
modify IORef (Seq a)
qr ((Seq a -> (Seq a, Maybe a)) -> IO (Maybe a))
-> (Seq a -> (Seq a, Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Seq a
s ->
case Seq a -> ViewL a
forall a. Seq a -> ViewL a
viewl Seq a
s of
ViewL a
EmptyL -> (Seq a
forall a. Seq a
empty, Maybe a
forall a. Maybe a
Nothing)
a
x :< Seq a
s' -> (Seq a
s', a -> Maybe a
forall a. a -> Maybe a
Just a
x)
pushR :: SimpleDeque t -> t -> IO ()
pushR :: forall t. SimpleDeque t -> t -> IO ()
pushR (DQ Int
0 IORef (Seq t)
qr) t
x = IORef (Seq t) -> (Seq t -> (Seq t, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
modify IORef (Seq t)
qr (\Seq t
s -> (Seq t
s Seq t -> t -> Seq t
forall a. Seq a -> a -> Seq a
|> t
x, ()))
pushR (DQ Int
n IORef (Seq t)
_) t
_ = [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"should not call pushR on Deque with size bound "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
tryPushL :: SimpleDeque a -> a -> IO Bool
tryPushL :: forall a. SimpleDeque a -> a -> IO Bool
tryPushL q :: SimpleDeque a
q@(DQ Int
0 IORef (Seq a)
_) a
v = SimpleDeque a -> a -> IO ()
forall t. SimpleDeque t -> t -> IO ()
pushL SimpleDeque a
q a
v IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
tryPushL (DQ Int
lim IORef (Seq a)
qr) a
v =
IORef (Seq a) -> (Seq a -> (Seq a, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
modify IORef (Seq a)
qr ((Seq a -> (Seq a, Bool)) -> IO Bool)
-> (Seq a -> (Seq a, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Seq a
s ->
if Seq a -> Int
forall a. Seq a -> Int
length Seq a
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lim
then (Seq a
s, Bool
False)
else (a
v a -> Seq a -> Seq a
forall a. a -> Seq a -> Seq a
<| Seq a
s, Bool
True)
tryPushR :: SimpleDeque a -> a -> IO Bool
tryPushR :: forall a. SimpleDeque a -> a -> IO Bool
tryPushR q :: SimpleDeque a
q@(DQ Int
0 IORef (Seq a)
_) a
v = SimpleDeque a -> a -> IO ()
forall t. SimpleDeque t -> t -> IO ()
pushR SimpleDeque a
q a
v IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
tryPushR (DQ Int
lim IORef (Seq a)
qr) a
v =
IORef (Seq a) -> (Seq a -> (Seq a, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
modify IORef (Seq a)
qr ((Seq a -> (Seq a, Bool)) -> IO Bool)
-> (Seq a -> (Seq a, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Seq a
s ->
if Seq a -> Int
forall a. Seq a -> Int
length Seq a
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lim
then (Seq a
s, Bool
False)
else (Seq a
s Seq a -> a -> Seq a
forall a. Seq a -> a -> Seq a
|> a
v, Bool
True)
instance C.DequeClass SimpleDeque where
newQ :: forall elt. IO (SimpleDeque elt)
newQ = IO (SimpleDeque elt)
forall elt. IO (SimpleDeque elt)
newQ
nullQ :: forall elt. SimpleDeque elt -> IO Bool
nullQ = SimpleDeque elt -> IO Bool
forall elt. SimpleDeque elt -> IO Bool
nullQ
pushL :: forall t. SimpleDeque t -> t -> IO ()
pushL = SimpleDeque elt -> elt -> IO ()
forall t. SimpleDeque t -> t -> IO ()
pushL
tryPopR :: forall a. SimpleDeque a -> IO (Maybe a)
tryPopR = SimpleDeque elt -> IO (Maybe elt)
forall a. SimpleDeque a -> IO (Maybe a)
tryPopR
leftThreadSafe :: forall elt. SimpleDeque elt -> Bool
leftThreadSafe SimpleDeque elt
_ = Bool
True
rightThreadSafe :: forall elt. SimpleDeque elt -> Bool
rightThreadSafe SimpleDeque elt
_ = Bool
True
instance C.PopL SimpleDeque where
tryPopL :: forall a. SimpleDeque a -> IO (Maybe a)
tryPopL = SimpleDeque elt -> IO (Maybe elt)
forall a. SimpleDeque a -> IO (Maybe a)
tryPopL
instance C.PushR SimpleDeque where
pushR :: forall t. SimpleDeque t -> t -> IO ()
pushR = SimpleDeque elt -> elt -> IO ()
forall t. SimpleDeque t -> t -> IO ()
pushR
instance C.BoundedL SimpleDeque where
tryPushL :: forall a. SimpleDeque a -> a -> IO Bool
tryPushL = SimpleDeque elt -> elt -> IO Bool
forall a. SimpleDeque a -> a -> IO Bool
tryPushL
newBoundedQ :: forall elt. Int -> IO (SimpleDeque elt)
newBoundedQ = Int -> IO (SimpleDeque elt)
forall elt. Int -> IO (SimpleDeque elt)
newBoundedQ
instance C.BoundedR SimpleDeque where
tryPushR :: forall a. SimpleDeque a -> a -> IO Bool
tryPushR = SimpleDeque elt -> elt -> IO Bool
forall a. SimpleDeque a -> a -> IO Bool
tryPushR