Commit 316a8150 authored by Guerric Chupin's avatar Guerric Chupin


parent da23b70d
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TupleSections #-}
module RMCA.MCBMVar ( newMCBMVar
, readMCBMVar
, writeMCBMVar
, installCallbackMCBMVar
, removeCallbackMCBMVar
, HandlerId
) where
import Control.Concurrent.MVar
import Control.Monad
import qualified Data.Map as M
import Data.ReactiveValue
type CallbackMap = M.Map Integer (IO ())
-- Carries a phantom type to avoid some errors where HandlerIds would
-- be applied to the wrong MCBMVar leading to strange results.
newtype HandlerId a = HandlerId Integer deriving(Eq, Show, Ord)
-- MVar executing actions when modified (highly inspired by CBMVar)
-- with the possibility of removing actions.
-- The callbacks to execute are stored in an integer indexed map, the
-- HandlerId stored with it is the index where the next callback will
-- be stored. This is to ensure that we never give the same HandlerId
-- several times, or we could have situations where a handler can
-- delete callback a and later callback b because callback b was added
-- behind at the same index where callback a was.
newtype MCBMVar a = MCBMVar (MVar (a, (HandlerId a,CallbackMap)))
newMCBMVar :: a -> IO (MCBMVar a)
newMCBMVar = (MCBMVar <$>) . newMVar . (,(HandlerId 0,M.empty))
readMCBMVar :: MCBMVar a -> IO a
readMCBMVar (MCBMVar x) = fst <$> readMVar x
runCallBacks :: MCBMVar a -> IO ()
runCallBacks (MCBMVar x) = readMVar x >>= sequence_ . snd . snd
writeMCBMVar :: MCBMVar a -> a -> IO ()
writeMCBMVar w@(MCBMVar x) y = do
takeMVar x >>= putMVar x . (y,) . snd
runCallBacks w
installCallbackMCBMVar :: MCBMVar a -> IO () -> IO (HandlerId a)
installCallbackMCBMVar (MCBMVar x) io = do
(val,(nhid'@(HandlerId nhid),cbs)) <- takeMVar x
let ncbs = M.insertWith (\_ _ -> error "HandlerId already in use") nhid io cbs
putMVar x (val,(HandlerId (nhid + 1), ncbs))
return nhid'
removeCallbackMCBMVar :: MCBMVar a -> HandlerId a -> IO ()
removeCallbackMCBMVar (MCBMVar x) (HandlerId hid) = do
(val,(nhid,cbs)) <- takeMVar x
let ncbs = M.delete hid cbs
putMVar x (val,(nhid,ncbs))
instance ReactiveValueRead (MCBMVar a) a IO where
reactiveValueRead = readMCBMVar
reactiveValueOnCanRead x io = void $ installCallbackMCBMVar x io
instance ReactiveValueWrite (MCBMVar a) a IO where
reactiveValueWrite = writeMCBMVar
instance ReactiveValueReadWrite (MCBMVar a) a IO where
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment