CHERRY erase SN in step to Rhine, but Rhine still isn't an Arrow

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

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)