{-|
Module      : Database.PostgreSQL.Replicant.Queue
Description : Bounded and unbounded FIFO queues
Copyright   : (c) James King, 2020, 2021
License     : BSD3
Maintainer  : [email protected]
Stability   : experimental
Portability : POSIX

Shared FIFO queues
-}
module Database.PostgreSQL.Replicant.Queue where

import Control.Concurrent.MVar
import Data.Sequence (Seq, ViewR (..), (<|), (|>))
import qualified Data.Sequence as S

data BoundedFifoQueueMeta a
  = BoundedFifoQueueMeta
  { BoundedFifoQueueMeta a -> Int
boundedFifoQueueSize :: Int
  , BoundedFifoQueueMeta a -> Seq a
boundedFifoQueue     :: Seq a
  }
  deriving (BoundedFifoQueueMeta a -> BoundedFifoQueueMeta a -> Bool
(BoundedFifoQueueMeta a -> BoundedFifoQueueMeta a -> Bool)
-> (BoundedFifoQueueMeta a -> BoundedFifoQueueMeta a -> Bool)
-> Eq (BoundedFifoQueueMeta a)
forall a.
Eq a =>
BoundedFifoQueueMeta a -> BoundedFifoQueueMeta a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BoundedFifoQueueMeta a -> BoundedFifoQueueMeta a -> Bool
$c/= :: forall a.
Eq a =>
BoundedFifoQueueMeta a -> BoundedFifoQueueMeta a -> Bool
== :: BoundedFifoQueueMeta a -> BoundedFifoQueueMeta a -> Bool
$c== :: forall a.
Eq a =>
BoundedFifoQueueMeta a -> BoundedFifoQueueMeta a -> Bool
Eq, Int -> BoundedFifoQueueMeta a -> ShowS
[BoundedFifoQueueMeta a] -> ShowS
BoundedFifoQueueMeta a -> String
(Int -> BoundedFifoQueueMeta a -> ShowS)
-> (BoundedFifoQueueMeta a -> String)
-> ([BoundedFifoQueueMeta a] -> ShowS)
-> Show (BoundedFifoQueueMeta a)
forall a. Show a => Int -> BoundedFifoQueueMeta a -> ShowS
forall a. Show a => [BoundedFifoQueueMeta a] -> ShowS
forall a. Show a => BoundedFifoQueueMeta a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BoundedFifoQueueMeta a] -> ShowS
$cshowList :: forall a. Show a => [BoundedFifoQueueMeta a] -> ShowS
show :: BoundedFifoQueueMeta a -> String
$cshow :: forall a. Show a => BoundedFifoQueueMeta a -> String
showsPrec :: Int -> BoundedFifoQueueMeta a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> BoundedFifoQueueMeta a -> ShowS
Show)

newtype BoundedFifoQueue a = BoundedFifoQueue (MVar (BoundedFifoQueueMeta a))

newtype BoundedQueueException a
  = BoundedQueueOverflow a
  deriving (BoundedQueueException a -> BoundedQueueException a -> Bool
(BoundedQueueException a -> BoundedQueueException a -> Bool)
-> (BoundedQueueException a -> BoundedQueueException a -> Bool)
-> Eq (BoundedQueueException a)
forall a.
Eq a =>
BoundedQueueException a -> BoundedQueueException a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BoundedQueueException a -> BoundedQueueException a -> Bool
$c/= :: forall a.
Eq a =>
BoundedQueueException a -> BoundedQueueException a -> Bool
== :: BoundedQueueException a -> BoundedQueueException a -> Bool
$c== :: forall a.
Eq a =>
BoundedQueueException a -> BoundedQueueException a -> Bool
Eq, Int -> BoundedQueueException a -> ShowS
[BoundedQueueException a] -> ShowS
BoundedQueueException a -> String
(Int -> BoundedQueueException a -> ShowS)
-> (BoundedQueueException a -> String)
-> ([BoundedQueueException a] -> ShowS)
-> Show (BoundedQueueException a)
forall a. Show a => Int -> BoundedQueueException a -> ShowS
forall a. Show a => [BoundedQueueException a] -> ShowS
forall a. Show a => BoundedQueueException a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BoundedQueueException a] -> ShowS
$cshowList :: forall a. Show a => [BoundedQueueException a] -> ShowS
show :: BoundedQueueException a -> String
$cshow :: forall a. Show a => BoundedQueueException a -> String
showsPrec :: Int -> BoundedQueueException a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> BoundedQueueException a -> ShowS
Show)

emptyBounded :: Int -> IO (BoundedFifoQueue a)
emptyBounded :: Int -> IO (BoundedFifoQueue a)
emptyBounded Int
size =
  MVar (BoundedFifoQueueMeta a) -> BoundedFifoQueue a
forall a. MVar (BoundedFifoQueueMeta a) -> BoundedFifoQueue a
BoundedFifoQueue (MVar (BoundedFifoQueueMeta a) -> BoundedFifoQueue a)
-> IO (MVar (BoundedFifoQueueMeta a)) -> IO (BoundedFifoQueue a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BoundedFifoQueueMeta a -> IO (MVar (BoundedFifoQueueMeta a))
forall a. a -> IO (MVar a)
newMVar (Int -> Seq a -> BoundedFifoQueueMeta a
forall a. Int -> Seq a -> BoundedFifoQueueMeta a
BoundedFifoQueueMeta Int
size Seq a
forall a. Seq a
S.empty)

enqueueBounded :: BoundedFifoQueue a -> a -> IO (Either (BoundedQueueException a) ())
enqueueBounded :: BoundedFifoQueue a -> a -> IO (Either (BoundedQueueException a) ())
enqueueBounded (BoundedFifoQueue MVar (BoundedFifoQueueMeta a)
mQueue) a
x = do
  b :: BoundedFifoQueueMeta a
b@(BoundedFifoQueueMeta Int
size Seq a
queue) <- MVar (BoundedFifoQueueMeta a) -> IO (BoundedFifoQueueMeta a)
forall a. MVar a -> IO a
takeMVar MVar (BoundedFifoQueueMeta a)
mQueue
  if Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Seq a -> Int
forall a. Seq a -> Int
S.length Seq a
queue
    then Either (BoundedQueueException a) ()
-> IO (Either (BoundedQueueException a) ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (BoundedQueueException a) ()
 -> IO (Either (BoundedQueueException a) ()))
-> Either (BoundedQueueException a) ()
-> IO (Either (BoundedQueueException a) ())
forall a b. (a -> b) -> a -> b
$ BoundedQueueException a -> Either (BoundedQueueException a) ()
forall a b. a -> Either a b
Left (BoundedQueueException a -> Either (BoundedQueueException a) ())
-> BoundedQueueException a -> Either (BoundedQueueException a) ()
forall a b. (a -> b) -> a -> b
$ a -> BoundedQueueException a
forall a. a -> BoundedQueueException a
BoundedQueueOverflow a
x
    else do
    MVar (BoundedFifoQueueMeta a) -> BoundedFifoQueueMeta a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (BoundedFifoQueueMeta a)
mQueue (BoundedFifoQueueMeta a -> IO ())
-> BoundedFifoQueueMeta a -> IO ()
forall a b. (a -> b) -> a -> b
$ BoundedFifoQueueMeta a
b { boundedFifoQueue :: Seq a
boundedFifoQueue = a
x a -> Seq a -> Seq a
forall a. a -> Seq a -> Seq a
<| Seq a
queue }
    Either (BoundedQueueException a) ()
-> IO (Either (BoundedQueueException a) ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (BoundedQueueException a) ()
 -> IO (Either (BoundedQueueException a) ()))
-> Either (BoundedQueueException a) ()
-> IO (Either (BoundedQueueException a) ())
forall a b. (a -> b) -> a -> b
$ () -> Either (BoundedQueueException a) ()
forall a b. b -> Either a b
Right ()

newtype FifoQueue a = FifoQueue (MVar (Seq a))

empty :: IO (FifoQueue a)
empty :: IO (FifoQueue a)
empty = MVar (Seq a) -> FifoQueue a
forall a. MVar (Seq a) -> FifoQueue a
FifoQueue (MVar (Seq a) -> FifoQueue a)
-> IO (MVar (Seq a)) -> IO (FifoQueue a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq a -> IO (MVar (Seq a))
forall a. a -> IO (MVar a)
newMVar Seq a
forall a. Seq a
S.empty

-- | Return @True@ if the queue is empty
null :: FifoQueue a -> IO Bool
null :: FifoQueue a -> IO Bool
null (FifoQueue MVar (Seq a)
mQueue) = do
  Seq a
queue <- MVar (Seq a) -> IO (Seq a)
forall a. MVar a -> IO a
readMVar MVar (Seq a)
mQueue
  Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Seq a -> Bool
forall a. Seq a -> Bool
S.null Seq a
queue

-- | Remove an item from the end of the non-empty queue.
dequeue :: FifoQueue a -> IO (Maybe a)
dequeue :: FifoQueue a -> IO (Maybe a)
dequeue (FifoQueue MVar (Seq a)
mQueue) = do
  Seq a
queue <- MVar (Seq a) -> IO (Seq a)
forall a. MVar a -> IO a
takeMVar MVar (Seq a)
mQueue
  case Seq a -> ViewR a
forall a. Seq a -> ViewR a
S.viewr Seq a
queue of
    ViewR a
S.EmptyR -> do
      MVar (Seq a) -> Seq a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Seq a)
mQueue Seq a
queue
      Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    Seq a
rest :> a
x -> do
      MVar (Seq a) -> Seq a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Seq a)
mQueue Seq a
rest
      Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x

-- | Put an item on the front of the queue.
enqueue :: FifoQueue a -> a -> IO ()
enqueue :: FifoQueue a -> a -> IO ()
enqueue (FifoQueue MVar (Seq a)
mQueue) a
x = do
  Seq a
queue <- MVar (Seq a) -> IO (Seq a)
forall a. MVar a -> IO a
takeMVar MVar (Seq a)
mQueue
  MVar (Seq a) -> Seq a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Seq a)
mQueue (Seq a -> IO ()) -> Seq a -> IO ()
forall a b. (a -> b) -> a -> b
$ a
x a -> Seq a -> Seq a
forall a. a -> Seq a -> Seq a
<| Seq a
queue

-- | Put an item on the end of the queue so that it will be dequeued first.
enqueueRight :: FifoQueue a -> a -> IO ()
enqueueRight :: FifoQueue a -> a -> IO ()
enqueueRight (FifoQueue MVar (Seq a)
mQueue) a
x = do
  Seq a
queue <- MVar (Seq a) -> IO (Seq a)
forall a. MVar a -> IO a
takeMVar MVar (Seq a)
mQueue
  MVar (Seq a) -> Seq a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Seq a)
mQueue (Seq a -> IO ()) -> Seq a -> IO ()
forall a b. (a -> b) -> a -> b
$ Seq a
queue Seq a -> a -> Seq a
forall a. Seq a -> a -> Seq a
|> a
x