MCBMVar.hs 2.5 KB
Newer Older
Guerric Chupin's avatar
Guerric Chupin committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TupleSections #-}

module RMCA.MCBMVar ( newMCBMVar
                    , readMCBMVar
                    , writeMCBMVar
                    , installCallbackMCBMVar
                    , removeCallbackMCBMVar
                    , MCBMVar
                    , 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)
35
newMCBMVar = (fmap MCBMVar) . newMVar . (,(HandlerId 0,M.empty))
Guerric Chupin's avatar
Guerric Chupin committed
36 37

readMCBMVar :: MCBMVar a -> IO a
38
readMCBMVar (MCBMVar x) = fmap fst (readMVar x)
Guerric Chupin's avatar
Guerric Chupin committed
39 40

runCallBacks :: MCBMVar a -> IO ()
41
runCallBacks (MCBMVar x) = readMVar x >>= sequence_ . M.elems . snd . snd
Guerric Chupin's avatar
Guerric Chupin committed
42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68

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