module FP.API.Signal where
import Control.Applicative
import Control.Concurrent.MVar
import Control.Monad.IO.Class
import Data.Foldable
import Data.IORef
import qualified Data.IntMap as IM
import Prelude
import System.Timeout
data Signal m a = Signal (IORef (IM.IntMap (a -> m ())))
newSignal :: IO (Signal m a)
newSignal = Signal <$> newIORef IM.empty
sendSignal :: MonadIO m => Signal m a -> a -> m ()
sendSignal (Signal ref) x = do
m <- liftIO $ readIORef ref
forM_ m $ \f -> f x
subscribeSignal :: Signal m a -> (IO () -> a -> m ()) -> IO (IO ())
subscribeSignal (Signal ref) f =
atomicModifyIORef ref $ \m ->
let m' = IM.insert key (f unsub) m
unsub = unsubscriber key
key = if IM.null m
then 0
else 1 + fst (IM.findMax m)
in (m', unsub)
where
unsubscriber key =
atomicModifyIORef ref $ \m -> (IM.delete key m, ())
blockOnSignal :: MonadIO m => Maybe Int -> Signal m a -> (a -> m (Maybe b)) -> IO (Maybe b)
blockOnSignal mmicros sig f = do
resultVar <- newEmptyMVar
unsub <- subscribeSignal sig $ \_ x -> do
mres <- f x
liftIO $ forM_ mres $ putMVar resultVar
result <- maybe (fmap Just) timeout mmicros $
takeMVar resultVar
unsub
return result