]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Auxiliary/RV.hs
Solved side RV problem.
[tmp/julm/arpeggigon.git] / src / RMCA / Auxiliary / RV.hs
1 {-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}
2
3 module RMCA.Auxiliary.RV where
4
5 import Data.CBMVar
6 import Data.ReactiveValue
7 import FRP.Yampa
8 import Control.Monad
9 import RMCA.Auxiliary.Curry
10
11 leftSyncWith :: (ReactiveValueRead a b m, ReactiveValueWrite c d m) =>
12 (b -> d) -> a -> c -> m ()
13 leftSyncWith f a c = reactiveValueOnCanRead a
14 (reactiveValueRead a >>= reactiveValueWrite c . f)
15
16 (=:$:>) :: (ReactiveValueRead a b m, ReactiveValueWrite c d m) =>
17 (b -> d) -> a -> c -> m ()
18 (=:$:>) = leftSyncWith
19
20 newCBMVarRW :: forall a. a -> IO (ReactiveFieldReadWrite IO a)
21 newCBMVarRW val = do
22 mvar <- newCBMVar val
23 let getter :: IO a
24 getter = readCBMVar mvar
25 setter :: a -> IO ()
26 setter = writeCBMVar mvar
27 notifier :: IO () -> IO ()
28 notifier = installCallbackCBMVar mvar
29 return $ ReactiveFieldReadWrite setter getter notifier
30
31 emptyRW :: (Monoid b, ReactiveValueReadWrite a b m) => a -> m b
32 emptyRW rv = do
33 val <- reactiveValueRead rv
34 reactiveValueWrite rv mempty
35 return val
36
37 emptyW :: (Monoid b, ReactiveValueWrite a b m) => a -> m ()
38 emptyW rv = reactiveValueWrite rv mempty
39
40 onTick :: (ReactiveValueRead a b m, ReactiveValueRead c d m) =>
41 a -> c -> ReactiveFieldRead m d
42 onTick notif rv = ReactiveFieldRead getter notifier
43 where getter = reactiveValueRead rv
44 notifier cb = do
45 reactiveValueOnCanRead notif cb
46 reactiveValueOnCanRead rv cb
47
48 addHandlerR :: (ReactiveValueRead a b m) =>
49 a
50 -> (m () -> m())
51 -> ReactiveFieldRead m b
52 addHandlerR x h = ReactiveFieldRead (reactiveValueRead x)
53 (\p -> reactiveValueOnCanRead x p >> h p)
54 {-
55 notif ^:> rv =
56 reactiveValueOnCanRead notif (reactiveValueOnCanRead rv (return ()))
57 -}
58 -- Update when the value is an Event. It would be nice to have that
59 -- even for Maybe as well.
60 (>:>) :: (ReactiveValueRead a (Event b) IO, ReactiveValueWrite c b IO) =>
61 a -> c -> IO ()
62 eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
63 where syncOnEvent = do
64 erv <- reactiveValueRead eventRV
65 when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
66 {-
67 liftR3 :: ( Monad m
68 , ReactiveValueRead a b m
69 , ReactiveValueRead c d m
70 , ReactiveValueRead e f m) =>
71 ((b,d,f) -> i)
72 -> a
73 -> c
74 -> e
75 -> ReactiveFieldRead m i
76 liftR3 f a b c = ReactiveFieldRead getter notifier
77 where getter = do
78 x1 <- reactiveValueRead a
79 x2 <- reactiveValueRead b
80 x3 <- reactiveValueRead c
81 return $ f (x1, x2, x3)
82 notifier p = reactiveValueOnCanRead a p >>
83 reactiveValueOnCanRead b p >>
84 reactiveValueOnCanRead c p
85 -}
86
87 liftW3 :: ( Monad m
88 , ReactiveValueWrite a b m
89 , ReactiveValueWrite c d m
90 , ReactiveValueWrite e f m) =>
91 (i -> (b,d,f))
92 -> a
93 -> c
94 -> e
95 -> ReactiveFieldWrite m i
96 liftW3 f a b c = ReactiveFieldWrite setter
97 where setter x = do
98 let (x1,x2,x3) = f x
99 reactiveValueWrite a x1
100 reactiveValueWrite b x2
101 reactiveValueWrite c x3
102
103 liftRW3 :: ( ReactiveValueReadWrite a b m
104 , ReactiveValueReadWrite c d m
105 , ReactiveValueReadWrite e f m) =>
106 BijectiveFunc i (b,d,f)
107 -> a
108 -> c
109 -> e
110 -> ReactiveFieldReadWrite m i
111 liftRW3 bij a b c =
112 ReactiveFieldReadWrite setter getter notifier
113 where ReactiveFieldRead getter notifier = liftR3 (curry3 f2) a b c
114 ReactiveFieldWrite setter = liftW3 f1 a b c
115 (f1, f2) = (direct bij, inverse bij)
116
117 liftR4 :: ( ReactiveValueRead a b m
118 , ReactiveValueRead c d m
119 , ReactiveValueRead e f m
120 , ReactiveValueRead g h m) =>
121 ((b,d,f,h) -> i)
122 -> a
123 -> c
124 -> e
125 -> g
126 -> ReactiveFieldRead m i
127 liftR4 f a b c d = ReactiveFieldRead getter notifier
128 where getter = do
129 x1 <- reactiveValueRead a
130 x2 <- reactiveValueRead b
131 x3 <- reactiveValueRead c
132 x4 <- reactiveValueRead d
133 return $ f (x1, x2, x3, x4)
134 notifier p = do
135 reactiveValueOnCanRead a p
136 reactiveValueOnCanRead b p
137 reactiveValueOnCanRead c p
138 reactiveValueOnCanRead d p
139
140 liftW4 :: ( Monad m
141 , ReactiveValueWrite a b m
142 , ReactiveValueWrite c d m
143 , ReactiveValueWrite e f m
144 , ReactiveValueWrite g h m) =>
145 (i -> (b,d,f,h))
146 -> a
147 -> c
148 -> e
149 -> g
150 -> ReactiveFieldWrite m i
151 liftW4 f a b c d = ReactiveFieldWrite setter
152 where setter x = do
153 let (x1,x2,x3,x4) = f x
154 reactiveValueWrite a x1
155 reactiveValueWrite b x2
156 reactiveValueWrite c x3
157 reactiveValueWrite d x4
158
159 liftRW4 :: ( ReactiveValueReadWrite a b m
160 , ReactiveValueReadWrite c d m
161 , ReactiveValueReadWrite e f m
162 , ReactiveValueReadWrite g h m) =>
163 BijectiveFunc i (b,d,f,h)
164 -> a
165 -> c
166 -> e
167 -> g
168 -> ReactiveFieldReadWrite m i
169 liftRW4 bij a b c d =
170 ReactiveFieldReadWrite setter getter notifier
171 where ReactiveFieldRead getter notifier = liftR4 f2 a b c d
172 ReactiveFieldWrite setter = liftW4 f1 a b c d
173 (f1, f2) = (direct bij, inverse bij)