{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}

module Multitasking.Communication
  ( -- ** Variable
    Variable (..),
    newVariable,
    readVariable,
    writeVariable,

    -- ** Option
    Option (..),
    newOption,
    newEmptyOption,
    writeOption,
    putOption,
    offerOption,
    awaitOption,
    probeOption,
    takeOption,
    drainOption,

    -- ** Gate
    Gate (..),
    newGate,
    awaitGate,
    openGate,

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

    -- ** Condition,
    Condition (..),
    newCondition,
    awaitCondition,
    probeCondition,

    -- ** Slot
    Slot (..),
    newSlot,
    putSlot,
    awaitSlot,
    probeSlot,

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

    -- ** Sink
    Sink,
    newSink,
    putSink,

    -- ** Source
    Source,
    newSource,
    takeSource,
    drainSource,

    -- ** Queue
    Queue (..),
    newQueue,
    popQueue,
    peekQueue,
    putQueue,
    isEmptyQueue,
    queueSource,
    queueSink,
  )
where

import Control.Concurrent.STM
import Data.Functor (($>))
import Data.Functor.Contravariant
import Multitasking.MonadSTM

-- | 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

-- | Open a 'Gate'. You __cannot__ close a 'Gate'.
openGate :: (MonadSTM m) => Gate -> m ()
openGate :: forall (m :: * -> *). MonadSTM m => Gate -> m ()
openGate (Gate TMVar ()
tmvar) = 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 -> a -> STM ()
writeTMVar TMVar ()
tmvar ()

-- | Wait for the 'Gate' to open.
awaitGate :: (MonadSTM m) => Gate -> m ()
awaitGate :: forall (m :: * -> *). MonadSTM m => Gate -> m ()
awaitGate (Gate TMVar ()
tmvar) = 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 ()
tmvar

-- | 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 until the 'Switch' is on
awaitSwitch :: (MonadSTM m) => Switch -> m ()
awaitSwitch :: forall (m :: * -> *). MonadSTM m => Switch -> m ()
awaitSwitch (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
  result <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
tvar
  check result

-- | 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, non-blocking manner.
newtype Variable a = Variable (TVar a)

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)

-- | Read in a non-blocking manner
readVariable :: (MonadSTM m) => Variable a -> m a
readVariable :: forall (m :: * -> *) a. MonadSTM m => Variable a -> m a
readVariable (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

-- | Write in a non-blocking manner
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

-- | A 'Condition' puts a constraint on a value that you can wait for
data Condition a = Condition (a -> Bool) (STM a)

newCondition :: (a -> Bool) -> STM a -> Condition a
newCondition :: forall a. (a -> Bool) -> STM a -> Condition a
newCondition a -> Bool
f STM a
stm = (a -> Bool) -> STM a -> Condition a
forall a. (a -> Bool) -> STM a -> Condition a
Condition a -> Bool
f STM a
stm

-- | Wait for the 'Condition' to be true
awaitCondition :: (MonadSTM m) => Condition a -> m a
awaitCondition :: forall (m :: * -> *) a. MonadSTM m => Condition a -> m a
awaitCondition (Condition a -> Bool
f STM a
stm) = 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 <- STM a
stm
  check (f a)
  pure a

-- | Probe the 'Condition' status
probeCondition :: (MonadSTM m) => Condition a -> m (Maybe a)
probeCondition :: forall (m :: * -> *) a. MonadSTM m => Condition a -> m (Maybe a)
probeCondition (Condition a -> Bool
f STM a
stm) =
  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
$
    (STM a
stm STM a -> (a -> STM (Maybe a)) -> STM (Maybe a)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> Bool -> STM ()
check (a -> Bool
f a
a) STM () -> Maybe a -> STM (Maybe a)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a -> Maybe a
forall a. a -> Maybe a
Just a
a) STM (Maybe a) -> STM (Maybe a) -> STM (Maybe a)
forall a. STM a -> STM a -> STM a
`orElse` Maybe a -> STM (Maybe a)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

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

-- | Create a new 'Counter' with an initial value.
newCounter :: (MonadSTM m) => Int -> m Counter
newCounter :: forall (m :: * -> *). MonadSTM m => Int -> m Counter
newCounter Int
initial = 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
initial) (Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
initial)

-- | 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

-- | Wait until the 'Counter' has the value
awaitCounter :: (MonadSTM m) => Counter -> Int -> m ()
awaitCounter :: forall (m :: * -> *). MonadSTM m => Counter -> Int -> m ()
awaitCounter (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
$ do
  value <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
tVar
  check (value == 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

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

-- | Creates a new 'Option' filled with `a`.
newOption :: (MonadSTM m) => a -> m (Option a)
newOption :: forall (m :: * -> *) a. MonadSTM m => a -> m (Option a)
newOption a
a = TMVar a -> Option a
forall a. TMVar a -> Option a
Option (TMVar a -> Option a) -> m (TMVar a) -> m (Option 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 'Option'.
newEmptyOption :: (MonadSTM m) => m (Option a)
newEmptyOption :: forall (m :: * -> *) a. MonadSTM m => m (Option a)
newEmptyOption = TMVar a -> Option a
forall a. TMVar a -> Option a
Option (TMVar a -> Option a) -> m (TMVar a) -> m (Option 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

-- | Write in non-blocking manner
writeOption :: (MonadSTM m) => Option a -> a -> m ()
writeOption :: forall (m :: * -> *) a. MonadSTM m => Option a -> a -> m ()
writeOption (Option TMVar a
tmvar) 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
$ TMVar a -> a -> STM ()
forall a. TMVar a -> a -> STM ()
writeTMVar TMVar a
tmvar a
a

-- | Puts in a blocking manner, waiting if the 'Option' is not empty.
putOption :: (MonadSTM m) => Option a -> a -> m ()
putOption :: forall (m :: * -> *) a. MonadSTM m => Option a -> a -> m ()
putOption (Option TMVar a
tmvar) 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
$ TMVar a -> a -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar a
tmvar a
a

-- | Offers a value to the 'Option' in a non-blocking manner. Returns whether the offer was accepted or not.
offerOption :: (MonadSTM m) => Option a -> a -> m Bool
offerOption :: forall (m :: * -> *) a. MonadSTM m => Option a -> a -> m Bool
offerOption (Option TMVar a
tmvar) a
a = 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
$ TMVar a -> a -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar a
tmvar a
a

-- | Awaits the value from the 'Option'.
awaitOption :: (MonadSTM m) => Option a -> m a
awaitOption :: forall (m :: * -> *) a. MonadSTM m => Option a -> m a
awaitOption (Option 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)

-- | Probes the 'Option' in a non-blocking manner.
probeOption :: (MonadSTM m) => Option a -> m (Maybe a)
probeOption :: forall (m :: * -> *) a. MonadSTM m => Option a -> m (Maybe a)
probeOption (Option 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)

-- | Takes the element from the 'Option'. Waits if there is no element.
-- Afterwards, the 'Option' is empty.
takeOption :: (MonadSTM m) => Option a -> m a
takeOption :: forall (m :: * -> *) a. MonadSTM m => Option a -> m a
takeOption (Option 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 'Option' in a non-blocking manner.
-- Afterwards, the 'Option' is empty.
drainOption :: (MonadSTM m) => Option a -> m (Maybe a)
drainOption :: forall (m :: * -> *) a. MonadSTM m => Option a -> m (Maybe a)
drainOption (Option 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)

-- | 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

-- | Push an element to the back of the 'Queue'.
putQueue :: (MonadSTM m) => Queue a -> a -> m ()
putQueue :: forall (m :: * -> *) a. MonadSTM m => Queue a -> a -> m ()
putQueue (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

queueSource :: Queue a -> Source a
queueSource :: forall a. Queue a -> Source a
queueSource Queue a
queue = STM a -> Source a
forall a. STM a -> Source a
newSource (STM a -> Source a) -> STM a -> Source a
forall a b. (a -> b) -> a -> b
$ Queue a -> STM a
forall (m :: * -> *) a. MonadSTM m => Queue a -> m a
popQueue Queue a
queue

queueSink :: Queue a -> Sink a
queueSink :: forall a. Queue a -> Sink a
queueSink Queue a
queue = (a -> STM ()) -> Sink a
forall a. (a -> STM ()) -> Sink a
newSink ((a -> STM ()) -> Sink a) -> (a -> STM ()) -> Sink a
forall a b. (a -> b) -> a -> b
$ Queue a -> a -> STM ()
forall (m :: * -> *) a. MonadSTM m => Queue a -> a -> m ()
putQueue Queue a
queue

-- | A 'Sink' represents a channel where you can only push data
newtype Sink a = Sink (a -> STM ())

instance Contravariant Sink where
  contramap :: forall a' a. (a' -> a) -> Sink a -> Sink a'
contramap a' -> a
f (Sink a -> STM ()
s) = (a' -> STM ()) -> Sink a'
forall a. (a -> STM ()) -> Sink a
Sink (a -> STM ()
s (a -> STM ()) -> (a' -> a) -> a' -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f)

-- | A 'Source' represents a channel where you can only read data
newtype Source a = Source (STM a) deriving ((forall a b. (a -> b) -> Source a -> Source b)
-> (forall a b. a -> Source b -> Source a) -> Functor Source
forall a b. a -> Source b -> Source a
forall a b. (a -> b) -> Source a -> Source b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Source a -> Source b
fmap :: forall a b. (a -> b) -> Source a -> Source b
$c<$ :: forall a b. a -> Source b -> Source a
<$ :: forall a b. a -> Source b -> Source a
Functor, Functor Source
Functor Source =>
(forall a. a -> Source a)
-> (forall a b. Source (a -> b) -> Source a -> Source b)
-> (forall a b c.
    (a -> b -> c) -> Source a -> Source b -> Source c)
-> (forall a b. Source a -> Source b -> Source b)
-> (forall a b. Source a -> Source b -> Source a)
-> Applicative Source
forall a. a -> Source a
forall a b. Source a -> Source b -> Source a
forall a b. Source a -> Source b -> Source b
forall a b. Source (a -> b) -> Source a -> Source b
forall a b c. (a -> b -> c) -> Source a -> Source b -> Source c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Source a
pure :: forall a. a -> Source a
$c<*> :: forall a b. Source (a -> b) -> Source a -> Source b
<*> :: forall a b. Source (a -> b) -> Source a -> Source b
$cliftA2 :: forall a b c. (a -> b -> c) -> Source a -> Source b -> Source c
liftA2 :: forall a b c. (a -> b -> c) -> Source a -> Source b -> Source c
$c*> :: forall a b. Source a -> Source b -> Source b
*> :: forall a b. Source a -> Source b -> Source b
$c<* :: forall a b. Source a -> Source b -> Source a
<* :: forall a b. Source a -> Source b -> Source a
Applicative)

newSource :: STM a -> Source a
newSource :: forall a. STM a -> Source a
newSource = STM a -> Source a
forall a. STM a -> Source a
Source

takeSource :: (MonadSTM m) => Source a -> m a
takeSource :: forall (m :: * -> *) a. MonadSTM m => Source a -> m a
takeSource (Source STM a
stm) = STM a -> m a
forall a. STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM STM a
stm

drainSource :: (MonadSTM m) => Source a -> m (Maybe a)
drainSource :: forall (m :: * -> *) a. MonadSTM m => Source a -> m (Maybe a)
drainSource (Source STM a
stm) = 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
$ STM (Maybe a) -> STM (Maybe a) -> STM (Maybe a)
forall a. STM a -> STM a -> STM a
orElse (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> STM a -> STM (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM a
stm) (Maybe a -> STM (Maybe a)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing)

newSink :: (a -> STM ()) -> Sink a
newSink :: forall a. (a -> STM ()) -> Sink a
newSink = (a -> STM ()) -> Sink a
forall a. (a -> STM ()) -> Sink a
Sink

putSink :: (MonadSTM m) => Sink a -> a -> m ()
putSink :: forall (m :: * -> *) a. MonadSTM m => Sink a -> a -> m ()
putSink (Sink a -> STM ()
f) 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
$ a -> STM ()
f a
a

-- | A 'Slot' starts out empty and can be filled with 'putSlot'.
newtype Slot a = Slot (TMVar a)

newSlot :: (MonadSTM m) => m (Slot a)
newSlot :: forall (m :: * -> *) a. MonadSTM m => m (Slot a)
newSlot = 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

putSlot :: (MonadSTM m) => Slot a -> a -> m Bool
putSlot :: forall (m :: * -> *) a. MonadSTM m => Slot a -> a -> m Bool
putSlot (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 (STM Bool -> m Bool) -> STM Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ TMVar a -> a -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar a
var a
a

awaitSlot :: (MonadSTM m) => Slot a -> m a
awaitSlot :: forall (m :: * -> *) a. MonadSTM m => Slot a -> m a
awaitSlot (Slot TMVar a
var) = 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
$ TMVar a -> STM a
forall a. TMVar a -> STM a
readTMVar TMVar a
var

probeSlot :: (MonadSTM m) => Slot a -> m (Maybe a)
probeSlot :: forall (m :: * -> *) a. MonadSTM m => Slot a -> m (Maybe a)
probeSlot (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 (STM (Maybe a) -> m (Maybe a)) -> STM (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ TMVar a -> STM (Maybe a)
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar a
var