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