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 (TMVar [r]) (TMVar [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
    TMVar [a]
x <- STM (TMVar [a])
forall a. STM (TMVar a)
newEmptyTMVar
    TMVar [b]
y <- STM (TMVar [b])
forall a. STM (TMVar a)
newEmptyTMVar
    (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 (TMVar [a] -> TMVar [b] -> Flow a b
forall r w. TMVar [r] -> TMVar [w] -> Flow r w
Flow TMVar [a]
x TMVar [b]
y, TMVar [b] -> TMVar [a] -> Flow b a
forall r w. TMVar [r] -> TMVar [w] -> Flow r w
Flow TMVar [b]
y TMVar [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 TMVar [r]
rvar TMVar [w]
_) = TMVar [r] -> STM [r]
forall a. TMVar a -> STM a
takeTMVar TMVar [r]
rvar STM [r] -> ([r] -> STM r) -> STM r
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (r
x:[]) -> r -> STM r
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return r
x
    (r
x:[r]
xs) -> TMVar [r] -> [r] -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar [r]
rvar [r]
xs STM () -> STM r -> STM r
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> r -> STM r
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return r
x
    [] -> [Char] -> STM r
forall a. HasCallStack => [Char] -> a
error [Char]
"Flow: empty list"
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 TMVar [r]
rvar TMVar [w]
_) = TMVar [r] -> STM (Maybe [r])
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar [r]
rvar STM (Maybe [r]) -> (Maybe [r] -> STM (Maybe r)) -> STM (Maybe r)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (r
x:[]) -> Maybe r -> STM (Maybe r)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> Maybe r
forall a. a -> Maybe a
Just r
x)
    Just (r
x:[r]
xs) -> TMVar [r] -> [r] -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar [r]
rvar [r]
xs STM () -> STM (Maybe r) -> STM (Maybe r)
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe r -> STM (Maybe r)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> Maybe r
forall a. a -> Maybe a
Just r
x)
    Just [] -> [Char] -> STM (Maybe r)
forall a. HasCallStack => [Char] -> a
error [Char]
"Flow: empty list"
    Maybe [r]
Nothing -> Maybe r -> STM (Maybe r)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe r
forall a. Maybe a
Nothing
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 TMVar [r]
rvar TMVar [w]
_) = Bool -> Bool
not (Bool -> Bool) -> STM Bool -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar [r] -> STM Bool
forall a. TMVar a -> STM Bool
isEmptyTMVar TMVar [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 TMVar [r]
_ TMVar [w]
wvar) = TMVar [w] -> [w] -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar [w]
wvar ([w] -> STM ()) -> (w -> [w]) -> w -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w -> [w] -> [w]
forall a. a -> [a] -> [a]
:[])
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 TMVar [r]
_ TMVar [w]
wvar) [w]
xs = TMVar [w] -> [w] -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar [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 TMVar [r]
_ TMVar [w]
wvar) = TMVar [w] -> [w] -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar [w]
wvar ([w] -> STM Bool) -> (w -> [w]) -> w -> STM Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w -> [w] -> [w]
forall a. a -> [a] -> [a]
:[])
tryWriteFlow (MappedFlow r' -> r
_ w -> w'
f Flow r' w'
up) = Flow r' w' -> w' -> STM Bool
forall r w. Flow r w -> w -> STM Bool
tryWriteFlow Flow r' w'
up (w' -> STM Bool) -> (w -> w') -> w -> STM Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> w'
f

canWriteFlow :: Flow r w -> STM Bool
canWriteFlow :: forall r w. Flow r w -> STM Bool
canWriteFlow (Flow TMVar [r]
_ TMVar [w]
wvar) = TMVar [w] -> STM Bool
forall a. TMVar a -> STM Bool
isEmptyTMVar TMVar [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