module Hails.Yampa where
import Control.Monad (when, void)
import Data.CBMVar
import Data.IORef
import Data.Maybe (fromJust)
import Data.ReactiveValue
import Data.Time.Clock
import FRP.Yampa
yampaReactiveDual :: a -> SF a b
-> IO (ReactiveFieldWrite IO a, ReactiveFieldRead IO b)
yampaReactiveDual :: a -> SF a b -> IO (ReactiveFieldWrite IO a, ReactiveFieldRead IO b)
yampaReactiveDual a
initial SF a b
sf = do
CBMVar (Maybe b)
mvar <- Maybe b -> IO (CBMVar (Maybe b))
forall a. a -> IO (CBMVar a)
newCBMVar Maybe b
forall a. Maybe a
Nothing
UTCTime
initialClock <- IO UTCTime
getCurrentTime
IORef UTCTime
lastTimeR <- UTCTime -> IO (IORef UTCTime)
forall a. a -> IO (IORef a)
newIORef UTCTime
initialClock
ReactHandle a b
rh <- IO a
-> (ReactHandle a b -> Bool -> b -> IO Bool)
-> SF a b
-> IO (ReactHandle a b)
forall a b.
IO a
-> (ReactHandle a b -> Bool -> b -> IO Bool)
-> SF a b
-> IO (ReactHandle a b)
reactInit
(a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
initial)
(\ReactHandle a b
_ Bool
changed b
output -> do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
changed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CBMVar (Maybe b) -> Maybe b -> IO ()
forall a. CBMVar a -> a -> IO ()
writeCBMVar CBMVar (Maybe b)
mvar (b -> Maybe b
forall a. a -> Maybe a
Just b
output)
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
)
SF a b
sf
let getter :: IO b
getter = (Maybe b -> b) -> IO (Maybe b) -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe b -> b
forall a. HasCallStack => Maybe a -> a
fromJust (IO (Maybe b) -> IO b) -> IO (Maybe b) -> IO b
forall a b. (a -> b) -> a -> b
$ CBMVar (Maybe b) -> IO (Maybe b)
forall a. CBMVar a -> IO a
readCBMVar CBMVar (Maybe b)
mvar
setter :: a -> IO ()
setter a
y = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
UTCTime
newTime <- IO UTCTime
getCurrentTime
UTCTime
lastTime <- IORef UTCTime -> IO UTCTime
forall a. IORef a -> IO a
readIORef IORef UTCTime
lastTimeR
let dt :: DTime
dt = NominalDiffTime -> DTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (NominalDiffTime -> DTime) -> NominalDiffTime -> DTime
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
newTime UTCTime
lastTime
IORef UTCTime -> UTCTime -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef UTCTime
lastTimeR UTCTime
newTime
ReactHandle a b -> (DTime, Maybe a) -> IO Bool
forall a b. ReactHandle a b -> (DTime, Maybe a) -> IO Bool
react ReactHandle a b
rh (DTime
dt, a -> Maybe a
forall a. a -> Maybe a
Just a
y)
notifier :: IO () -> IO ()
notifier IO ()
evH = CBMVar (Maybe b) -> IO () -> IO ()
forall a. CBMVar a -> IO () -> IO ()
installCallbackCBMVar CBMVar (Maybe b)
mvar IO ()
evH
let rvRead :: ReactiveFieldRead IO b
rvRead = IO b -> (IO () -> IO ()) -> ReactiveFieldRead IO b
forall (m :: * -> *) a.
FieldGetter m a -> FieldNotifier m a -> ReactiveFieldRead m a
ReactiveFieldRead IO b
getter IO () -> IO ()
notifier
rvWrite :: ReactiveFieldWrite IO a
rvWrite = (a -> IO ()) -> ReactiveFieldWrite IO a
forall (m :: * -> *) a. FieldSetter m a -> ReactiveFieldWrite m a
ReactiveFieldWrite a -> IO ()
setter
(ReactiveFieldWrite IO a, ReactiveFieldRead IO b)
-> IO (ReactiveFieldWrite IO a, ReactiveFieldRead IO b)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReactiveFieldWrite IO a
rvWrite, ReactiveFieldRead IO b
rvRead)
yampaReactive :: a -> SF a a -> IO (ReactiveFieldReadWrite IO a)
yampaReactive :: a -> SF a a -> IO (ReactiveFieldReadWrite IO a)
yampaReactive a
initial SF a a
sf = do
CBMVar a
mvar <- a -> IO (CBMVar a)
forall a. a -> IO (CBMVar a)
newCBMVar a
initial
UTCTime
initialClock <- IO UTCTime
getCurrentTime
IORef UTCTime
lastTimeR <- UTCTime -> IO (IORef UTCTime)
forall a. a -> IO (IORef a)
newIORef UTCTime
initialClock
ReactHandle a a
rh <- IO a
-> (ReactHandle a a -> Bool -> a -> IO Bool)
-> SF a a
-> IO (ReactHandle a a)
forall a b.
IO a
-> (ReactHandle a b -> Bool -> b -> IO Bool)
-> SF a b
-> IO (ReactHandle a b)
reactInit
(CBMVar a -> IO a
forall a. CBMVar a -> IO a
readCBMVar CBMVar a
mvar)
(\ReactHandle a a
_ Bool
changed a
output -> do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
changed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CBMVar a -> a -> IO ()
forall a. CBMVar a -> a -> IO ()
writeCBMVar CBMVar a
mvar a
output
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
)
SF a a
sf
let getter :: IO a
getter = CBMVar a -> IO a
forall a. CBMVar a -> IO a
readCBMVar CBMVar a
mvar
setter :: a -> IO ()
setter a
y = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
UTCTime
newTime <- IO UTCTime
getCurrentTime
UTCTime
lastTime <- IORef UTCTime -> IO UTCTime
forall a. IORef a -> IO a
readIORef IORef UTCTime
lastTimeR
let dt :: DTime
dt = NominalDiffTime -> DTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (NominalDiffTime -> DTime) -> NominalDiffTime -> DTime
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
newTime UTCTime
lastTime
IORef UTCTime -> UTCTime -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef UTCTime
lastTimeR UTCTime
newTime
ReactHandle a a -> (DTime, Maybe a) -> IO Bool
forall a b. ReactHandle a b -> (DTime, Maybe a) -> IO Bool
react ReactHandle a a
rh (DTime
dt, a -> Maybe a
forall a. a -> Maybe a
Just a
y)
notifier :: IO () -> IO ()
notifier = CBMVar a -> IO () -> IO ()
forall a. CBMVar a -> IO () -> IO ()
installCallbackCBMVar CBMVar a
mvar
ReactiveFieldReadWrite IO a -> IO (ReactiveFieldReadWrite IO a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReactiveFieldReadWrite IO a -> IO (ReactiveFieldReadWrite IO a))
-> ReactiveFieldReadWrite IO a -> IO (ReactiveFieldReadWrite IO a)
forall a b. (a -> b) -> a -> b
$ (a -> IO ())
-> IO a -> (IO () -> IO ()) -> ReactiveFieldReadWrite IO a
forall (m :: * -> *) a.
FieldSetter m a
-> FieldGetter m a
-> FieldNotifier m a
-> ReactiveFieldReadWrite m a
ReactiveFieldReadWrite a -> IO ()
setter IO a
getter IO () -> IO ()
notifier
yampaReactive' :: a -> SF a a -> IO (ReactiveFieldReadWrite IO a)
yampaReactive' :: a -> SF a a -> IO (ReactiveFieldReadWrite IO a)
yampaReactive' a
initial SF a a
sf = do
(ReactiveFieldWrite IO a
rvW, ReactiveFieldRead IO a
rvR) <- a -> SF a a -> IO (ReactiveFieldWrite IO a, ReactiveFieldRead IO a)
forall a b.
a -> SF a b -> IO (ReactiveFieldWrite IO a, ReactiveFieldRead IO b)
yampaReactiveDual a
initial SF a a
sf
ReactiveFieldReadWrite IO a -> IO (ReactiveFieldReadWrite IO a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReactiveFieldReadWrite IO a -> IO (ReactiveFieldReadWrite IO a))
-> ReactiveFieldReadWrite IO a -> IO (ReactiveFieldReadWrite IO a)
forall a b. (a -> b) -> a -> b
$ ReactiveFieldRead IO a
-> ReactiveFieldWrite IO a -> ReactiveFieldReadWrite IO a
forall r1 a (m :: * -> *) r2.
(ReactiveValueRead r1 a m, ReactiveValueWrite r2 a m) =>
r1 -> r2 -> ReactiveFieldReadWrite m a
combineRVReadWrite ReactiveFieldRead IO a
rvR ReactiveFieldWrite IO a
rvW
combineRVReadWrite :: (ReactiveValueRead r1 a m, ReactiveValueWrite r2 a m)
=> r1 -> r2 -> ReactiveFieldReadWrite m a
combineRVReadWrite :: r1 -> r2 -> ReactiveFieldReadWrite m a
combineRVReadWrite r1
rvR r2
rvW = FieldSetter m a
-> FieldGetter m a
-> FieldNotifier m a
-> ReactiveFieldReadWrite m a
forall (m :: * -> *) a.
FieldSetter m a
-> FieldGetter m a
-> FieldNotifier m a
-> ReactiveFieldReadWrite m a
ReactiveFieldReadWrite FieldSetter m a
setter FieldGetter m a
getter FieldNotifier m a
notifier
where getter :: FieldGetter m a
getter = r1 -> FieldGetter m a
forall a b (m :: * -> *). ReactiveValueRead a b m => a -> m b
reactiveValueRead r1
rvR
setter :: FieldSetter m a
setter = r2 -> FieldSetter m a
forall a b (m :: * -> *).
ReactiveValueWrite a b m =>
a -> b -> m ()
reactiveValueWrite r2
rvW
notifier :: FieldNotifier m a
notifier = r1 -> FieldNotifier m a
forall a b (m :: * -> *).
ReactiveValueRead a b m =>
a -> m () -> m ()
reactiveValueOnCanRead r1
rvR