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)