module FRP.Reactivity.RPC where
import Control.Monad.Reader
import Control.Monad.IO.Class
import Control.Monad.Trans
import Control.Monad.Loops
import Control.Monad.Catch
import Control.Concurrent
import Control.Applicative
import Data.Typeable
newtype RPC t = RPC { unRPC :: ReaderT (Bool, MVar (IO ())) IO t } deriving (Functor, Typeable)
instance Monad RPC where
return = RPC . return
m >>= f = RPC $ unRPC m >>= unRPC . f
fail = RPC . fail
instance Applicative RPC where
pure = return
(<*>) = ap
instance MonadIO RPC where
liftIO m = RPC $ ask >>= \(ty, mv2) -> lift $
if ty then
newEmptyMVar >>= \mv -> putMVar mv2 (catch (m >>= putMVar mv . Right) (\(ex :: SomeException) -> putMVar mv (Left ex)))
>> takeMVar mv >>= either throwM return
else
m
rpcFork (RPC m) = RPC $ ask >>= \(_, mv) -> lift (forkIO (runReaderT m (True, mv)))
_nonDispatchedIO m = RPC (lift m)
instance MonadThrow RPC where
throwM e = _nonDispatchedIO (throwM e)
instance MonadCatch RPC where
catch m f = RPC $ ask >>= \pr -> lift (catch (runReaderT (unRPC m) pr) (\e -> runReaderT (unRPC (f e)) pr))
rpcFinally :: RPC t -> RPC u -> RPC t
rpcFinally m m2 = catch m (\(ex :: SomeException) -> m2 >> throwM ex)
data RpcFinishedException = RpcFinishedException deriving (Show, Typeable)
instance Exception RpcFinishedException
rpcServer :: MVar (IO ()) -> IO ()
rpcServer mv = catch
(whileM_ (return True) (join (takeMVar mv)))
(\RpcFinishedException -> return ())
killRpcServer :: MVar (IO ()) -> IO ()
killRpcServer mv2 = putMVar mv2 (throwM RpcFinishedException)