{-# 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 :: forall a b. IORef a -> (a -> (a, b)) -> IO b
modify = 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 :: forall elt. IO (SimpleDeque elt)
newQ = do IORef (Seq elt)
r <- forall a. a -> IO (IORef a)
newIORef forall a. Seq a
empty
	  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! 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 <- forall a. a -> IO (IORef a)
newIORef forall a. Seq a
empty
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! 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 
   () <- forall a b. IORef a -> (a -> (a, b)) -> IO b
modify IORef (Seq t)
qr Seq t -> (Seq t, ())
addleft
   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 :: forall a b. a -> b -> b
`seq` (Seq t, ())
pair
    where extended :: Seq t
extended = t
x 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
_ = forall a. HasCallStack => [Char] -> a
errorforall a b. (a -> b) -> a -> b
$ [Char]
"should not call pushL on Deque with size bound "forall a. [a] -> [a] -> [a]
++ 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) = forall a b. IORef a -> (a -> (a, b)) -> IO b
modify IORef (Seq a)
qr forall a b. (a -> b) -> a -> b
$ \ Seq a
s -> 
   case forall a. Seq a -> ViewR a
viewr Seq a
s of
     ViewR a
EmptyR  -> (forall a. Seq a
empty, forall a. Maybe a
Nothing)
     Seq a
s' :> a
x -> (Seq a
s', 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 <- forall a. IORef a -> IO a
readIORef IORef (Seq elt)
qr
     case forall a. Seq a -> ViewR a
viewr Seq elt
s of 
       ViewR elt
EmptyR -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       Seq elt
_ :> elt
_ -> 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 :: forall a. SimpleDeque a -> IO (Maybe a)
tryPopL (DQ Int
_ IORef (Seq a)
qr) = forall a b. IORef a -> (a -> (a, b)) -> IO b
modify IORef (Seq a)
qr forall a b. (a -> b) -> a -> b
$ \Seq a
s -> 
  case forall a. Seq a -> ViewL a
viewl Seq a
s of
    ViewL a
EmptyL  -> (forall a. Seq a
empty, forall a. Maybe a
Nothing)
    a
x :< Seq a
s' -> (Seq a
s', 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 = forall a b. IORef a -> (a -> (a, b)) -> IO b
modify IORef (Seq t)
qr (\Seq t
s -> (Seq t
s forall a. Seq a -> a -> Seq a
|> t
x, ()))
pushR (DQ Int
n IORef (Seq t)
_) t
_ = forall a. HasCallStack => [Char] -> a
errorforall a b. (a -> b) -> a -> b
$ [Char]
"should not call pushR on Deque with size bound "forall a. [a] -> [a] -> [a]
++ 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 = forall t. SimpleDeque t -> t -> IO ()
pushL SimpleDeque a
q a
v forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
tryPushL (DQ Int
lim IORef (Seq a)
qr) a
v = 
  forall a b. IORef a -> (a -> (a, b)) -> IO b
modify IORef (Seq a)
qr forall a b. (a -> b) -> a -> b
$ \Seq a
s -> 
     if forall a. Seq a -> Int
length Seq a
s forall a. Eq a => a -> a -> Bool
== Int
lim
     then (Seq a
s, Bool
False)
     else (a
v 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 = forall t. SimpleDeque t -> t -> IO ()
pushR SimpleDeque a
q a
v forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
tryPushR (DQ Int
lim IORef (Seq a)
qr) a
v = 
  forall a b. IORef a -> (a -> (a, b)) -> IO b
modify IORef (Seq a)
qr forall a b. (a -> b) -> a -> b
$ \Seq a
s -> 
     if forall a. Seq a -> Int
length Seq a
s forall a. Eq a => a -> a -> Bool
== Int
lim
     then (Seq a
s, Bool
False)
     else (Seq a
s forall a. Seq a -> a -> Seq a
|> a
v, Bool
True)

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

instance C.DequeClass SimpleDeque where 
  newQ :: forall elt. IO (SimpleDeque elt)
newQ     = forall elt. IO (SimpleDeque elt)
newQ
  nullQ :: forall elt. SimpleDeque elt -> IO Bool
nullQ    = forall elt. SimpleDeque elt -> IO Bool
nullQ
  pushL :: forall t. SimpleDeque t -> t -> IO ()
pushL    = forall t. SimpleDeque t -> t -> IO ()
pushL
  tryPopR :: forall a. SimpleDeque a -> IO (Maybe a)
tryPopR  = 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  = forall a. SimpleDeque a -> IO (Maybe a)
tryPopL
instance C.PushR SimpleDeque where 
  pushR :: forall t. SimpleDeque t -> t -> IO ()
pushR    = forall t. SimpleDeque t -> t -> IO ()
pushR

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

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