]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Auxiliary/RV.hs
Volume modification.
[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 reactiveValueAppend :: (Monoid b, ReactiveValueReadWrite a b m) =>
41 a -> b -> m ()
42 reactiveValueAppend rv v = do ov <- reactiveValueRead rv
43 reactiveValueWrite rv (ov `mappend` v)
44
45 onTick :: (ReactiveValueRead a b m, ReactiveValueRead c d m) =>
46 a -> c -> ReactiveFieldRead m d
47 onTick notif rv = ReactiveFieldRead getter notifier
48 where getter = reactiveValueRead rv
49 notifier cb = do
50 reactiveValueOnCanRead notif cb
51 reactiveValueOnCanRead rv cb
52
53 addHandlerR :: (ReactiveValueRead a b m) =>
54 a
55 -> (m () -> m())
56 -> ReactiveFieldRead m b
57 addHandlerR x h = ReactiveFieldRead (reactiveValueRead x)
58 (\p -> reactiveValueOnCanRead x p >> h p)
59
60 -- Update when the value is an Event. It would be nice to have that
61 -- even for Maybe as well.
62 (>:>) :: (ReactiveValueRead a (Event b) IO, ReactiveValueWrite c b IO) =>
63 a -> c -> IO ()
64 eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
65 where syncOnEvent = do
66 erv <- reactiveValueRead eventRV
67 when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
68
69 liftW3 :: ( Monad m
70 , ReactiveValueWrite a b m
71 , ReactiveValueWrite c d m
72 , ReactiveValueWrite e f m) =>
73 (i -> (b,d,f))
74 -> a
75 -> c
76 -> e
77 -> ReactiveFieldWrite m i
78 liftW3 f a b c = ReactiveFieldWrite setter
79 where setter x = do
80 let (x1,x2,x3) = f x
81 reactiveValueWrite a x1
82 reactiveValueWrite b x2
83 reactiveValueWrite c x3
84
85 liftRW3 :: ( ReactiveValueReadWrite a b m
86 , ReactiveValueReadWrite c d m
87 , ReactiveValueReadWrite e f m) =>
88 BijectiveFunc i (b,d,f)
89 -> a
90 -> c
91 -> e
92 -> ReactiveFieldReadWrite m i
93 liftRW3 bij a b c =
94 ReactiveFieldReadWrite setter getter notifier
95 where ReactiveFieldRead getter notifier = liftR3 (curry3 f2) a b c
96 ReactiveFieldWrite setter = liftW3 f1 a b c
97 (f1, f2) = (direct bij, inverse bij)
98
99 liftR4 :: ( ReactiveValueRead a b m
100 , ReactiveValueRead c d m
101 , ReactiveValueRead e f m
102 , ReactiveValueRead g h m) =>
103 ((b,d,f,h) -> i)
104 -> a
105 -> c
106 -> e
107 -> g
108 -> ReactiveFieldRead m i
109 liftR4 f a b c d = ReactiveFieldRead getter notifier
110 where getter = do
111 x1 <- reactiveValueRead a
112 x2 <- reactiveValueRead b
113 x3 <- reactiveValueRead c
114 x4 <- reactiveValueRead d
115 return $ f (x1, x2, x3, x4)
116 notifier p = do
117 reactiveValueOnCanRead a p
118 reactiveValueOnCanRead b p
119 reactiveValueOnCanRead c p
120 reactiveValueOnCanRead d p
121
122 liftW4 :: ( Monad m
123 , ReactiveValueWrite a b m
124 , ReactiveValueWrite c d m
125 , ReactiveValueWrite e f m
126 , ReactiveValueWrite g h m) =>
127 (i -> (b,d,f,h))
128 -> a
129 -> c
130 -> e
131 -> g
132 -> ReactiveFieldWrite m i
133 liftW4 f a b c d = ReactiveFieldWrite setter
134 where setter x = do
135 let (x1,x2,x3,x4) = f x
136 reactiveValueWrite a x1
137 reactiveValueWrite b x2
138 reactiveValueWrite c x3
139 reactiveValueWrite d x4
140
141 liftRW4 :: ( ReactiveValueReadWrite a b m
142 , ReactiveValueReadWrite c d m
143 , ReactiveValueReadWrite e f m
144 , ReactiveValueReadWrite g h m) =>
145 BijectiveFunc i (b,d,f,h)
146 -> a
147 -> c
148 -> e
149 -> g
150 -> ReactiveFieldReadWrite m i
151 liftRW4 bij a b c d =
152 ReactiveFieldReadWrite setter getter notifier
153 where ReactiveFieldRead getter notifier = liftR4 f2 a b c d
154 ReactiveFieldWrite setter = liftW4 f1 a b c d
155 (f1, f2) = (direct bij, inverse bij)
156
157 liftR5 :: ( ReactiveValueRead a b m
158 , ReactiveValueRead c d m
159 , ReactiveValueRead e f m
160 , ReactiveValueRead g h m
161 , ReactiveValueRead i j m) =>
162 ((b,d,f,h,j) -> k)
163 -> a
164 -> c
165 -> e
166 -> g
167 -> i
168 -> ReactiveFieldRead m k
169 liftR5 f a b c d e = ReactiveFieldRead getter notifier
170 where getter = do
171 x1 <- reactiveValueRead a
172 x2 <- reactiveValueRead b
173 x3 <- reactiveValueRead c
174 x4 <- reactiveValueRead d
175 x5 <- reactiveValueRead e
176 return $ f (x1, x2, x3, x4, x5)
177 notifier p = do
178 reactiveValueOnCanRead a p
179 reactiveValueOnCanRead b p
180 reactiveValueOnCanRead c p
181 reactiveValueOnCanRead d p
182 reactiveValueOnCanRead e p
183
184 liftW5 :: ( Monad m
185 , ReactiveValueWrite a b m
186 , ReactiveValueWrite c d m
187 , ReactiveValueWrite e f m
188 , ReactiveValueWrite g h m
189 , ReactiveValueWrite i j m) =>
190 (k -> (b,d,f,h,j))
191 -> a
192 -> c
193 -> e
194 -> g
195 -> i
196 -> ReactiveFieldWrite m k
197 liftW5 f a b c d e = ReactiveFieldWrite setter
198 where setter x = do
199 let (x1,x2,x3,x4,x5) = f x
200 reactiveValueWrite a x1
201 reactiveValueWrite b x2
202 reactiveValueWrite c x3
203 reactiveValueWrite d x4
204 reactiveValueWrite e x5
205
206 liftRW5 :: ( ReactiveValueReadWrite a b m
207 , ReactiveValueReadWrite c d m
208 , ReactiveValueReadWrite e f m
209 , ReactiveValueReadWrite g h m
210 , ReactiveValueReadWrite i j m) =>
211 BijectiveFunc k (b,d,f,h,j)
212 -> a
213 -> c
214 -> e
215 -> g
216 -> i
217 -> ReactiveFieldReadWrite m k
218 liftRW5 bij a b c d e =
219 ReactiveFieldReadWrite setter getter notifier
220 where ReactiveFieldRead getter notifier = liftR5 f2 a b c d e
221 ReactiveFieldWrite setter = liftW5 f1 a b c d e
222 (f1, f2) = (direct bij, inverse bij)