module FRP.Rhine.Clock.Select where
import FRP.Rhine
import Data.Maybe (catMaybes, maybeToList)
data SelectClock cl a = SelectClock
{ mainClock :: cl
, select :: Tag cl -> Maybe a
}
instance (Monad m, Clock m cl) => Clock m (SelectClock cl a) where
type TimeDomainOf (SelectClock cl _) = TimeDomainOf cl
type Tag (SelectClock cl a) = a
startClock SelectClock {..} = do
(runningClock, initialTime) <- startClock mainClock
let
runningSelectClock = filterS $ proc _ -> do
(time, tag) <- runningClock -< ()
returnA -< (time, ) <$> select tag
return (runningSelectClock, initialTime)
schedSelectClocks
:: (Monad m, Monoid cl, Clock m cl)
=> Schedule m (SelectClock cl a) (SelectClock cl b)
schedSelectClocks = Schedule {..}
where
startSchedule subClock1 subClock2 = do
(runningClock, initialTime) <- startClock
$ mainClock subClock1 `mappend` mainClock subClock2
let
runningSelectClocks = concatS $ proc _ -> do
(time, tag) <- runningClock -< ()
returnA -< catMaybes
[ (time, ) . Left <$> select subClock1 tag
, (time, ) . Right <$> select subClock2 tag ]
return (runningSelectClocks, initialTime)
concatS :: Monad m => MStream m [b] -> MStream m b
concatS msf = MSF $ \_ -> tick msf []
where
tick msf (b:bs) = return (b, MSF $ \_ -> tick msf bs)
tick msf [] = do
(bs, msf') <- unMSF msf ()
tick msf' bs
filterS :: Monad m => MSF m () (Maybe b) -> MSF m () b
filterS = concatS . (>>> arr maybeToList)