module Erebos.Flow (
    Flow, SymFlow,
    newFlow, newFlowIO,
    readFlow, tryReadFlow, canReadFlow,
    writeFlow, writeFlowBulk, tryWriteFlow, canWriteFlow,
    readFlowIO, writeFlowIO,

    mapFlow,
) where

import Control.Concurrent.STM


data Flow r w
    = Flow (TBQueue r) (TBQueue w)
    | forall r' w'. MappedFlow (r' -> r) (w -> w') (Flow r' w')

type SymFlow a = Flow a a

newFlow :: STM (Flow a b, Flow b a)
newFlow :: forall a b. STM (Flow a b, Flow b a)
newFlow = do
    TBQueue a
x <- Natural -> STM (TBQueue a)
forall a. Natural -> STM (TBQueue a)
newTBQueue Natural
16
    TBQueue b
y <- Natural -> STM (TBQueue b)
forall a. Natural -> STM (TBQueue a)
newTBQueue Natural
16
    (Flow a b, Flow b a) -> STM (Flow a b, Flow b a)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (TBQueue a -> TBQueue b -> Flow a b
forall r w. TBQueue r -> TBQueue w -> Flow r w
Flow TBQueue a
x TBQueue b
y, TBQueue b -> TBQueue a -> Flow b a
forall r w. TBQueue r -> TBQueue w -> Flow r w
Flow TBQueue b
y TBQueue a
x)

newFlowIO :: IO (Flow a b, Flow b a)
newFlowIO :: forall a b. IO (Flow a b, Flow b a)
newFlowIO = STM (Flow a b, Flow b a) -> IO (Flow a b, Flow b a)
forall a. STM a -> IO a
atomically STM (Flow a b, Flow b a)
forall a b. STM (Flow a b, Flow b a)
newFlow

readFlow :: Flow r w -> STM r
readFlow :: forall r w. Flow r w -> STM r
readFlow (Flow TBQueue r
rvar TBQueue w
_) = TBQueue r -> STM r
forall a. TBQueue a -> STM a
readTBQueue TBQueue r
rvar
readFlow (MappedFlow r' -> r
f w -> w'
_ Flow r' w'
up) = r' -> r
f (r' -> r) -> STM r' -> STM r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Flow r' w' -> STM r'
forall r w. Flow r w -> STM r
readFlow Flow r' w'
up

tryReadFlow :: Flow r w -> STM (Maybe r)
tryReadFlow :: forall r w. Flow r w -> STM (Maybe r)
tryReadFlow (Flow TBQueue r
rvar TBQueue w
_) = TBQueue r -> STM (Maybe r)
forall a. TBQueue a -> STM (Maybe a)
tryReadTBQueue TBQueue r
rvar
tryReadFlow (MappedFlow r' -> r
f w -> w'
_ Flow r' w'
up) = (r' -> r) -> Maybe r' -> Maybe r
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r' -> r
f (Maybe r' -> Maybe r) -> STM (Maybe r') -> STM (Maybe r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Flow r' w' -> STM (Maybe r')
forall r w. Flow r w -> STM (Maybe r)
tryReadFlow Flow r' w'
up

canReadFlow :: Flow r w -> STM Bool
canReadFlow :: forall r w. Flow r w -> STM Bool
canReadFlow (Flow TBQueue r
rvar TBQueue w
_) = Bool -> Bool
not (Bool -> Bool) -> STM Bool -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TBQueue r -> STM Bool
forall a. TBQueue a -> STM Bool
isEmptyTBQueue TBQueue r
rvar
canReadFlow (MappedFlow r' -> r
_ w -> w'
_ Flow r' w'
up) = Flow r' w' -> STM Bool
forall r w. Flow r w -> STM Bool
canReadFlow Flow r' w'
up

writeFlow :: Flow r w -> w -> STM ()
writeFlow :: forall r w. Flow r w -> w -> STM ()
writeFlow (Flow TBQueue r
_ TBQueue w
wvar) = TBQueue w -> w -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue w
wvar
writeFlow (MappedFlow r' -> r
_ w -> w'
f Flow r' w'
up) = Flow r' w' -> w' -> STM ()
forall r w. Flow r w -> w -> STM ()
writeFlow Flow r' w'
up (w' -> STM ()) -> (w -> w') -> w -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> w'
f

writeFlowBulk :: Flow r w -> [w] -> STM ()
writeFlowBulk :: forall r w. Flow r w -> [w] -> STM ()
writeFlowBulk Flow r w
_ [] = () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
writeFlowBulk (Flow TBQueue r
_ TBQueue w
wvar) [w]
xs = (w -> STM ()) -> [w] -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TBQueue w -> w -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue w
wvar) [w]
xs
writeFlowBulk (MappedFlow r' -> r
_ w -> w'
f Flow r' w'
up) [w]
xs = Flow r' w' -> [w'] -> STM ()
forall r w. Flow r w -> [w] -> STM ()
writeFlowBulk Flow r' w'
up ([w'] -> STM ()) -> [w'] -> STM ()
forall a b. (a -> b) -> a -> b
$ (w -> w') -> [w] -> [w']
forall a b. (a -> b) -> [a] -> [b]
map w -> w'
f [w]
xs

tryWriteFlow :: Flow r w -> w -> STM Bool
tryWriteFlow :: forall r w. Flow r w -> w -> STM Bool
tryWriteFlow (Flow TBQueue r
_ TBQueue w
wvar) w
x = do
    TBQueue w -> STM Bool
forall a. TBQueue a -> STM Bool
isFullTBQueue TBQueue w
wvar STM Bool -> (Bool -> STM Bool) -> STM Bool
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> Bool -> STM Bool
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Bool
False -> do
            TBQueue w -> w -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue w
wvar w
x
            Bool -> STM Bool
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
tryWriteFlow (MappedFlow r' -> r
_ w -> w'
f Flow r' w'
up) w
x = Flow r' w' -> w' -> STM Bool
forall r w. Flow r w -> w -> STM Bool
tryWriteFlow Flow r' w'
up (w' -> STM Bool) -> w' -> STM Bool
forall a b. (a -> b) -> a -> b
$ w -> w'
f w
x

canWriteFlow :: Flow r w -> STM Bool
canWriteFlow :: forall r w. Flow r w -> STM Bool
canWriteFlow (Flow TBQueue r
_ TBQueue w
wvar) = Bool -> Bool
not (Bool -> Bool) -> STM Bool -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TBQueue w -> STM Bool
forall a. TBQueue a -> STM Bool
isFullTBQueue TBQueue w
wvar
canWriteFlow (MappedFlow r' -> r
_ w -> w'
_ Flow r' w'
up) = Flow r' w' -> STM Bool
forall r w. Flow r w -> STM Bool
canWriteFlow Flow r' w'
up

readFlowIO :: Flow r w -> IO r
readFlowIO :: forall r w. Flow r w -> IO r
readFlowIO Flow r w
path = STM r -> IO r
forall a. STM a -> IO a
atomically (STM r -> IO r) -> STM r -> IO r
forall a b. (a -> b) -> a -> b
$ Flow r w -> STM r
forall r w. Flow r w -> STM r
readFlow Flow r w
path

writeFlowIO :: Flow r w -> w -> IO ()
writeFlowIO :: forall r w. Flow r w -> w -> IO ()
writeFlowIO Flow r w
path = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (w -> STM ()) -> w -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flow r w -> w -> STM ()
forall r w. Flow r w -> w -> STM ()
writeFlow Flow r w
path


mapFlow :: (r -> r') -> (w' -> w) -> Flow r w -> Flow r' w'
mapFlow :: forall r r' w' w. (r -> r') -> (w' -> w) -> Flow r w -> Flow r' w'
mapFlow r -> r'
rf w' -> w
wf (MappedFlow r' -> r
rf' w -> w'
wf' Flow r' w'
up) = (r' -> r') -> (w' -> w') -> Flow r' w' -> Flow r' w'
forall r w r' w'. (r' -> r) -> (w -> w') -> Flow r' w' -> Flow r w
MappedFlow (r -> r'
rf (r -> r') -> (r' -> r) -> r' -> r'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r' -> r
rf') (w -> w'
wf' (w -> w') -> (w' -> w) -> w' -> w'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w' -> w
wf) Flow r' w'
up
mapFlow r -> r'
rf w' -> w
wf Flow r w
up = (r -> r') -> (w' -> w) -> Flow r w -> Flow r' w'
forall r w r' w'. (r' -> r) -> (w -> w') -> Flow r' w' -> Flow r w
MappedFlow r -> r'
rf w' -> w
wf Flow r w
up