module FRP.Reactive.Internal.TVal
(
makeFuture, makeEvent, Fed, MkFed
) where
import Control.Arrow (first)
import Control.Applicative ((<$>))
import Control.Monad (forever)
import Control.Concurrent (forkIO,yield)
import Control.Concurrent.Chan
import System.IO.Unsafe (unsafePerformIO)
import Data.Unamb (unamb,assuming)
import FRP.Reactive.Improving (Improving(..))
import FRP.Reactive.Future (FutureG,future)
import FRP.Reactive.Reactive (Event,TimeT,ITime)
import FRP.Reactive.PrimReactive (futuresE)
import FRP.Reactive.Internal.Misc (Sink)
import FRP.Reactive.Internal.Clock
import FRP.Reactive.Internal.Timing (sleepPast)
import FRP.Reactive.Internal.IVar
data TVal t a = TVal { timeVal :: (t,a), definedAt :: t -> Bool }
makeTVal :: Clock TimeT -> IO (TVal TimeT a, Sink a)
makeTVal (Clock getT serial) = f <$> newEmptyIVar
where
f v = ( TVal (readIVar v)
(\ t -> unsafePerformIO $ do
sleepPast getT t
do value <- tryReadIVar v
return $ case value of
Nothing -> False
Just (t',_) -> t' < t)
, \ a -> serial (getT >>= \ t -> writeIVar v (t,a))
)
tValFuture :: Ord t => TVal t a -> FutureG (Improving t) a
tValFuture v = future (tValImp v) (snd (timeVal v))
tValImp :: Ord t => TVal t a -> Improving t
tValImp v = Imp ta (\ t -> assuming (not (definedAt v t)) GT
`unamb` (ta `compare` t))
where
ta = fst (timeVal v)
type Fed a b = (a, Sink b)
type MkFed a b = IO (Fed a b)
makeFuture :: Clock TimeT -> MkFed (FutureG ITime a) a
makeFuture = (fmap.fmap.first) tValFuture makeTVal
makeEvent :: Clock TimeT -> MkFed (Event a) a
makeEvent clock = (fmap.first) futuresE (listSink (makeFuture clock))
listSink :: MkFed a b -> MkFed [a] b
listSink mk = do chanA <- newChan
chanB <- newChan
forkIO . forever $ do
(a,snk) <- mk
writeChan chanB a
readChan chanA >>= snk
as <- getChanContents chanB
return (as, writeChanY chanA)
where
writeChanY ch x = writeChan ch x >> yield