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