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)