module Control.Concurrent.Reactive
( Action
, Request
, reactiveObjectIO
, Sink
, pauseIO
, reactiveIO
) where
import Control.Concurrent.Chan
import Control.Concurrent
import Control.Exception as Ex
type Action s = s -> IO s
type Request s a = s -> IO (s,a)
data Msg s = Act (Action s)
| forall a . Req (Request s a) (MVar a)
| Done (MVar ())
reactiveObjectIO
:: forall state object. state
-> ( ThreadId
-> (forall r. Request state r -> IO r)
-> (Action state -> IO ())
-> IO ()
-> object
)
-> IO object
reactiveObjectIO state mkObject = do
chan <- newChan
let dispatch state =
readChan chan >>= \case Act act -> do state1 <- act state
dispatch $! state1
Req req box -> do (state1,ret) <- req state
putMVar box ret
dispatch $! state1
Done box -> do putMVar box ()
return ()
pid <- forkIO $ dispatch state
let requestit :: forall r. Request state r -> IO r
requestit fun = do
ret <- newEmptyMVar
writeChan chan $ Req fun ret
takeMVar ret
actionit act = writeChan chan $ Act act
doneit = do
ret <- newEmptyMVar
writeChan chan $ Done ret
takeMVar ret
return (mkObject pid requestit actionit doneit)
type Sink a = a -> IO ()
pauseIO :: (a -> Sink b -> IO ()) -> a -> IO b
pauseIO fn a = do
var <- newEmptyMVar
forkIO $ do fn a (\ b -> putMVar var b)
takeMVar var
reactiveIO :: (a -> IO b) -> a -> Sink b -> IO ()
reactiveIO fn a sinkB = do
forkIO $ sinkB =<< fn a
return ()