Signal-slot mechanism in Haskell.

signal-slot.hs

-------------------------------------------------------------
-- |
-- Copyright:               (c) Tao He 2016
-- License:                 MIT
-- Maintainer:              [email protected]
--
-- Signal-slot mechanism in Haskell.
--

import Control.Monad
import Data.IORef
import qualified Data.IntMap.Strict as M

------------------------------------------------------------
-- DEMO
------------------------------------------------------------

main :: IO ()
main = do
    sig <- newSig
    conn1 <- connect sig $ \x -> putStrLn $ x ++ "abcde"
    conn2 <- connect sig $ \x -> putStrLn $ x ++ "12345"
    _ <- emit ($ "test signal 1 ") sig
    block conn1
    emit_ ($ "test signal 2 ") sig
    active conn1
    emit_ ($ "test signal 3 ") sig

------------------------------------------------------------
-- LIBRARY IMPLEMENTATION
------------------------------------------------------------

-- | Blockable slot type.
data Slot a = Slot a (IORef Int)

newSlot :: a -> IO (Slot a)
newSlot x = Slot x <$> newIORef 0

blocked (Slot _ i) = (> 0) <$> readIORef i
callSlot val (Slot x _) = val x
blockSlot (Slot _ i) = atomicModifyIORef' i $ \v -> let v' = succ v in (v', ())
activeSlot (Slot _ i) = atomicModifyIORef' i $ \v -> let v' = pred v in (v', ())

-- | Signal's internal implementation.
data SigImpl a = SigImpl Int (M.IntMap (Slot a))

-- | Signal type.
type Signal a = IORef (SigImpl a)

-- | Connection type.
data Connection = Connection { block :: IO ()
                             , active :: IO ()
                             , disconnect :: IO ()
                             }

-- | Create new signal object.
newSig :: IO (Signal a)
newSig = newIORef (SigImpl (minBound :: Int) M.empty)

-- | Connect a signal object with a slot, return a connection.
connect :: Signal a -> a -> IO Connection
connect sig a = do
    slot <- newSlot a
    atomicModifyIORef sig $ \ref ->
        let (sig', i) = addSig ref slot
            fdisconnect = atomicModifyIORef' sig $ \ref' -> (delSig ref' i, ())
            fblock = blockSlot slot
            factive = activeSlot slot
        in (sig', Connection { block = fblock, active = factive, disconnect = fdisconnect } )
      where addSig (SigImpl i m) x =
                let m' = M.insert i x m
                    i' = succ i
                in (SigImpl i' m', i)
            delSig (SigImpl i m) x = SigImpl i (M.delete x m)

-- | Emit a signal and return results after apply signal to all available slots.
emit :: (a -> IO b) -> Signal a -> IO [b]
emit val sig = do
    SigImpl _ ss <- readIORef sig
    go (M.elems ss) where
                        go [] = return []
                        go (x:xs) = blocked x >>= \r -> if r then go xs
                                                             else do
                                                                  xr <- callSlot val x
                                                                  xsr <- go xs
                                                                  return (xr:xsr)

-- | Emit a signal and ignore results.
emit_ :: (a -> IO b) -> Signal a -> IO ()
emit_ val sig = do
    SigImpl _ ss <- readIORef sig
    mapM_ (\s -> blocked s >>= \r -> unless r . void . callSlot val $ s) (M.elems ss)