Signal.hs

-- | A very minimal library for broadcasting events to listeners.

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, ())

-- | Block, watching for a particular value (indicated by 'Just').
-- Once a 'Just' value is seen, stop subscribing, and return the
-- value.  The @Maybe Int@ argument specifies an optional timeout in
-- microseconds.  If the function instead times out, then 'Nothing' is
-- yielded.
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