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 initial sf = do
mvar <- newCBMVar Nothing
initialClock <- getCurrentTime
lastTimeR <- newIORef initialClock
rh <- reactInit
(return initial)
(\_ changed output -> do when changed $ writeCBMVar mvar (Just output)
return False
)
sf
let getter = fmap fromJust $ readCBMVar mvar
setter y = void $ do
newTime <- getCurrentTime
lastTime <- readIORef lastTimeR
let dt = realToFrac $ diffUTCTime newTime lastTime
writeIORef lastTimeR newTime
react rh (dt, Just y)
notifier evH = installCallbackCBMVar mvar evH
let rvRead = ReactiveFieldRead getter notifier
rvWrite = ReactiveFieldWrite setter
return (rvWrite, rvRead)
yampaReactive :: a -> SF a a -> IO (ReactiveFieldReadWrite IO a)
yampaReactive initial sf = do
mvar <- newCBMVar initial
initialClock <- getCurrentTime
lastTimeR <- newIORef initialClock
rh <- reactInit
(readCBMVar mvar)
(\_ changed output -> do when changed $ writeCBMVar mvar output
return False
)
sf
let getter = readCBMVar mvar
setter y = void $ do
newTime <- getCurrentTime
lastTime <- readIORef lastTimeR
let dt = realToFrac $ diffUTCTime newTime lastTime
writeIORef lastTimeR newTime
react rh (dt, Just y)
notifier = installCallbackCBMVar mvar
return $ ReactiveFieldReadWrite setter getter notifier
yampaReactive' :: a -> SF a a -> IO (ReactiveFieldReadWrite IO a)
yampaReactive' initial sf = do
(rvW, rvR) <- yampaReactiveDual initial sf
return $ combineRVReadWrite rvR rvW
combineRVReadWrite :: (ReactiveValueRead r1 a m, ReactiveValueWrite r2 a m)
=> r1 -> r2 -> ReactiveFieldReadWrite m a
combineRVReadWrite rvR rvW = ReactiveFieldReadWrite setter getter notifier
where getter = reactiveValueRead rvR
setter = reactiveValueWrite rvW
notifier = reactiveValueOnCanRead rvR