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 onTick :: (ReactiveValueRead a b m, ReactiveValueRead c d m) =>
  32           a -> c -> ReactiveFieldRead m d
  33 onTick notif rv = ReactiveFieldRead getter notifier
  34   where getter = reactiveValueRead rv
  35         notifier cb = do
  36           reactiveValueOnCanRead notif cb
  37           reactiveValueOnCanRead rv cb
  38 {-
  39 notif ^:> rv =
  40   reactiveValueOnCanRead notif (reactiveValueOnCanRead rv (return ()))
  41 -}
  42 -- Update when the value is an Event. It would be nice to have that
  43 -- even for Maybe as well.
  44 (>:>) :: (ReactiveValueRead a (Event b) IO, ReactiveValueWrite c b IO) =>
  45          a -> c -> IO ()
  46 eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
  47   where  syncOnEvent = do
  48            erv <- reactiveValueRead eventRV
  49            when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
  50 {-
  51 liftR3 :: ( Monad m
  52           , ReactiveValueRead a b m
  53           , ReactiveValueRead c d m
  54           , ReactiveValueRead e f m) =>
  55           ((b,d,f) -> i)
  56        -> a
  57        -> c
  58        -> e
  59        -> ReactiveFieldRead m i
  60 liftR3 f a b c = ReactiveFieldRead getter notifier
  61   where getter = do
  62           x1 <- reactiveValueRead a
  63           x2 <- reactiveValueRead b
  64           x3 <- reactiveValueRead c
  65           return $ f (x1, x2, x3)
  66         notifier p = reactiveValueOnCanRead a p >>
  67                      reactiveValueOnCanRead b p >>
  68                      reactiveValueOnCanRead c p
  69 -}
  70
  71 liftW3 :: ( Monad m
  72           , ReactiveValueWrite a b m
  73           , ReactiveValueWrite c d m
  74           , ReactiveValueWrite e f m) =>
  75           (i -> (b,d,f))
  76        -> a
  77        -> c
  78        -> e
  79        -> ReactiveFieldWrite m i
  80 liftW3 f a b c = ReactiveFieldWrite setter
  81   where setter x = do
  82           let (x1,x2,x3) = f x
  83           reactiveValueWrite a x1
  84           reactiveValueWrite b x2
  85           reactiveValueWrite c x3
  86
  87 liftRW3 :: ( Monad m
  88            , ReactiveValueReadWrite a b m
  89            , ReactiveValueReadWrite c d m
  90            , ReactiveValueReadWrite e f m) =>
  91            BijectiveFunc i (b,d,f)
  92         -> a
  93         -> c
  94         -> e
  95         -> ReactiveFieldReadWrite m i
  96 liftRW3 bij a b c =
  97   ReactiveFieldReadWrite setter getter notifier
  98   where ReactiveFieldRead getter notifier = liftR3 (curry3 f2) a b c
  99         ReactiveFieldWrite setter = liftW3 f1 a b c
 100         (f1, f2) = (direct bij, inverse bij)
 101
 102 liftR4 :: ( Monad m
 103           , ReactiveValueRead a b m
 104           , ReactiveValueRead c d m
 105           , ReactiveValueRead e f m
 106           , ReactiveValueRead g h m) =>
 107           ((b,d,f,h) -> i)
 108        -> a
 109        -> c
 110        -> e
 111        -> g
 112        -> ReactiveFieldRead m i
 113 liftR4 f a b c d = ReactiveFieldRead getter notifier
 114   where getter = do
 115           x1 <- reactiveValueRead a
 116           x2 <- reactiveValueRead b
 117           x3 <- reactiveValueRead c
 118           x4 <- reactiveValueRead d
 119           return $ f (x1, x2, x3, x4)
 120         notifier p = do
 121           reactiveValueOnCanRead a p
 122           reactiveValueOnCanRead b p
 123           reactiveValueOnCanRead c p
 124           reactiveValueOnCanRead d p
 125
 126 liftW4 :: ( Monad m
 127           , ReactiveValueWrite a b m
 128           , ReactiveValueWrite c d m
 129           , ReactiveValueWrite e f m
 130           , ReactiveValueWrite g h m) =>
 131           (i -> (b,d,f,h))
 132        -> a
 133        -> c
 134        -> e
 135        -> g
 136        -> ReactiveFieldWrite m i
 137 liftW4 f a b c d = ReactiveFieldWrite setter
 138   where setter x = do
 139           let (x1,x2,x3,x4) = f x
 140           reactiveValueWrite a x1
 141           reactiveValueWrite b x2
 142           reactiveValueWrite c x3
 143           reactiveValueWrite d x4
 144
 145 liftRW4 :: ( Monad m
 146            , ReactiveValueReadWrite a b m
 147            , ReactiveValueReadWrite c d m
 148            , ReactiveValueReadWrite e f m
 149            , ReactiveValueReadWrite g h m) =>
 150            BijectiveFunc i (b,d,f,h)
 151         -> a
 152         -> c
 153         -> e
 154         -> g
 155         -> ReactiveFieldReadWrite m i
 156 liftRW4 bij a b c d =
 157   ReactiveFieldReadWrite setter getter notifier
 158   where ReactiveFieldRead getter notifier = liftR4 f2 a b c d
 159         ReactiveFieldWrite setter = liftW4 f1 a b c d
 160         (f1, f2) = (direct bij, inverse bij)