{-# 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 :: ClockProxy cl
-> Time cl -> ClSF m cl a b -> MSF m (Time cl, Tag cl, a) b
eraseClockClSF ClockProxy cl
proxy Time cl
initialTime ClSF m cl a b
clsf = proc (Time cl
time, Tag cl
tag, a
a) -> do
TimeInfo cl
timeInfo <- ClockProxy cl -> Time cl -> MSF m (Time cl, Tag cl) (TimeInfo cl)
forall (m :: Type -> Type) cl.
(Monad m, Clock m cl) =>
ClockProxy cl -> Time cl -> MSF m (Time cl, Tag cl) (TimeInfo cl)
genTimeInfo ClockProxy cl
proxy Time cl
initialTime -< (Time cl
time, Tag cl
tag)
ClSF m cl a b -> MSF m (TimeInfo cl, a) b
forall (m :: Type -> Type) r a b.
Monad m =>
MSF (ReaderT r m) a b -> MSF m (r, a) b
runReaderS ClSF m cl a b
clsf -< (TimeInfo cl
timeInfo, a
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 :: Time cl
-> SN m cl a b -> MSF m (Time cl, Tag cl, Maybe a) (Maybe b)
eraseClockSN Time cl
initialTime sn :: SN m cl a b
sn@(Synchronous ClSF m cl a b
clsf) = proc (Time cl
time, Tag cl
tag, Just a
a) -> do
b
b <- ClockProxy cl
-> Time cl -> ClSF m cl a b -> MSF m (Time cl, Tag cl, a) b
forall (m :: Type -> Type) cl a b.
(Monad m, Clock m cl) =>
ClockProxy cl
-> Time cl -> ClSF m cl a b -> MSF m (Time cl, Tag cl, a) b
eraseClockClSF (SN m cl a b -> ClockProxy (Cl (SN m cl a b))
forall a. ToClockProxy a => a -> ClockProxy (Cl a)
toClockProxy SN m cl a b
sn) Time cl
initialTime ClSF m cl a b
clsf -< (Time cl
time, Tag cl
tag, a
a)
MSF m (Maybe b) (Maybe b)
forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA -< b -> Maybe b
forall a. a -> Maybe a
Just b
b
eraseClockSN Time cl
initialTime (Sequential SN m clab a b
sn1 ResamplingBuffer m (Out clab) (In clcd) b c
resBuf SN m clcd c b
sn2) =
let
proxy1 :: ClockProxy (Cl (SN m clab a b))
proxy1 = SN m clab a b -> ClockProxy (Cl (SN m clab a b))
forall a. ToClockProxy a => a -> ClockProxy (Cl a)
toClockProxy SN m clab a b
sn1
proxy2 :: ClockProxy (Cl (SN m clcd c b))
proxy2 = SN m clcd c b -> ClockProxy (Cl (SN m clcd c b))
forall a. ToClockProxy a => a -> ClockProxy (Cl a)
toClockProxy SN m clcd c b
sn2
in proc (Time cl
time, Tag cl
tag, Maybe a
maybeA) -> do
Maybe
(Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd)))
resBufIn <- case Tag cl
tag of
Left tagL -> do
Maybe b
maybeB <- Time clab
-> SN m clab a b -> MSF m (Time clab, Tag clab, Maybe a) (Maybe b)
forall (m :: Type -> Type) cl a b.
(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 Time cl
Time clab
initialTime SN m clab a b
sn1 -< (Time cl
time, Tag clab
tagL, Maybe a
maybeA)
MSF
m
(Maybe
(Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd))))
(Maybe
(Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd))))
forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA -< (Time cl, Tag (Out clab), b)
-> Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd))
forall a b. a -> Either a b
Left ((Time cl, Tag (Out clab), b)
-> Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd)))
-> Maybe (Time cl, Tag (Out clab), b)
-> Maybe
(Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Time cl
time, , ) (Tag (Out clab) -> b -> (Time cl, Tag (Out clab), b))
-> Maybe (Tag (Out clab))
-> Maybe (b -> (Time cl, Tag (Out clab), b))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ClockProxy clab -> Tag clab -> Maybe (Tag (Out clab))
forall cl. ClockProxy cl -> Tag cl -> Maybe (Tag (Out cl))
outTag ClockProxy clab
ClockProxy (Cl (SN m clab a b))
proxy1 Tag clab
tagL Maybe (b -> (Time cl, Tag (Out clab), b))
-> Maybe b -> Maybe (Time cl, Tag (Out clab), b)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Maybe b
maybeB)
Right tagR -> do
MSF
m
(Maybe
(Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd))))
(Maybe
(Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd))))
forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA -< (Time cl, Tag (In clcd))
-> Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd))
forall a b. b -> Either a b
Right ((Time cl, Tag (In clcd))
-> Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd)))
-> (Tag (In clcd) -> (Time cl, Tag (In clcd)))
-> Tag (In clcd)
-> Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Time cl
time, ) (Tag (In clcd)
-> Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd)))
-> Maybe (Tag (In clcd))
-> Maybe
(Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ClockProxy clcd -> Tag clcd -> Maybe (Tag (In clcd))
forall cl. ClockProxy cl -> Tag cl -> Maybe (Tag (In cl))
inTag ClockProxy clcd
ClockProxy (Cl (SN m clcd c b))
proxy2 Tag clcd
tagR
Maybe (Maybe c)
maybeC <- MSF
m
(Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd)))
(Maybe c)
-> MSF
m
(Maybe
(Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd))))
(Maybe (Maybe c))
forall (m :: Type -> Type) a b.
Monad m =>
MSF m a b -> MSF m (Maybe a) (Maybe b)
mapMaybeS (MSF
m
(Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd)))
(Maybe c)
-> MSF
m
(Maybe
(Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd))))
(Maybe (Maybe c)))
-> MSF
m
(Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd)))
(Maybe c)
-> MSF
m
(Maybe
(Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd))))
(Maybe (Maybe c))
forall a b. (a -> b) -> a -> b
$ ClockProxy (Out clab)
-> ClockProxy (In clcd)
-> Time (Out clab)
-> ResamplingBuffer m (Out clab) (In clcd) b c
-> MSF
m
(Either
(Time (Out clab), Tag (Out clab), b)
(Time (In clcd), Tag (In clcd)))
(Maybe c)
forall (m :: Type -> Type) cl1 cl2 a b.
(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 (ClockProxy clab -> ClockProxy (Out clab)
forall cl. ClockProxy cl -> ClockProxy (Out cl)
outProxy ClockProxy clab
ClockProxy (Cl (SN m clab a b))
proxy1) (ClockProxy clcd -> ClockProxy (In clcd)
forall cl. ClockProxy cl -> ClockProxy (In cl)
inProxy ClockProxy clcd
ClockProxy (Cl (SN m clcd c b))
proxy2) Time cl
Time (Out clab)
initialTime ResamplingBuffer m (Out clab) (In clcd) b c
resBuf -< Maybe
(Either (Time cl, Tag (Out clab), b) (Time cl, Tag (In clcd)))
resBufIn
case Tag cl
tag of
Left _ -> do
MSF m (Maybe b) (Maybe b)
forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA -< Maybe b
forall a. Maybe a
Nothing
Right tagR -> do
Time clcd
-> SN m clcd c b -> MSF m (Time clcd, Tag clcd, Maybe c) (Maybe b)
forall (m :: Type -> Type) cl a b.
(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 Time cl
Time clcd
initialTime SN m clcd c b
sn2 -< (Time cl
time, Tag clcd
tagR, Maybe (Maybe c) -> Maybe c
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join Maybe (Maybe c)
maybeC)
eraseClockSN Time cl
initialTime (Parallel SN m cl1 a b
snL SN m cl2 a b
snR) = proc (Time cl
time, Tag cl
tag, Maybe a
maybeA) -> do
case Tag cl
tag of
Left tagL -> Time cl1
-> SN m cl1 a b -> MSF m (Time cl1, Tag cl1, Maybe a) (Maybe b)
forall (m :: Type -> Type) cl a b.
(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 Time cl
Time cl1
initialTime SN m cl1 a b
snL -< (Time cl
time, Tag cl1
tagL, Maybe a
maybeA)
Right tagR -> Time cl2
-> SN m cl2 a b -> MSF m (Time cl2, Tag cl2, Maybe a) (Maybe b)
forall (m :: Type -> Type) cl a b.
(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 Time cl
Time cl2
initialTime SN m cl2 a b
snR -< (Time cl
time, Tag cl2
tagR, Maybe a
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 :: 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 ClockProxy cl1
proxy1 ClockProxy cl2
proxy2 Time cl1
initialTime ResBuf m cl1 cl2 a b
resBuf0 = ResBuf m cl1 cl2 a b
-> MSF
m
(Either (Time cl2, Tag cl1, a) (Time cl2, Tag cl2),
ResBuf m cl1 cl2 a b)
(Maybe b, ResBuf m cl1 cl2 a b)
-> MSF
m (Either (Time cl2, Tag cl1, a) (Time cl2, Tag cl2)) (Maybe b)
forall (m :: Type -> Type) c a b.
Monad m =>
c -> MSF m (a, c) (b, c) -> MSF m a b
feedback ResBuf m cl1 cl2 a b
resBuf0 (MSF
m
(Either (Time cl2, Tag cl1, a) (Time cl2, Tag cl2),
ResBuf m cl1 cl2 a b)
(Maybe b, ResBuf m cl1 cl2 a b)
-> MSF
m (Either (Time cl2, Tag cl1, a) (Time cl2, Tag cl2)) (Maybe b))
-> MSF
m
(Either (Time cl2, Tag cl1, a) (Time cl2, Tag cl2),
ResBuf m cl1 cl2 a b)
(Maybe b, ResBuf m cl1 cl2 a b)
-> MSF
m (Either (Time cl2, Tag cl1, a) (Time cl2, Tag cl2)) (Maybe b)
forall a b. (a -> b) -> a -> b
$ proc (Either (Time cl2, Tag cl1, a) (Time cl2, Tag cl2)
input, ResBuf m cl1 cl2 a b
resBuf) -> do
case Either (Time cl2, Tag cl1, a) (Time cl2, Tag cl2)
input of
Left (Time cl2
time1, Tag cl1
tag1, a
a) -> do
TimeInfo cl1
timeInfo1 <- ClockProxy cl1
-> Time cl1 -> MSF m (Time cl1, Tag cl1) (TimeInfo cl1)
forall (m :: Type -> Type) cl.
(Monad m, Clock m cl) =>
ClockProxy cl -> Time cl -> MSF m (Time cl, Tag cl) (TimeInfo cl)
genTimeInfo ClockProxy cl1
proxy1 Time cl1
initialTime -< (Time cl2
time1, Tag cl1
tag1)
ResBuf m cl1 cl2 a b
resBuf' <- (((ResBuf m cl1 cl2 a b, TimeInfo cl1), a)
-> m (ResBuf m cl1 cl2 a b))
-> MSF
m ((ResBuf m cl1 cl2 a b, TimeInfo cl1), a) (ResBuf m cl1 cl2 a b)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> MSF m a b
arrM (((ResBuf m cl1 cl2 a b, TimeInfo cl1)
-> a -> m (ResBuf m cl1 cl2 a b))
-> ((ResBuf m cl1 cl2 a b, TimeInfo cl1), a)
-> m (ResBuf m cl1 cl2 a b)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (((ResBuf m cl1 cl2 a b, TimeInfo cl1)
-> a -> m (ResBuf m cl1 cl2 a b))
-> ((ResBuf m cl1 cl2 a b, TimeInfo cl1), a)
-> m (ResBuf m cl1 cl2 a b))
-> ((ResBuf m cl1 cl2 a b, TimeInfo cl1)
-> a -> m (ResBuf m cl1 cl2 a b))
-> ((ResBuf m cl1 cl2 a b, TimeInfo cl1), a)
-> m (ResBuf m cl1 cl2 a b)
forall a b. (a -> b) -> a -> b
$ (ResBuf m cl1 cl2 a b
-> TimeInfo cl1 -> a -> m (ResBuf m cl1 cl2 a b))
-> (ResBuf m cl1 cl2 a b, TimeInfo cl1)
-> a
-> m (ResBuf m cl1 cl2 a b)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ResBuf m cl1 cl2 a b
-> TimeInfo cl1 -> a -> m (ResBuf m cl1 cl2 a b)
forall (m :: Type -> Type) cla clb a b.
ResamplingBuffer m cla clb a b
-> TimeInfo cla -> a -> m (ResamplingBuffer m cla clb a b)
put) -< ((ResBuf m cl1 cl2 a b
resBuf, TimeInfo cl1
timeInfo1), a
a)
MSF
m (Maybe b, ResBuf m cl1 cl2 a b) (Maybe b, ResBuf m cl1 cl2 a b)
forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA -< (Maybe b
forall a. Maybe a
Nothing, ResBuf m cl1 cl2 a b
resBuf')
Right (Time cl2
time2, Tag cl2
tag2) -> do
TimeInfo cl2
timeInfo2 <- ClockProxy cl2
-> Time cl2 -> MSF m (Time cl2, Tag cl2) (TimeInfo cl2)
forall (m :: Type -> Type) cl.
(Monad m, Clock m cl) =>
ClockProxy cl -> Time cl -> MSF m (Time cl, Tag cl) (TimeInfo cl)
genTimeInfo ClockProxy cl2
proxy2 Time cl1
Time cl2
initialTime -< (Time cl2
time2, Tag cl2
tag2)
(b
b, ResBuf m cl1 cl2 a b
resBuf') <- ((ResBuf m cl1 cl2 a b, TimeInfo cl2)
-> m (b, ResBuf m cl1 cl2 a b))
-> MSF
m (ResBuf m cl1 cl2 a b, TimeInfo cl2) (b, ResBuf m cl1 cl2 a b)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> MSF m a b
arrM ((ResBuf m cl1 cl2 a b
-> TimeInfo cl2 -> m (b, ResBuf m cl1 cl2 a b))
-> (ResBuf m cl1 cl2 a b, TimeInfo cl2)
-> m (b, ResBuf m cl1 cl2 a b)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ResBuf m cl1 cl2 a b -> TimeInfo cl2 -> m (b, ResBuf m cl1 cl2 a b)
forall (m :: Type -> Type) cla clb a b.
ResamplingBuffer m cla clb a b
-> TimeInfo clb -> m (b, ResamplingBuffer m cla clb a b)
get) -< (ResBuf m cl1 cl2 a b
resBuf, TimeInfo cl2
timeInfo2)
MSF
m (Maybe b, ResBuf m cl1 cl2 a b) (Maybe b, ResBuf m cl1 cl2 a b)
forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA -< (b -> Maybe b
forall a. a -> Maybe a
Just b
b, ResBuf m cl1 cl2 a b
resBuf')