{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module FRP.Rhine.Reactimation.ClockErasure where
import Control.Monad (join)
import Data.Maybe (fromJust, fromMaybe)
import Control.Monad.Trans.MSF.Reader
import Data.MonadicStreamFunction
import Data.MonadicStreamFunction.InternalCore
import FRP.Rhine.Clock
import FRP.Rhine.Clock.Proxy
import FRP.Rhine.Clock.Util
import FRP.Rhine.ClSF hiding (runReaderS)
import FRP.Rhine.ResamplingBuffer
import FRP.Rhine.Schedule
import FRP.Rhine.SN
eraseClockClSF
:: (Monad m, Clock m cl)
=> ClockProxy cl -> Time cl
-> ClSF m cl a b
-> MSF m (Time cl, Tag cl, a) b
eraseClockClSF proxy initialTime clsf = proc (time, tag, a) -> do
timeInfo <- genTimeInfo proxy initialTime -< (time, tag)
runReaderS clsf -< (timeInfo, a)
eraseClockSN
:: (Monad m, Clock m cl, GetClockProxy cl)
=> Time cl
-> SN m cl a b
-> MSF m (Time cl, Tag cl, Maybe a) (Maybe b)
eraseClockSN initialTime sn@(Synchronous clsf) = proc (time, tag, Just a) -> do
b <- eraseClockClSF (toClockProxy sn) initialTime clsf -< (time, tag, a)
returnA -< Just b
eraseClockSN initialTime (Sequential sn1 resBuf sn2) =
let
proxy1 = toClockProxy sn1
proxy2 = toClockProxy sn2
in proc (time, tag, maybeA) -> do
resBufIn <- case tag of
Left tagL -> do
maybeB <- eraseClockSN initialTime sn1 -< (time, tagL, maybeA)
returnA -< Left <$> ((time, , ) <$> outTag proxy1 tagL <*> maybeB)
Right tagR -> do
returnA -< Right <$> (time, ) <$> inTag proxy2 tagR
maybeC <- mapMaybeS $ eraseClockResBuf (outProxy proxy1) (inProxy proxy2) initialTime resBuf -< resBufIn
case tag of
Left _ -> do
returnA -< Nothing
Right tagR -> do
eraseClockSN initialTime sn2 -< (time, tagR, join maybeC)
eraseClockSN initialTime (Parallel snL snR) = proc (time, tag, maybeA) -> do
case tag of
Left tagL -> eraseClockSN initialTime snL -< (time, tagL, maybeA)
Right tagR -> eraseClockSN initialTime snR -< (time, tagR, maybeA)
eraseClockResBuf
:: ( Monad m
, Clock m cl1, Clock m cl2
, Time cl1 ~ Time cl2
)
=> ClockProxy cl1 -> ClockProxy cl2 -> Time cl1
-> ResBuf m cl1 cl2 a b
-> MSF m (Either (Time cl1, Tag cl1, a) (Time cl2, Tag cl2)) (Maybe b)
eraseClockResBuf proxy1 proxy2 initialTime resBuf0 = feedback resBuf0 $ proc (input, resBuf) -> do
case input of
Left (time1, tag1, a) -> do
timeInfo1 <- genTimeInfo proxy1 initialTime -< (time1, tag1)
resBuf' <- arrM (uncurry $ uncurry put) -< ((resBuf, timeInfo1), a)
returnA -< (Nothing, resBuf')
Right (time2, tag2) -> do
timeInfo2 <- genTimeInfo proxy2 initialTime -< (time2, tag2)
(b, resBuf') <- arrM (uncurry get) -< (resBuf, timeInfo2)
returnA -< (Just b, resBuf')