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