src/RMCA/EventProvider.hs

   1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TupleSections #-}
   2
   3 module RMCA.EventProvider ( EventProvider
   4                           , newEventProvider
   5                           , newEmptyEventProvider
   6                           , stopProviding
   7                           , getEPfromRV
   8                           , EventProviderQueue
   9                           , newEventProviderQueue
  10                           , newEmptyEventProviderQueue
  11                           , emptyProviderQueue
  12                           , getEPQfromRV
  13                           ) where
  14
  15 import Control.Concurrent.MVar
  16 import Control.Monad
  17 import Data.ReactiveValue
  18 import FRP.Yampa hiding (maybeToEvent)
  19 import RMCA.Auxiliary
  20
  21 newtype EventProvider a = EventProvider (MVar (Event a, [IO ()]))
  22
  23 newEventProvider :: Maybe a -> IO (EventProvider a)
  24 newEventProvider = fmap EventProvider . newMVar . (,[]) . maybeToEvent
  25
  26 newEmptyEventProvider :: IO (EventProvider a)
  27 newEmptyEventProvider = newEventProvider Nothing
  28
  29 -- Stop event production without triggering the callbacks.
  30 stopProviding :: EventProvider a -> IO ()
  31 stopProviding (EventProvider mvar) =
  32   modifyMVar_ mvar (\(_,cbs) -> return (NoEvent,cbs))
  33
  34 getEPfromRV :: (ReactiveValueRead a b IO) => a -> IO (EventProvider b)
  35 getEPfromRV rv = do
  36   ep <- newEventProvider . Just =<< reactiveValueRead rv
  37   (Event <^> rv) =:> ep
  38   return ep
  39
  40 instance ReactiveValueRead (EventProvider a) (Event a) IO where
  41   reactiveValueRead (EventProvider mvar) =
  42     modifyMVar mvar $ \(mval,cbs) -> return ((NoEvent,cbs), mval)
  43   reactiveValueOnCanRead (EventProvider mvar) io =
  44     modifyMVar_ mvar $ \(mval,cbs) -> return (mval, cbs ++ [io])
  45
  46 instance ReactiveValueWrite (EventProvider a) (Event a) IO where
  47   reactiveValueWrite (EventProvider mvar) val = do
  48     modifyMVar_ mvar (\(_,cbs) -> return (val,cbs))
  49     readMVar mvar >>= sequence_ . snd
  50
  51 instance ReactiveValueReadWrite (EventProvider a) (Event a) IO where
  52
  53 newtype EventProviderQueue a = EventProviderQueue (MVar ([a], [IO ()]))
  54
  55 newEventProviderQueue :: [a] -> IO (EventProviderQueue a)
  56 newEventProviderQueue = fmap EventProviderQueue . newMVar . (,[])
  57
  58 newEmptyEventProviderQueue :: IO (EventProviderQueue a)
  59 newEmptyEventProviderQueue = newEventProviderQueue []
  60
  61 emptyProviderQueue :: EventProviderQueue a -> IO ()
  62 emptyProviderQueue (EventProviderQueue mvar) =
  63   modifyMVar_ mvar (\(_,cbs) -> return ([],cbs))
  64
  65 getEPQfromRV :: (ReactiveValueRead a b IO) => a -> IO (EventProviderQueue b)
  66 getEPQfromRV rv = do
  67   ep <- newEventProviderQueue . (:[]) =<< reactiveValueRead rv
  68   (Event <^> rv) =:> ep
  69   return ep
  70
  71 instance ReactiveValueRead (EventProviderQueue a) (Event a) IO where
  72   reactiveValueRead (EventProviderQueue mvar) =
  73     modifyMVar mvar popEventMVar
  74     where popEventMVar ([],cbs) = return (([],cbs), NoEvent)
  75           popEventMVar (el,cbs) = return ((init el,cbs), Event $ last el)
  76   reactiveValueOnCanRead (EventProviderQueue mvar) io =
  77     modifyMVar_ mvar $ \(mval,cbs) -> return (mval, cbs ++ [io])
  78
  79 instance ReactiveValueWrite (EventProviderQueue a) (Event a) IO where
  80   reactiveValueWrite (EventProviderQueue mvar) val = do
  81     when (isEvent val) $
  82       modifyMVar_ mvar $ \(mval,cbs) -> return (fromEvent val:mval,cbs)
  83     readMVar mvar >>= sequence_ . snd