diff --git a/rhine/src/FRP/Rhine/Rhine/Free.hs b/rhine/src/FRP/Rhine/Rhine/Free.hs index 81c444c8..b8a813bc 100644 --- a/rhine/src/FRP/Rhine/Rhine/Free.hs +++ b/rhine/src/FRP/Rhine/Rhine/Free.hs @@ -15,9 +15,24 @@ import FRP.Rhine.SN.Free data Rhine m td cls a b = Rhine { clocks :: Clocks m td cls - , sn :: FreeSN m cls a b + , erasedSN :: MSF (ReaderT (Tick cls) m) a b } +rhine :: Monad m => Clocks m td cls -> FreeSN m cls a b -> Rhine m td cls a b +rhine clocks sn = Rhine + { clocks + , erasedSN = eraseClockFreeSN sn + } + +eraseClockRhine :: (Monad m, MonadSchedule m) => Rhine m td cls a b -> MSF m a b +eraseClockRhine Rhine {clocks, erasedSN} = proc a -> do + ti <- runClocks clocks -< () + runReaderS erasedSN -< (ti, a) + +flow :: (Monad m, MonadSchedule m) => Rhine m td cls () () -> m () +flow = reactimate . eraseClockRhine + +-- FIXME the following haven't been adapted to the new change yet instance Profunctor (Rhine m td cls) where dimap f g Rhine {clocks, sn} = Rhine diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs index c07bd9ba..36b6bb64 100644 --- a/rhine/src/FRP/Rhine/SN/Free.hs +++ b/rhine/src/FRP/Rhine/SN/Free.hs @@ -26,9 +26,13 @@ module FRP.Rhine.SN.Free ( feedbackSN, always, currently, - Clocks (..), - NP (..), - NS (..), + Rhine(..), + eraseClockRhine, + rhine, + flow, + Clocks(..), + NP(..), + NS(..), (.:.), cnil, (^>>>), @@ -325,66 +329,18 @@ data OrderedPositions cl1 cl2 cls where newtype Tick cls = Tick {getTick :: NS TimeInfo cls} -type family Append (cls1 :: [Type]) (cls2 :: [Type]) :: [Type] where - Append '[] cls = cls - Append (cl ': cls1) cls2 = cl ': Append cls1 cls2 - -appendPosition :: Clocks m td cls2 -> Position cl cls1 -> Position cl (Append cls1 cls2) -appendPosition _ (Z Refl) = Z Refl -appendPosition clocks (S pos) = S $ appendPosition clocks pos - -prependPosition :: Clocks m td cls1 -> Position cl cls2 -> Position cl (Append cls1 cls2) -prependPosition Clocks {getClocks = Nil} pos = pos -prependPosition Clocks {getClocks = _ :* getClocks} pos = S $ prependPosition Clocks {getClocks} pos - -appendPositions :: Clocks m td cls2 -> OrderedPositions clA clB cls1 -> OrderedPositions clA clB (Append cls1 cls2) -appendPositions clocks (OPHere pos) = OPHere $ appendPosition clocks pos -appendPositions clocks (OPThere positions) = OPThere $ appendPositions clocks positions - -appendClocks :: Clocks m td cls1 -> Clocks m td cls2 -> Clocks m td (Append cls1 cls2) -appendClocks Clocks {getClocks = Nil} clocks = clocks -appendClocks Clocks {getClocks = cl :* cls} clocks = - let Clocks {getClocks} = appendClocks Clocks {getClocks = cls} clocks - in Clocks {getClocks = cl :* getClocks} - -addClockSNComponent :: SNComponent m cls a b -> SNComponent m (cl ': cls) a b -addClockSNComponent (Synchronous position clsf) = Synchronous (S position) clsf -addClockSNComponent (Resampling positions clsf) = Resampling (OPThere positions) clsf -addClockSNComponent (Feedback posA posB resbuf sn) = Feedback (S posA) (S posB) resbuf (addClockSN sn) -addClockSNComponent (Always msf) = Always msf - -appendClockSNComponent :: Clocks m td cls2 -> SNComponent m cls1 a b -> SNComponent m (Append cls1 cls2) a b -appendClockSNComponent clocks (Synchronous position clsf) = Synchronous (appendPosition clocks position) clsf -appendClockSNComponent clocks (Resampling positions resbuf) = Resampling (appendPositions clocks positions) resbuf -appendClockSNComponent clocks (Feedback posA posB resbuf sn) = - Feedback - (appendPosition clocks posA) - (appendPosition clocks posB) - resbuf - (appendClocksSN clocks sn) -appendClockSNComponent _ (Always msf) = Always msf - -addClockSN :: FreeSN m cls a b -> FreeSN m (cl ': cls) a b -addClockSN = FreeSN . foldNatFree2 (liftFree2 . addClockSNComponent) . getFreeSN - -prependClocksSN :: Clocks m td cls1 -> FreeSN m cls2 a b -> FreeSN m (Append cls1 cls2) a b -prependClocksSN Clocks {getClocks = Nil} = id -prependClocksSN Clocks {getClocks = _ :* getClocks} = addClockSN . prependClocksSN Clocks {getClocks} - -appendClocksSN :: Clocks m td cls2 -> FreeSN m cls1 a b -> FreeSN m (Append cls1 cls2) a b -appendClocksSN clocks = FreeSN . foldNatFree2 (liftFree2 . appendClockSNComponent clocks) . getFreeSN - -orderedPositionsInAppend :: - Clocks m td cls1 -> - Clocks m td cls2 -> - Position cl1 cls1 -> - Position cl2 cls2 -> - OrderedPositions cl1 cl2 (Append cls1 cls2) -orderedPositionsInAppend Clocks {getClocks = _ :* getClocks} _ (Z Refl) pos2 = OPHere $ prependPosition Clocks {getClocks} pos2 -orderedPositionsInAppend Clocks {getClocks = _ :* getClocks} cls2 (S pos1) pos2 = OPThere $ orderedPositionsInAppend Clocks {getClocks} cls2 pos1 pos2 --- I think that there are no other valid patterns. GHC 9.4 is unsure about that because of https://gitlab.haskell.org/ghc/ghc/-/issues/22684. --- Revisit with GHC 9.6. -orderedPositionsInAppend Clocks {getClocks = Nil} _ _ _ = error "orderedPositionsInAppend: Internal error. Please report as a rhine bug." +data Rhine m td cls a b = Rhine + { clocks :: Clocks m td cls + , sn :: FreeSN m cls a b + } + +eraseClockRhine :: (Monad m, MonadSchedule m) => Rhine m td cls a b -> MSF m a b +eraseClockRhine Rhine {clocks, sn} = proc a -> do + ti <- runClocks clocks -< () + runReaderS (eraseClockFreeSN sn) -< (ti, a) + +flow :: (Monad m, MonadSchedule m) => Rhine m td cls () () -> m () +flow = reactimate . eraseClockRhine runClocks :: (Monad m, MonadSchedule m) => Clocks m td cls -> MSF m () (Tick cls) runClocks cls = performOnFirstSample $ scheduleMSFs <$> getRunningClocks (getClocks cls)