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
  10 newCBMVarRW :: forall a. a -> IO (ReactiveFieldReadWrite IO a)
  11 newCBMVarRW val = do
  12   mvar <- newCBMVar val
  13   let getter :: IO a
  14       getter = readCBMVar mvar
  15       setter :: a -> IO ()
  16       setter = writeCBMVar mvar
  17       notifier :: IO () -> IO ()
  18       notifier = installCallbackCBMVar mvar
  19   return $ ReactiveFieldReadWrite setter getter notifier
  20
  21 emptyRW :: (Monoid b, ReactiveValueReadWrite a b m) => a -> m b
  22 emptyRW rv = do
  23   val <- reactiveValueRead rv
  24   reactiveValueWrite rv mempty
  25   return val
  26
  27 emptyW :: (Monoid b, ReactiveValueWrite a b m) => a -> m ()
  28 emptyW rv = reactiveValueWrite rv mempty
  29
  30 (^:>) :: (ReactiveValueRead a b m, ReactiveValueReadWrite c d m) =>
  31          a -> c -> m ()
  32 notif ^:> rv = reactiveValueOnCanRead notif resync
  33   where resync = reactiveValueRead rv >>= reactiveValueWrite rv
  34
  35 -- Update when the value is an Event. It would be nice to have that
  36 -- even for Maybe as well.
  37 (>:>) :: (ReactiveValueRead a (Event b) m, ReactiveValueWrite c b m) =>
  38          a -> c -> m ()
  39 eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
  40   where  syncOnEvent = do
  41            erv <- reactiveValueRead eventRV
  42            when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
  43
  44 liftR3 :: ( Monad m
  45           , ReactiveValueRead a b m
  46           , ReactiveValueRead c d m
  47           , ReactiveValueRead e f m) =>
  48           ((b,d,f) -> i)
  49        -> a
  50        -> c
  51        -> e
  52        -> ReactiveFieldRead m i
  53 liftR3 f a b c = ReactiveFieldRead getter notifier
  54   where getter = do
  55           x1 <- reactiveValueRead a
  56           x2 <- reactiveValueRead b
  57           x3 <- reactiveValueRead c
  58           return $ f (x1, x2, x3)
  59         notifier p = reactiveValueOnCanRead a p >>
  60                      reactiveValueOnCanRead b p >>
  61                      reactiveValueOnCanRead c p
  62
  63 liftW3 :: ( Monad m
  64           , ReactiveValueWrite a b m
  65           , ReactiveValueWrite c d m
  66           , ReactiveValueWrite e f m) =>
  67           (i -> (b,d,f))
  68        -> a
  69        -> c
  70        -> e
  71        -> ReactiveFieldWrite m i
  72 liftW3 f a b c = ReactiveFieldWrite setter
  73   where setter x = do
  74           let (x1,x2,x3) = f x
  75           reactiveValueWrite a x1
  76           reactiveValueWrite b x2
  77           reactiveValueWrite c x3
  78
  79 liftR4 :: ( Monad m
  80           , ReactiveValueRead a b m
  81           , ReactiveValueRead c d m
  82           , ReactiveValueRead e f m
  83           , ReactiveValueRead g h m) =>
  84           ((b,d,f,h) -> i)
  85        -> a
  86        -> c
  87        -> e
  88        -> g
  89        -> ReactiveFieldRead m i
  90 liftR4 f a b c d = ReactiveFieldRead getter notifier
  91   where getter = do
  92           x1 <- reactiveValueRead a
  93           x2 <- reactiveValueRead b
  94           x3 <- reactiveValueRead c
  95           x4 <- reactiveValueRead d
  96           return $ f (x1, x2, x3, x4)
  97         notifier p = reactiveValueOnCanRead a p >>
  98                      reactiveValueOnCanRead b p >>
  99                      reactiveValueOnCanRead c p >>
 100                      reactiveValueOnCanRead d p
 101
 102 liftW4 :: ( Monad m
 103           , ReactiveValueWrite a b m
 104           , ReactiveValueWrite c d m
 105           , ReactiveValueWrite e f m
 106           , ReactiveValueWrite g h m) =>
 107           (i -> (b,d,f,h))
 108        -> a
 109        -> c
 110        -> e
 111        -> g
 112        -> ReactiveFieldWrite m i
 113 liftW4 f a b c d = ReactiveFieldWrite setter
 114   where setter x = do
 115           let (x1,x2,x3,x4) = f x
 116           reactiveValueWrite a x1
 117           reactiveValueWrite b x2
 118           reactiveValueWrite c x3
 119           reactiveValueWrite d x4
 120
 121 liftRW4 :: ( Monad m
 122            , ReactiveValueReadWrite a b m
 123            , ReactiveValueReadWrite c d m
 124            , ReactiveValueReadWrite e f m
 125            , ReactiveValueReadWrite g h m) =>
 126            BijectiveFunc i (b,d,f,h)
 127         -> a
 128         -> c
 129         -> e
 130         -> g
 131         -> ReactiveFieldReadWrite m i
 132 liftRW4 bij a b c d =
 133   ReactiveFieldReadWrite setter getter notifier
 134   where ReactiveFieldRead getter notifier = liftR4 f2 a b c d
 135         ReactiveFieldWrite setter = liftW4 f1 a b c d
 136         (f1, f2) = (direct bij, inverse bij)