module ConIO.Communication
  ( -- ** Gate
    Gate (..),
    newGate,
    waitGate,
    openGate,

    -- ** Switch
    Switch (..),
    newSwitch,
    waitSwitch,
    setSwitch,
    unsetSwitch,
    toggleSwitch,

    -- ** Variable
    Variable (..),
    newVariable,
    waitVariable,
    writeVariable,
    getVariable,

    -- ** Slot
    Slot (..),
    newSlot,
    newEmptySlot,
    takeSlot,
    tryTakeSlot,
    readSlot,
    tryReadSlot,
    putSlot,
    tryPutSlot,

    -- ** Counter
    Counter (..),
    newCounter,
    getCounter,
    setCounter,
    incrementCounter,
    decrementCounter,

    -- ** Queue
    Queue (..),
    newQueue,
    popQueue,
    peekQueue,
    tryPopQueue,
    tryPeekQueue,
    pushQueue,
    isEmptyQueue,
  )
where

import ConIO.MonadSTM
import Control.Concurrent.STM
import Control.Monad (void)

-- | A 'Gate' is initially closed and can be opened with 'openGate'.
newtype Gate = Gate (TMVar ())

newGate :: (MonadSTM m) => m Gate
newGate :: forall (m :: * -> *). MonadSTM m => m Gate
newGate = TMVar () -> Gate
Gate (TMVar () -> Gate) -> m (TMVar ()) -> m Gate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (TMVar ()) -> IO (TMVar ()) -> m (TMVar ())
forall a. STM a -> IO a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> IO a -> m a
liftSTM_IO STM (TMVar ())
forall a. STM (TMVar a)
newEmptyTMVar IO (TMVar ())
forall a. IO (TMVar a)
newEmptyTMVarIO

-- | Wait for the 'Gate' to open.
waitGate :: (MonadSTM m) => Gate -> m ()
waitGate :: forall (m :: * -> *). MonadSTM m => Gate -> m ()
waitGate (Gate TMVar ()
mVar) = STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
forall a. TMVar a -> STM a
readTMVar TMVar ()
mVar

-- | Open a 'Gate'. You __cannot__ close a 'Gate'.
openGate :: (MonadSTM m) => Gate -> m ()
openGate :: forall (m :: * -> *). MonadSTM m => Gate -> m ()
openGate (Gate TMVar ()
mVar) = STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Bool -> STM ()) -> STM Bool -> STM ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
mVar ()

-- | A 'Switch' is either on or off.
newtype Switch = Switch (TVar Bool)

newSwitch :: (MonadSTM m) => Bool -> m Switch
newSwitch :: forall (m :: * -> *). MonadSTM m => Bool -> m Switch
newSwitch Bool
b = TVar Bool -> Switch
Switch (TVar Bool -> Switch) -> m (TVar Bool) -> m Switch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (TVar Bool) -> IO (TVar Bool) -> m (TVar Bool)
forall a. STM a -> IO a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> IO a -> m a
liftSTM_IO (Bool -> STM (TVar Bool)
forall a. a -> STM (TVar a)
newTVar Bool
b) (Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
b)

-- | Wait for the switch to turn on and execute the given 'STM' at the same time.
--
-- Be mindful that 'Switch' is only guaranteed to be on during the given 'STM' action.
waitSwitch :: (MonadSTM m) => Switch -> STM a -> m a
waitSwitch :: forall (m :: * -> *) a. MonadSTM m => Switch -> STM a -> m a
waitSwitch (Switch TVar Bool
tVar) STM a
m = STM a -> m a
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM a -> m a) -> STM a -> m a
forall a b. (a -> b) -> a -> b
$ do
  a <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
tVar
  if a
    then m
    else retry

-- | Turn on the 'Switch'
setSwitch :: (MonadSTM m) => Switch -> m ()
setSwitch :: forall (m :: * -> *). MonadSTM m => Switch -> m ()
setSwitch (Switch TVar Bool
tVar) = STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
tVar Bool
True

-- | Turn off the 'Switch'
unsetSwitch :: (MonadSTM m) => Switch -> m ()
unsetSwitch :: forall (m :: * -> *). MonadSTM m => Switch -> m ()
unsetSwitch (Switch TVar Bool
tVar) = STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
tVar Bool
False

-- | Toggle the 'Switch' between on/off.
toggleSwitch :: (MonadSTM m) => Switch -> m ()
toggleSwitch :: forall (m :: * -> *). MonadSTM m => Switch -> m ()
toggleSwitch (Switch TVar Bool
tVar) = STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  state <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
tVar
  if state
    then writeTVar tVar False
    else writeTVar tVar True

-- | A 'Variable' holds some value in a concurrency-safe manner.
newtype Variable a = Variable (TVar a)

-- | Wait until the value within the 'Variable' fulfills some condition
waitVariable :: (MonadSTM m) => (a -> Bool) -> Variable a -> m a
waitVariable :: forall (m :: * -> *) a.
MonadSTM m =>
(a -> Bool) -> Variable a -> m a
waitVariable a -> Bool
myCheck (Variable TVar a
tVar) = STM a -> m a
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM a -> m a) -> STM a -> m a
forall a b. (a -> b) -> a -> b
$ do
  a <- TVar a -> STM a
forall a. TVar a -> STM a
readTVar TVar a
tVar
  if (myCheck a)
    then pure a
    else retry

newVariable :: (MonadSTM m) => a -> m (Variable a)
newVariable :: forall (m :: * -> *) a. MonadSTM m => a -> m (Variable a)
newVariable a
a = TVar a -> Variable a
forall a. TVar a -> Variable a
Variable (TVar a -> Variable a) -> m (TVar a) -> m (Variable a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (TVar a) -> IO (TVar a) -> m (TVar a)
forall a. STM a -> IO a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> IO a -> m a
liftSTM_IO (a -> STM (TVar a)
forall a. a -> STM (TVar a)
newTVar a
a) (a -> IO (TVar a)
forall a. a -> IO (TVar a)
newTVarIO a
a)

-- | Write a value to the 'Variable'. Keep in mind that you can do this within 'STM'.
writeVariable :: (MonadSTM m) => Variable a -> a -> m ()
writeVariable :: forall (m :: * -> *) a. MonadSTM m => Variable a -> a -> m ()
writeVariable (Variable TVar a
tVar) a
a = STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar a
tVar a
a

-- | Get the value of the 'Variable'. Keep in mind that you can do this within 'STM'.
getVariable :: (MonadSTM m) => Variable a -> m a
getVariable :: forall (m :: * -> *) a. MonadSTM m => Variable a -> m a
getVariable (Variable TVar a
tVar) = STM a -> m a
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM a -> m a) -> STM a -> m a
forall a b. (a -> b) -> a -> b
$ TVar a -> STM a
forall a. TVar a -> STM a
readTVar TVar a
tVar

-- | A 'Counter' stores an int.
newtype Counter = Counter (TVar Int)

newCounter :: (MonadSTM m) => m Counter
newCounter :: forall (m :: * -> *). MonadSTM m => m Counter
newCounter = TVar Int -> Counter
Counter (TVar Int -> Counter) -> m (TVar Int) -> m Counter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (TVar Int) -> IO (TVar Int) -> m (TVar Int)
forall a. STM a -> IO a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> IO a -> m a
liftSTM_IO (Int -> STM (TVar Int)
forall a. a -> STM (TVar a)
newTVar Int
0) (Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0)

-- | Get the current value of the 'Counter'.
getCounter :: (MonadSTM m) => Counter -> m Int
getCounter :: forall (m :: * -> *). MonadSTM m => Counter -> m Int
getCounter (Counter TVar Int
tVar) = STM Int -> m Int
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM Int -> m Int) -> STM Int -> m Int
forall a b. (a -> b) -> a -> b
$ TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
tVar

-- | Set the value of the 'Counter'.
setCounter :: (MonadSTM m) => Counter -> Int -> m ()
setCounter :: forall (m :: * -> *). MonadSTM m => Counter -> Int -> m ()
setCounter (Counter TVar Int
tVar) Int
i = STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
tVar Int
i

-- | Increment the 'Counter' by one.
incrementCounter :: (MonadSTM m) => Counter -> m ()
incrementCounter :: forall (m :: * -> *). MonadSTM m => Counter -> m ()
incrementCounter (Counter TVar Int
tVar) = STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
tVar Int -> Int
forall a. Enum a => a -> a
succ

-- | Decrement the 'Counter' by one.
decrementCounter :: (MonadSTM m) => Counter -> m ()
decrementCounter :: forall (m :: * -> *). MonadSTM m => Counter -> m ()
decrementCounter (Counter TVar Int
tVar) = STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
tVar Int -> Int
forall a. Enum a => a -> a
pred

-- | A 'Queue' holds zero or more values.
newtype Queue a = Queue (TChan a)

newQueue :: (MonadSTM m) => m (Queue a)
newQueue :: forall (m :: * -> *) a. MonadSTM m => m (Queue a)
newQueue = TChan a -> Queue a
forall a. TChan a -> Queue a
Queue (TChan a -> Queue a) -> m (TChan a) -> m (Queue a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (TChan a) -> IO (TChan a) -> m (TChan a)
forall a. STM a -> IO a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> IO a -> m a
liftSTM_IO STM (TChan a)
forall a. STM (TChan a)
newTChan IO (TChan a)
forall a. IO (TChan a)
newTChanIO

-- | Pop the first element of the 'Queue', removing it from the queue.
-- Waits until an element is available.
popQueue :: (MonadSTM m) => Queue a -> m a
popQueue :: forall (m :: * -> *) a. MonadSTM m => Queue a -> m a
popQueue (Queue TChan a
chan) = STM a -> m a
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM a -> m a) -> STM a -> m a
forall a b. (a -> b) -> a -> b
$ TChan a -> STM a
forall a. TChan a -> STM a
readTChan TChan a
chan

-- | Get the first element of the 'Queue', __not__ removing it from the queue.
-- Waits until an element is available.
peekQueue :: (MonadSTM m) => Queue a -> m a
peekQueue :: forall (m :: * -> *) a. MonadSTM m => Queue a -> m a
peekQueue (Queue TChan a
chan) = STM a -> m a
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM a -> m a) -> STM a -> m a
forall a b. (a -> b) -> a -> b
$ TChan a -> STM a
forall a. TChan a -> STM a
peekTChan TChan a
chan

-- | Pop the first element of the 'Queue', removing it from the queue.
-- Does not wait and returns immediately, if no element is available.
tryPopQueue :: (MonadSTM m) => Queue a -> m (Maybe a)
tryPopQueue :: forall (m :: * -> *) a. MonadSTM m => Queue a -> m (Maybe a)
tryPopQueue (Queue TChan a
chan) = STM (Maybe a) -> m (Maybe a)
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM (Maybe a) -> m (Maybe a)) -> STM (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ TChan a -> STM (Maybe a)
forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan a
chan

-- | Get the first element of the 'Queue', __not__ removing it from the queue.
-- Does not wait and returns immediately, if no element is available.
tryPeekQueue :: (MonadSTM m) => Queue a -> m (Maybe a)
tryPeekQueue :: forall (m :: * -> *) a. MonadSTM m => Queue a -> m (Maybe a)
tryPeekQueue (Queue TChan a
chan) = STM (Maybe a) -> m (Maybe a)
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM (Maybe a) -> m (Maybe a)) -> STM (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ TChan a -> STM (Maybe a)
forall a. TChan a -> STM (Maybe a)
tryPeekTChan TChan a
chan

-- | Push an element to the back of the 'Queue'.
pushQueue :: (MonadSTM m) => Queue a -> a -> m ()
pushQueue :: forall (m :: * -> *) a. MonadSTM m => Queue a -> a -> m ()
pushQueue (Queue TChan a
chan) a
a = STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TChan a -> a -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan a
chan a
a

-- | Checks if the 'Queue' is empty.
isEmptyQueue :: (MonadSTM m) => Queue a -> m Bool
isEmptyQueue :: forall (m :: * -> *) a. MonadSTM m => Queue a -> m Bool
isEmptyQueue (Queue TChan a
chan) = STM Bool -> m Bool
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM Bool -> m Bool) -> STM Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ TChan a -> STM Bool
forall a. TChan a -> STM Bool
isEmptyTChan TChan a
chan

-- | A 'Slot' is either empty or contains an `a`.
newtype Slot a = Slot (TMVar a)

-- | Creates a new 'Slot' filled with `a`.
newSlot :: (MonadSTM m) => a -> m (Slot a)
newSlot :: forall (m :: * -> *) a. MonadSTM m => a -> m (Slot a)
newSlot a
a = TMVar a -> Slot a
forall a. TMVar a -> Slot a
Slot (TMVar a -> Slot a) -> m (TMVar a) -> m (Slot a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (TMVar a) -> IO (TMVar a) -> m (TMVar a)
forall a. STM a -> IO a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> IO a -> m a
liftSTM_IO (a -> STM (TMVar a)
forall a. a -> STM (TMVar a)
newTMVar a
a) (a -> IO (TMVar a)
forall a. a -> IO (TMVar a)
newTMVarIO a
a)

-- | Creates a new empty 'Slot'.
newEmptySlot :: (MonadSTM m) => m (Slot a)
newEmptySlot :: forall (m :: * -> *) a. MonadSTM m => m (Slot a)
newEmptySlot = TMVar a -> Slot a
forall a. TMVar a -> Slot a
Slot (TMVar a -> Slot a) -> m (TMVar a) -> m (Slot a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (TMVar a) -> IO (TMVar a) -> m (TMVar a)
forall a. STM a -> IO a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> IO a -> m a
liftSTM_IO STM (TMVar a)
forall a. STM (TMVar a)
newEmptyTMVar IO (TMVar a)
forall a. IO (TMVar a)
newEmptyTMVarIO

-- | Takes the element from the 'Slot'. Waits if there is no element.
-- Afterwards, the 'Slot' is empty.
takeSlot :: (MonadSTM m) => Slot a -> m a
takeSlot :: forall (m :: * -> *) a. MonadSTM m => Slot a -> m a
takeSlot (Slot TMVar a
var) = STM a -> m a
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (TMVar a -> STM a
forall a. TMVar a -> STM a
takeTMVar TMVar a
var)

-- | Tries to take the element from the 'Slot'. Does not wait for the 'Slot' to be filled.
-- Afterwards, the 'Slot' is empty.
tryTakeSlot :: (MonadSTM m) => Slot a -> m (Maybe a)
tryTakeSlot :: forall (m :: * -> *) a. MonadSTM m => Slot a -> m (Maybe a)
tryTakeSlot (Slot TMVar a
var) = STM (Maybe a) -> m (Maybe a)
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (TMVar a -> STM (Maybe a)
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar a
var)

-- | Reads the element from the 'Slot'. Waits if there is no element.
-- Afterwards, the 'Slot' is __not__ empty.
readSlot :: (MonadSTM m) => Slot a -> m a
readSlot :: forall (m :: * -> *) a. MonadSTM m => Slot a -> m a
readSlot (Slot TMVar a
var) = STM a -> m a
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (TMVar a -> STM a
forall a. TMVar a -> STM a
readTMVar TMVar a
var)

-- | Tries to read the element from the 'Slot'. Does not wait for the 'Slot' to be filled.
-- Afterwards, the 'Slot' is __not__ empty.
tryReadSlot :: (MonadSTM m) => Slot a -> m (Maybe a)
tryReadSlot :: forall (m :: * -> *) a. MonadSTM m => Slot a -> m (Maybe a)
tryReadSlot (Slot TMVar a
var) = STM (Maybe a) -> m (Maybe a)
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (TMVar a -> STM (Maybe a)
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar a
var)

-- | Puts an element into the slot if there is space. Waits until the 'Slot' is empty to fill it.
putSlot :: (MonadSTM m) => Slot a -> a -> m ()
putSlot :: forall (m :: * -> *) a. MonadSTM m => Slot a -> a -> m ()
putSlot (Slot TMVar a
var) a
a = STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (TMVar a -> a -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar a
var a
a)

-- | Tries to put an element into the 'Slot' if there is space.
-- Returns whether the putting was successful.
tryPutSlot :: (MonadSTM m) => Slot a -> a -> m Bool
tryPutSlot :: forall (m :: * -> *) a. MonadSTM m => Slot a -> a -> m Bool
tryPutSlot (Slot TMVar a
var) a
a = STM Bool -> m Bool
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (TMVar a -> a -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar a
var a
a)