{-# LANGUAGE TypeFamilies, CPP, BangPatterns #-}

{-| 
  A strawman implementation of concurrent Dequeues.  This
  implementation is so simple that it also makes a good reference
  implementation for debugging.

  The queue representation is simply an IORef containing a Data.Sequence.

  Also see "Data.Concurrent.Deque.Reference.DequeInstance".
  By convention a module of this name is also provided.

-}

module Data.Concurrent.Deque.Reference 
 (SimpleDeque(..),
  newQ, nullQ, newBoundedQ, pushL, pushR, tryPopR, tryPopL, tryPushL, tryPushR,
  
  _is_using_CAS -- Internal
 )
 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)
-- Toggle these and compare performance:
modify = atomicModifyIORefCAS
_is_using_CAS = True
#else
modify :: 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


-- | Stores a size bound (if any) as well as a mutable Seq.
data SimpleDeque elt = DQ {-# UNPACK #-} !Int !(IORef (Seq elt))


newQ :: IO (SimpleDeque elt)
newQ :: 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 (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 0 IORef (Seq elt)
r

newBoundedQ :: Int -> IO (SimpleDeque elt)
newBoundedQ :: Int -> IO (SimpleDeque elt)
newBoundedQ lim :: 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 (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 :: SimpleDeque t -> t -> IO ()
pushL (DQ 0 qr :: 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 (m :: * -> *) a. Monad m => a -> m a
return ()
 where 
   -- Here we are very strict to avoid stack leaks.
   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 n :: Int
n _) _ = [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ "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 :: SimpleDeque a -> IO (Maybe a)
tryPopR (DQ _ qr :: 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
$ \ s :: Seq a
s -> 
   case Seq a -> ViewR a
forall a. Seq a -> ViewR a
viewr Seq a
s of
     EmptyR  -> (Seq a
forall a. Seq a
empty, Maybe a
forall a. Maybe a
Nothing)
     s' :: Seq a
s' :> x :: a
x -> (Seq a
s', a -> Maybe a
forall a. a -> Maybe a
Just a
x)

nullQ :: SimpleDeque elt -> IO Bool
nullQ :: SimpleDeque elt -> IO Bool
nullQ (DQ _ qr :: 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 
       EmptyR -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       _ :> _ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

--   -- This simplistic version simply spins:
--   popR q = do x <- tryPopR q 
-- 	      case x of 
-- 	        Nothing -> popR q
-- 		Just x  -> return x

--   popL q = do x <- tryPopL q 
-- 	      case x of 
-- 	        Nothing -> popL q
-- 		Just x  -> return x

tryPopL :: SimpleDeque a -> IO (Maybe a)
tryPopL :: SimpleDeque a -> IO (Maybe a)
tryPopL (DQ _ qr :: 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
$ \s :: Seq a
s -> 
  case Seq a -> ViewL a
forall a. Seq a -> ViewL a
viewl Seq a
s of
    EmptyL  -> (Seq a
forall a. Seq a
empty, Maybe a
forall a. Maybe a
Nothing)
    x :: a
x :< s' :: Seq a
s' -> (Seq a
s', a -> Maybe a
forall a. a -> Maybe a
Just a
x)

pushR :: SimpleDeque t -> t -> IO ()
pushR :: SimpleDeque t -> t -> IO ()
pushR (DQ 0 qr :: IORef (Seq t)
qr) x :: 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 (\s :: Seq t
s -> (Seq t
s Seq t -> t -> Seq t
forall a. Seq a -> a -> Seq a
|> t
x, ()))
pushR (DQ n :: Int
n _) _ = [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ "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 :: SimpleDeque a -> a -> IO Bool
tryPushL q :: SimpleDeque a
q@(DQ 0 _) v :: a
v = SimpleDeque a -> a -> IO ()
forall t. SimpleDeque t -> t -> IO ()
pushL SimpleDeque a
q a
v IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
tryPushL (DQ lim :: Int
lim qr :: IORef (Seq a)
qr) v :: 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
$ \s :: 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 :: SimpleDeque a -> a -> IO Bool
tryPushR q :: SimpleDeque a
q@(DQ 0 _) v :: a
v = SimpleDeque a -> a -> IO ()
forall t. SimpleDeque t -> t -> IO ()
pushR SimpleDeque a
q a
v IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
tryPushR (DQ lim :: Int
lim qr :: IORef (Seq a)
qr) v :: 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
$ \s :: 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)

--------------------------------------------------------------------------------
--   Instances
--------------------------------------------------------------------------------

instance C.DequeClass SimpleDeque where 
  newQ :: IO (SimpleDeque elt)
newQ     = IO (SimpleDeque elt)
forall elt. IO (SimpleDeque elt)
newQ
  nullQ :: SimpleDeque elt -> IO Bool
nullQ    = SimpleDeque elt -> IO Bool
forall elt. SimpleDeque elt -> IO Bool
nullQ
  pushL :: SimpleDeque elt -> elt -> IO ()
pushL    = SimpleDeque elt -> elt -> IO ()
forall t. SimpleDeque t -> t -> IO ()
pushL
  tryPopR :: SimpleDeque elt -> IO (Maybe elt)
tryPopR  = SimpleDeque elt -> IO (Maybe elt)
forall elt. SimpleDeque elt -> IO (Maybe elt)
tryPopR
  leftThreadSafe :: SimpleDeque elt -> Bool
leftThreadSafe _ = Bool
True
  rightThreadSafe :: SimpleDeque elt -> Bool
rightThreadSafe _ = Bool
True
instance C.PopL SimpleDeque where 
  tryPopL :: SimpleDeque elt -> IO (Maybe elt)
tryPopL  = SimpleDeque elt -> IO (Maybe elt)
forall elt. SimpleDeque elt -> IO (Maybe elt)
tryPopL
instance C.PushR SimpleDeque where 
  pushR :: SimpleDeque elt -> elt -> IO ()
pushR    = SimpleDeque elt -> elt -> IO ()
forall t. SimpleDeque t -> t -> IO ()
pushR

instance C.BoundedL SimpleDeque where 
  tryPushL :: SimpleDeque elt -> elt -> IO Bool
tryPushL    = SimpleDeque elt -> elt -> IO Bool
forall elt. SimpleDeque elt -> elt -> IO Bool
tryPushL
  newBoundedQ :: Int -> IO (SimpleDeque elt)
newBoundedQ = Int -> IO (SimpleDeque elt)
forall elt. Int -> IO (SimpleDeque elt)
newBoundedQ

instance C.BoundedR SimpleDeque where 
  tryPushR :: SimpleDeque elt -> elt -> IO Bool
tryPushR = SimpleDeque elt -> elt -> IO Bool
forall elt. SimpleDeque elt -> elt -> IO Bool
tryPushR