src/RMCA/EventProvider.hs

   1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TupleSections #-}
   2
   3 module RMCA.EventProvider ( EventProvider
   4                           , newEventProvider
   5                           , stopProviding
   6                           , getEPfromRV
   7                           ) where
   8
   9 import Control.Concurrent.MVar
  10 import Data.ReactiveValue
  11 import FRP.Yampa
  12 import RMCA.Auxiliary
  13
  14 newtype EventProvider a = EventProvider (MVar (Event a, [IO ()]))
  15
  16 newEventProvider :: Maybe a -> IO (EventProvider a)
  17 newEventProvider = fmap EventProvider . newMVar . (,[]) . maybeToEvent
  18
  19 -- Stop event production without triggering the callbacks.
  20 stopProviding :: EventProvider a -> IO ()
  21 stopProviding (EventProvider mvar) =
  22   modifyMVar_ mvar (\(_,cbs) -> return (NoEvent,cbs))
  23
  24 getEPfromRV :: (ReactiveValueRead a b IO) => a -> IO (EventProvider b)
  25 getEPfromRV rv = do
  26   ep <- newEventProvider . Just =<< reactiveValueRead rv
  27   (Event <^> rv) =:> ep
  28   return ep
  29
  30 instance ReactiveValueRead (EventProvider a) (Event a) IO where
  31   reactiveValueRead (EventProvider mvar) =
  32     modifyMVar mvar $ \(mval,cbs) -> return ((NoEvent,cbs), mval)
  33   reactiveValueOnCanRead (EventProvider mvar) io =
  34     modifyMVar_ mvar $ \(mval,cbs) -> return (mval, cbs ++ [io])
  35
  36 instance ReactiveValueWrite (EventProvider a) (Event a) IO where
  37   reactiveValueWrite (EventProvider mvar) val = do
  38     modifyMVar_ mvar (\(_,cbs) -> return (val,cbs))
  39     readMVar mvar >>= sequence_ . snd
  40
  41 instance ReactiveValueReadWrite (EventProvider a) (Event a) IO where