{-# LANGUAGE Safe, GeneralizedNewtypeDeriving, DeriveFunctor, DeriveDataTypeable, ScopedTypeVariables #-}

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

-- | A simple RPC server.
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)))

{-# INLINE _nonDispatchedIO #-}
_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)