]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/EventProvider.hs
Refactoring to FRP.
[tmp/julm/arpeggigon.git] / 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
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