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 :: ( Monad m
 104            , ReactiveValueReadWrite a b m
 105            , ReactiveValueReadWrite c d m
 106            , ReactiveValueReadWrite e f m) =>
 107            BijectiveFunc i (b,d,f)
 108         -> a
 109         -> c
 110         -> e
 111         -> ReactiveFieldReadWrite m i
 112 liftRW3 bij a b c =
 113   ReactiveFieldReadWrite setter getter notifier
 114   where ReactiveFieldRead getter notifier = liftR3 (curry3 f2) a b c
 115         ReactiveFieldWrite setter = liftW3 f1 a b c
 116         (f1, f2) = (direct bij, inverse bij)
 117
 118 liftR4 :: ( Monad m
 119           , ReactiveValueRead a b m
 120           , ReactiveValueRead c d m
 121           , ReactiveValueRead e f m
 122           , ReactiveValueRead g h m) =>
 123           ((b,d,f,h) -> i)
 124        -> a
 125        -> c
 126        -> e
 127        -> g
 128        -> ReactiveFieldRead m i
 129 liftR4 f a b c d = ReactiveFieldRead getter notifier
 130   where getter = do
 131           x1 <- reactiveValueRead a
 132           x2 <- reactiveValueRead b
 133           x3 <- reactiveValueRead c
 134           x4 <- reactiveValueRead d
 135           return $ f (x1, x2, x3, x4)
 136         notifier p = do
 137           reactiveValueOnCanRead a p
 138           reactiveValueOnCanRead b p
 139           reactiveValueOnCanRead c p
 140           reactiveValueOnCanRead d p
 141
 142 liftW4 :: ( Monad m
 143           , ReactiveValueWrite a b m
 144           , ReactiveValueWrite c d m
 145           , ReactiveValueWrite e f m
 146           , ReactiveValueWrite g h m) =>
 147           (i -> (b,d,f,h))
 148        -> a
 149        -> c
 150        -> e
 151        -> g
 152        -> ReactiveFieldWrite m i
 153 liftW4 f a b c d = ReactiveFieldWrite setter
 154   where setter x = do
 155           let (x1,x2,x3,x4) = f x
 156           reactiveValueWrite a x1
 157           reactiveValueWrite b x2
 158           reactiveValueWrite c x3
 159           reactiveValueWrite d x4
 160
 161 liftRW4 :: ( Monad m
 162            , ReactiveValueReadWrite a b m
 163            , ReactiveValueReadWrite c d m
 164            , ReactiveValueReadWrite e f m
 165            , ReactiveValueReadWrite g h m) =>
 166            BijectiveFunc i (b,d,f,h)
 167         -> a
 168         -> c
 169         -> e
 170         -> g
 171         -> ReactiveFieldReadWrite m i
 172 liftRW4 bij a b c d =
 173   ReactiveFieldReadWrite setter getter notifier
 174   where ReactiveFieldRead getter notifier = liftR4 f2 a b c d
 175         ReactiveFieldWrite setter = liftW4 f1 a b c d
 176         (f1, f2) = (direct bij, inverse bij)