src/RMCA/Auxiliary/ReactiveValue.hs

   1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
   2
   3 module RMCA.Auxiliary.ReactiveValue where
   4
   5 import Control.Monad
   6 import Data.CBMVar
   7 import Data.CBRef
   8 import Data.ReactiveValue
   9 import FRP.Yampa
  10 import RMCA.Auxiliary.Misc
  11
  12 -- |
  13 -- = Auxiliary functions for manipulating reactive values
  14
  15 -- | Creates a new 'CBMVar' wrapped into a reactive field.
  16 newCBMVarRW :: a -> IO (ReactiveFieldReadWrite IO a)
  17 newCBMVarRW val = do
  18   mvar <- newCBMVar val
  19   let getter = readCBMVar mvar
  20       setter = writeCBMVar mvar
  21       notifier = installCallbackCBMVar mvar
  22   return $ ReactiveFieldReadWrite setter getter notifier
  23
  24 -- | Writes a value to a reactive value if the value is different from the one already in the reactive value.
  25 reactiveValueWriteOnNotEq :: ( Eq b
  26                              , ReactiveValueReadWrite a b m) =>
  27                              a -> b -> m ()
  28 reactiveValueWriteOnNotEq rv nv = do
  29   ov <- reactiveValueRead rv
  30   when (ov /= nv) $ reactiveValueWrite rv nv
  31
  32 -- | Relation that will update when the value is an 'Event'.
  33 (>:>) :: (ReactiveValueRead a (Event b) IO, ReactiveValueWrite c b IO) =>
  34          a -> c -> IO ()
  35 eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
  36   where  syncOnEvent = do
  37            erv <- reactiveValueRead eventRV
  38            when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
  39
  40 -- | When the reactive value on the left changes, the value on the right is updated using the value it contains and the value on the left with the provided function.
  41 syncRightOnLeftWithBoth :: ( ReactiveValueRead a b m
  42                            , ReactiveValueReadWrite c d m
  43                            ) => (b -> d -> d) -> a -> c -> m ()
  44 syncRightOnLeftWithBoth f l r = reactiveValueOnCanRead l $ do
  45   nl <- reactiveValueRead l
  46   or <- reactiveValueRead r
  47   reactiveValueWrite r (f nl or)
  48
  49 -- | Forces to update an reactive value by writing to it with the value it contains.
  50 updateRV :: (ReactiveValueReadWrite a b m) => a -> m ()
  51 updateRV rv = reactiveValueRead rv >>= reactiveValueWrite rv
  52
  53 floatConv :: (ReactiveValueReadWrite a b m,
  54               Real c, Real b, Fractional c, Fractional b) =>
  55              a -> ReactiveFieldReadWrite m c
  56 floatConv = liftRW $ bijection (realToFrac, realToFrac)
  57
  58 swapHandlerStorage :: (ReactiveValueReadWrite a b IO) =>
  59                       a -> IO (ReactiveFieldReadWrite IO b)
  60 swapHandlerStorage rv = do
  61   ioref <- newCBRef ()
  62   let setter val = reactiveValueWrite rv val >> writeCBRef ioref ()
  63       getter     = reactiveValueRead rv
  64       notifier   = installCallbackCBRef ioref
  65   return $ ReactiveFieldReadWrite setter getter notifier
  66
  67 liftW3 :: ( Monad m
  68           , ReactiveValueWrite a b m
  69           , ReactiveValueWrite c d m
  70           , ReactiveValueWrite e f m) =>
  71           (i -> (b,d,f)) -> a -> c -> e -> ReactiveFieldWrite m i
  72 liftW3 f a b c = ReactiveFieldWrite setter
  73   where setter x = do
  74           let (x1,x2,x3) = f x
  75           reactiveValueWrite a x1
  76           reactiveValueWrite b x2
  77           reactiveValueWrite c x3
  78
  79 liftRW3 :: ( ReactiveValueReadWrite a b m
  80            , ReactiveValueReadWrite c d m
  81            , ReactiveValueReadWrite e f m) =>
  82            BijectiveFunc i (b,d,f) -> a -> c -> e -> ReactiveFieldReadWrite m i
  83 liftRW3 bij a b c =
  84   ReactiveFieldReadWrite setter getter notifier
  85   where ReactiveFieldRead getter notifier = liftR3 (curry3 f2) a b c
  86         ReactiveFieldWrite setter = liftW3 f1 a b c
  87         (f1, f2) = (direct bij, inverse bij)
  88
  89 liftR4 :: ( ReactiveValueRead a b m
  90           , ReactiveValueRead c d m
  91           , ReactiveValueRead e f m
  92           , ReactiveValueRead g h m) =>
  93           (b -> d -> f -> h -> i) -> a -> c -> e -> g -> ReactiveFieldRead m i
  94 liftR4 f a b c d = ReactiveFieldRead getter notifier
  95   where getter = do
  96           x1 <- reactiveValueRead a
  97           x2 <- reactiveValueRead b
  98           x3 <- reactiveValueRead c
  99           x4 <- reactiveValueRead d
 100           return $ f x1 x2 x3 x4
 101         notifier p = do
 102           reactiveValueOnCanRead a p
 103           reactiveValueOnCanRead b p
 104           reactiveValueOnCanRead c p
 105           reactiveValueOnCanRead d p
 106
 107 liftW4 :: ( Monad m
 108           , ReactiveValueWrite a b m
 109           , ReactiveValueWrite c d m
 110           , ReactiveValueWrite e f m
 111           , ReactiveValueWrite g h m) =>
 112           (i -> (b,d,f,h)) -> a -> c -> e -> g -> ReactiveFieldWrite m i
 113 liftW4 f a b c d = ReactiveFieldWrite setter
 114   where setter x = do
 115           let (x1,x2,x3,x4) = f x
 116           reactiveValueWrite a x1
 117           reactiveValueWrite b x2
 118           reactiveValueWrite c x3
 119           reactiveValueWrite d x4
 120
 121 liftRW4 :: ( ReactiveValueReadWrite a b m
 122            , ReactiveValueReadWrite c d m
 123            , ReactiveValueReadWrite e f m
 124            , ReactiveValueReadWrite g h m) =>
 125            BijectiveFunc i (b,d,f,h) -> a -> c -> e -> g
 126         -> ReactiveFieldReadWrite m i
 127 liftRW4 bij a b c d =
 128   ReactiveFieldReadWrite setter getter notifier
 129   where ReactiveFieldRead getter notifier = liftR4 (curry4 f2) a b c d
 130         ReactiveFieldWrite setter = liftW4 f1 a b c d
 131         (f1, f2) = (direct bij, inverse bij)
 132
 133 liftR5 :: ( ReactiveValueRead a b m
 134           , ReactiveValueRead c d m
 135           , ReactiveValueRead e f m
 136           , ReactiveValueRead g h m
 137           , ReactiveValueRead i j m) =>
 138           (b -> d -> f -> h -> j -> k) -> a -> c -> e -> g -> i
 139        -> ReactiveFieldRead m k
 140 liftR5 f a b c d e = ReactiveFieldRead getter notifier
 141   where getter = do
 142           x1 <- reactiveValueRead a
 143           x2 <- reactiveValueRead b
 144           x3 <- reactiveValueRead c
 145           x4 <- reactiveValueRead d
 146           x5 <- reactiveValueRead e
 147           return $ f x1 x2 x3 x4 x5
 148         notifier p = do
 149           reactiveValueOnCanRead a p
 150           reactiveValueOnCanRead b p
 151           reactiveValueOnCanRead c p
 152           reactiveValueOnCanRead d p
 153           reactiveValueOnCanRead e p
 154
 155 liftW5 :: ( Monad m
 156           , ReactiveValueWrite a b m
 157           , ReactiveValueWrite c d m
 158           , ReactiveValueWrite e f m
 159           , ReactiveValueWrite g h m
 160           , ReactiveValueWrite i j m) =>
 161           (k -> (b,d,f,h,j)) -> a -> c -> e -> g -> i -> ReactiveFieldWrite m k
 162 liftW5 f a b c d e = ReactiveFieldWrite setter
 163   where setter x = do
 164           let (x1,x2,x3,x4,x5) = f x
 165           reactiveValueWrite a x1
 166           reactiveValueWrite b x2
 167           reactiveValueWrite c x3
 168           reactiveValueWrite d x4
 169           reactiveValueWrite e x5
 170
 171 liftRW5 :: ( ReactiveValueReadWrite a b m
 172            , ReactiveValueReadWrite c d m
 173            , ReactiveValueReadWrite e f m
 174            , ReactiveValueReadWrite g h m
 175            , ReactiveValueReadWrite i j m) =>
 176            BijectiveFunc k (b,d,f,h,j) -> a -> c -> e -> g -> i
 177         -> ReactiveFieldReadWrite m k
 178 liftRW5 bij a b c d e =
 179   ReactiveFieldReadWrite setter getter notifier
 180   where ReactiveFieldRead getter notifier = liftR5 (curry5 f2) a b c d e
 181         ReactiveFieldWrite setter = liftW5 f1 a b c d e
 182         (f1, f2) = (direct bij, inverse bij)