src/RMCA/MCBMVar.hs

   1 {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TupleSections #-}
   2
   3 module RMCA.MCBMVar ( newMCBMVar
   4                     , readMCBMVar
   5                     , writeMCBMVar
   6                     , installCallbackMCBMVar
   7                     , removeCallbackMCBMVar
   8                     , MCBMVar
   9                     , HandlerId
  10                     ) where
  11
  12 import           Control.Concurrent.MVar
  13 import           Control.Monad
  14 import qualified Data.Map                as M
  15 import           Data.ReactiveValue
  16
  17 type CallbackMap = M.Map Integer (IO ())
  18
  19 -- Carries a phantom type to avoid some errors where HandlerIds would
  20 -- be applied to the wrong MCBMVar leading to strange results.
  21 newtype HandlerId a = HandlerId Integer deriving(Eq, Show, Ord)
  22
  23 -- MVar executing actions when modified (highly inspired by CBMVar)
  24 -- with the possibility of removing actions.
  25 --
  26 -- The callbacks to execute are stored in an integer indexed map, the
  27 -- HandlerId stored with it is the index where the next callback will
  28 -- be stored. This is to ensure that we never give the same HandlerId
  29 -- several times, or we could have situations where a handler can
  30 -- delete callback a and later callback b because callback b was added
  31 -- behind at the same index where callback a was.
  32 newtype MCBMVar a = MCBMVar (MVar (a, (HandlerId a,CallbackMap)))
  33
  34 newMCBMVar :: a -> IO (MCBMVar a)
  35 newMCBMVar = (MCBMVar <$>) . newMVar . (,(HandlerId 0,M.empty))
  36
  37 readMCBMVar :: MCBMVar a -> IO a
  38 readMCBMVar (MCBMVar x) = fst <$> readMVar x
  39
  40 runCallBacks :: MCBMVar a -> IO ()
  41 runCallBacks (MCBMVar x) = readMVar x >>= sequence_ . snd . snd
  42
  43 writeMCBMVar :: MCBMVar a -> a -> IO ()
  44 writeMCBMVar w@(MCBMVar x) y = do
  45   takeMVar x >>= putMVar x . (y,) . snd
  46   runCallBacks w
  47
  48 installCallbackMCBMVar :: MCBMVar a -> IO () -> IO (HandlerId a)
  49 installCallbackMCBMVar (MCBMVar x) io = do
  50   (val,(nhid'@(HandlerId nhid),cbs)) <- takeMVar x
  51   let ncbs = M.insertWith (\_ _ -> error "HandlerId already in use") nhid io cbs
  52   putMVar x (val,(HandlerId (nhid + 1), ncbs))
  53   return nhid'
  54
  55 removeCallbackMCBMVar :: MCBMVar a -> HandlerId a -> IO ()
  56 removeCallbackMCBMVar (MCBMVar x) (HandlerId hid) = do
  57   (val,(nhid,cbs)) <- takeMVar x
  58   let ncbs = M.delete hid cbs
  59   putMVar x (val,(nhid,ncbs))
  60
  61 instance ReactiveValueRead (MCBMVar a) a IO where
  62   reactiveValueRead = readMCBMVar
  63   reactiveValueOnCanRead x io = void $ installCallbackMCBMVar x io
  64
  65 instance ReactiveValueWrite (MCBMVar a) a IO where
  66   reactiveValueWrite = writeMCBMVar
  67
  68 instance ReactiveValueReadWrite (MCBMVar a) a IO where