module FRP.Reactive.Internal.Timing
(adaptE,mkUpdater,sleepPast)
where
import Data.Monoid (mempty)
import Control.Applicative ((<$>))
import Control.Monad (unless)
import Data.IORef
import Control.Concurrent (threadDelay)
import Control.Concurrent.SampleVar
import Control.Instances ()
import Data.AddBounds
import FRP.Reactive.Reactive (exactNB,TimeT,Event)
import FRP.Reactive.Improving (Improving,exact)
import FRP.Reactive.Behavior (Behavior)
import FRP.Reactive.Internal.Misc (Action,Sink)
import FRP.Reactive.Internal.Reactive (forkR,runE)
import FRP.Reactive.Internal.Behavior (unb)
import FRP.Reactive.Internal.Fun
import FRP.Reactive.Internal.Clock (makeClock,cGetTime)
adaptE :: Sink (Event Action)
adaptE e = do clock <- makeClock
runE (sleepPast (cGetTime clock) . exactNB) e
drainS :: SampleVar a -> Sink (Sink a)
drainS sv snk = do emptySVar <- isEmptySampleVar sv
unless emptySVar (readSampleVar sv >>= snk)
noSink :: Sink t
noSink = mempty
mkUpdater :: IO TimeT -> Behavior Action -> IO Action
mkUpdater getT acts =
do actSVar <- newEmptySampleVar
_ <- forkR (sleepPast' getT . exact)
(writeSampleVar' actSVar <$> unb acts)
tfunRef <- newIORef (noSink :: Sink TimeT)
return $
do
now <- getT
drainS actSVar $ \ actF ->
case actF of
K c -> do
writeIORef tfunRef noSink >> c
Fun f -> do
writeIORef tfunRef f
readIORef tfunRef >>= ($ now)
where
writeSampleVar' v x = do
writeSampleVar v x
sleep :: Sink TimeT
sleep = threadDelay . ceiling . (1.0e6 *)
sleepPast :: IO TimeT -> Sink TimeT
sleepPast getT !target =
do
now <- getT
unless (now > target) $
sleep (targetnow)
sleepPast' :: IO TimeT -> Sink (AddBounds TimeT)
sleepPast' _ MinBound = return ()
sleepPast' getT (NoBound target) = sleepPast getT target
sleepPast' _ MaxBound = error "sleepPast MaxBound. Expected??"