From 776fb8523ab58b5444e3602f396954e6b914b1ca Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Mon, 10 Jun 2024 15:18:49 +0200
Subject: [PATCH 1/9] Replace SN by functions

---
 .../FRP/Rhine/Reactimation/ClockErasure.hs    | 63 ++++++++++++-------
 .../src/FRP/Rhine/Reactimation/Combinators.hs | 14 +++--
 rhine/src/FRP/Rhine/SN/Combinators.hs         | 56 +++++------------
 rhine/src/FRP/Rhine/Type.hs                   |  5 +-
 4 files changed, 65 insertions(+), 73 deletions(-)

diff --git a/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs b/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs
index 344e197e..842a64a1 100644
--- a/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs
+++ b/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs
@@ -2,6 +2,8 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 {- | Translate clocked signal processing components to stream functions without explicit clock types.
 
@@ -23,7 +25,7 @@ import FRP.Rhine.Clock
 import FRP.Rhine.Clock.Proxy
 import FRP.Rhine.Clock.Util
 import FRP.Rhine.ResamplingBuffer
-import FRP.Rhine.SN
+import FRP.Rhine.Schedule (In, Out, SequentialClock)
 
 {- | Run a clocked signal function as an automaton,
    accepting the timestamps and tags as explicit inputs.
@@ -39,23 +41,22 @@ eraseClockClSF proxy initialTime clsf = proc (time, tag, a) -> do
   runReaderS clsf -< (timeInfo, a)
 {-# INLINE eraseClockClSF #-}
 
-{- | Run a signal network as an automaton.
+-- Andras' trick: Encode in the domain
+newtype SN m cl a b = SN { getSN :: Reader (Time cl) (Automaton m (Time cl, Tag cl, Maybe a) (Maybe b)) }
+
+instance GetClockProxy cl => ToClockProxy (SN m cl a b) where
+  type Cl (SN m cl a b) = cl
+
+eraseClockSN :: Time cl -> SN m cl a b -> (Automaton m (Time cl, Tag cl, Maybe a) (Maybe b))
+eraseClockSN time = flip runReader time . getSN
 
-   Depending on the incoming clock,
-   input data may need to be provided,
-   and depending on the outgoing clock,
-   output data may be generated.
-   There are thus possible invalid inputs,
-   which 'eraseClockSN' does not gracefully handle.
--}
-eraseClockSN ::
-  (Monad m, Clock m cl, GetClockProxy cl) =>
-  Time cl ->
-  SN m cl a b ->
-  Automaton m (Time cl, Tag cl, Maybe a) (Maybe b)
 -- A synchronous signal network is run by erasing the clock from the clocked signal function.
-eraseClockSN initialTime sn@(Synchronous clsf) = proc (time, tag, Just a) -> do
-  b <- eraseClockClSF (toClockProxy sn) initialTime clsf -< (time, tag, a)
+synchronous :: forall cl m a b .     ( cl ~ In cl, cl ~ Out cl, Monad m, Clock m cl, GetClockProxy cl) =>
+    ClSF m cl a b ->
+    SN   m cl a b
+
+synchronous clsf = SN $ reader $ \initialTime -> proc (time, tag, Just a) -> do
+  b <- eraseClockClSF (getClockProxy @cl) initialTime clsf -< (time, tag, a)
   returnA -< Just b
 
 -- A sequentially composed signal network may either be triggered in its first component,
@@ -63,7 +64,19 @@ eraseClockSN initialTime sn@(Synchronous clsf) = proc (time, tag, Just a) -> do
 -- the resampling buffer (which connects the two components) may be triggered,
 -- but only if the outgoing clock of the first component ticks,
 -- or the incoming clock of the second component ticks.
-eraseClockSN initialTime (Sequential sn1 resBuf sn2) =
+sequential ::     ( Clock m clab, Clock m clcd
+    , Clock m (Out clab), Clock m (Out clcd)
+    , Clock m (In  clab), Clock m (In  clcd)
+    , GetClockProxy clab, GetClockProxy clcd
+    , Time clab ~ Time clcd
+    , Time clab ~ Time (Out clab)
+    , Time clcd ~ Time (In  clcd), Monad m
+    ) =>
+    SN               m      clab            a b     ->
+    ResamplingBuffer m (Out clab) (In clcd)   b c   ->
+    SN               m                clcd      c d ->
+    SN m (SequentialClock   clab      clcd) a     d
+sequential sn1 resBuf sn2  = SN $ reader $ \initialTime ->
   let
     proxy1 = toClockProxy sn1
     proxy2 = toClockProxy sn2
@@ -81,25 +94,29 @@ eraseClockSN initialTime (Sequential sn1 resBuf sn2) =
           returnA -< Nothing
         Right tagR -> do
           eraseClockSN initialTime sn2 -< (time, tagR, join maybeC)
-eraseClockSN initialTime (Parallel snL snR) = proc (time, tag, maybeA) -> do
+
+parallel snL snR = SN $ reader$ \initialTime -> proc (time, tag, maybeA) -> do
   case tag of
     Left tagL -> eraseClockSN initialTime snL -< (time, tagL, maybeA)
     Right tagR -> eraseClockSN initialTime snR -< (time, tagR, maybeA)
-eraseClockSN initialTime (Postcompose sn clsf) =
+
+postcompose sn clsf = SN $ reader $ \initialTime  ->
   let
     proxy = toClockProxy sn
    in
     proc input@(time, tag, _) -> do
       bMaybe <- eraseClockSN initialTime sn -< input
       mapMaybeS $ eraseClockClSF (outProxy proxy) initialTime clsf -< (time,,) <$> outTag proxy tag <*> bMaybe
-eraseClockSN initialTime (Precompose clsf sn) =
+
+precompose clsf sn = SN $ reader $ \initialTime ->
   let
     proxy = toClockProxy sn
    in
     proc (time, tag, aMaybe) -> do
       bMaybe <- mapMaybeS $ eraseClockClSF (inProxy proxy) initialTime clsf -< (time,,) <$> inTag proxy tag <*> aMaybe
       eraseClockSN initialTime sn -< (time, tag, bMaybe)
-eraseClockSN initialTime (Feedback ResamplingBuffer {buffer, put, get} sn) =
+
+feedbackSN ResamplingBuffer {buffer, put, get} sn = SN $ reader $ \initialTime  ->
   let
     proxy = toClockProxy sn
    in
@@ -119,7 +136,7 @@ eraseClockSN initialTime (Feedback ResamplingBuffer {buffer, put, get} sn) =
           timeInfo <- genTimeInfo (outProxy proxy) initialTime -< (time, tagOut)
           buf'' <- arrM $ uncurry $ uncurry put -< ((timeInfo, d), buf')
           returnA -< (Just b, buf'')
-eraseClockSN initialTime (FirstResampling sn buf) =
+firstResampling sn buf = SN $ reader $ \initialTime ->
   let
     proxy = toClockProxy sn
    in
@@ -132,7 +149,7 @@ eraseClockSN initialTime (FirstResampling sn buf) =
           _ -> Nothing
       dMaybe <- mapMaybeS $ eraseClockResBuf (inProxy proxy) (outProxy proxy) initialTime buf -< resBufInput
       returnA -< (,) <$> bMaybe <*> join dMaybe
-{-# INLINE eraseClockSN #-}
+{-# INLINE firstResampling #-}
 
 {- | Translate a resampling buffer into an automaton.
 
diff --git a/rhine/src/FRP/Rhine/Reactimation/Combinators.hs b/rhine/src/FRP/Rhine/Reactimation/Combinators.hs
index c0acc54f..22605a46 100644
--- a/rhine/src/FRP/Rhine/Reactimation/Combinators.hs
+++ b/rhine/src/FRP/Rhine/Reactimation/Combinators.hs
@@ -22,10 +22,10 @@ import FRP.Rhine.ClSF.Core
 import FRP.Rhine.Clock
 import FRP.Rhine.Clock.Proxy
 import FRP.Rhine.ResamplingBuffer
-import FRP.Rhine.SN
 import FRP.Rhine.SN.Combinators
 import FRP.Rhine.Schedule
 import FRP.Rhine.Type
+import FRP.Rhine.Reactimation.ClockErasure
 
 -- * Combinators and syntactic sugar for high-level composition of signal networks.
 
@@ -39,11 +39,14 @@ infix 5 @@
 (@@) ::
   ( cl ~ In cl
   , cl ~ Out cl
+  , Monad m
+  , Clock m cl
+  , GetClockProxy cl
   ) =>
   ClSF  m cl a b ->
           cl     ->
   Rhine m cl a b
-(@@) = Rhine . Synchronous
+(@@) = Rhine . synchronous
 {-# INLINE (@@) #-}
 
 {- | A purely syntactical convenience construction
@@ -82,6 +85,7 @@ infixr 1 -->
 (-->) ::
   ( Clock m cl1
   , Clock m cl2
+  , Monad m
   , Time cl1 ~ Time cl2
   , Time (Out cl1) ~ Time cl1
   , Time (In  cl2) ~ Time cl2
@@ -94,7 +98,7 @@ infixr 1 -->
   Rhine m cl2 b c ->
   Rhine m (SequentialClock cl1 cl2) a c
 RhineAndResamplingBuffer (Rhine sn1 cl1) rb --> (Rhine sn2 cl2) =
-  Rhine (Sequential sn1 rb sn2) (SequentialClock cl1 cl2)
+  Rhine (sequential sn1 rb sn2) (SequentialClock cl1 cl2)
 
 {- | The combinators for parallel composition allow for the following syntax:
 
@@ -177,7 +181,7 @@ f ^>>@ Rhine sn cl = Rhine (f ^>>> sn) cl
 
 -- | Postcompose a 'Rhine' with a 'ClSF'.
 (@>-^) ::
-  ( Clock m (Out cl)
+  ( Clock m (Out cl), GetClockProxy cl, Monad m
   , Time cl ~ Time (Out cl)
   ) =>
   Rhine m      cl  a b   ->
@@ -187,7 +191,7 @@ Rhine sn cl @>-^ clsf = Rhine (sn >--^ clsf) cl
 
 -- | Precompose a 'Rhine' with a 'ClSF'.
 (^->@) ::
-  ( Clock m (In cl)
+  ( Clock m (In cl), GetClockProxy cl, Monad m
   , Time cl ~ Time (In cl)
   ) =>
   ClSF  m (In cl) a b   ->
diff --git a/rhine/src/FRP/Rhine/SN/Combinators.hs b/rhine/src/FRP/Rhine/SN/Combinators.hs
index c78e9bd7..bd06eca4 100644
--- a/rhine/src/FRP/Rhine/SN/Combinators.hs
+++ b/rhine/src/FRP/Rhine/SN/Combinators.hs
@@ -11,8 +11,9 @@ import FRP.Rhine.ClSF.Core
 import FRP.Rhine.Clock
 import FRP.Rhine.Clock.Proxy
 import FRP.Rhine.ResamplingBuffer.Util
-import FRP.Rhine.SN
 import FRP.Rhine.Schedule
+import FRP.Rhine.Reactimation.ClockErasure
+import Data.Functor ((<&>))
 
 {- FOURMOLU_DISABLE -}
 -- | Postcompose a signal network with a pure function.
@@ -21,13 +22,7 @@ import FRP.Rhine.Schedule
   => SN m cl a b
   ->          (b -> c)
   -> SN m cl a      c
-Synchronous clsf      >>>^ f = Synchronous $ clsf >>^ f
-Sequential sn1 rb sn2 >>>^ f = Sequential sn1 rb     $ sn2 >>>^ f
-Parallel   sn1    sn2 >>>^ f = Parallel  (sn1 >>>^ f) (sn2 >>>^ f)
-Postcompose sn clsf >>>^ f = Postcompose sn $ clsf >>^ f
-Precompose clsf sn >>>^ f = Precompose clsf $ sn >>>^ f
-Feedback buf sn >>>^ f = Feedback buf $ sn >>>^ first f
-firstResampling@(FirstResampling _ _) >>>^ f = Postcompose firstResampling $ arr f
+SN {getSN} >>>^ f = SN $ getSN <&> (>>> arr (fmap f))
 
 -- | Precompose a signal network with a pure function.
 (^>>>)
@@ -35,33 +30,28 @@ firstResampling@(FirstResampling _ _) >>>^ f = Postcompose firstResampling $ arr
   =>        (a -> b)
   -> SN m cl      b c
   -> SN m cl a      c
-f ^>>> Synchronous clsf      = Synchronous $ f ^>> clsf
-f ^>>> Sequential sn1 rb sn2 = Sequential (f ^>>> sn1) rb      sn2
-f ^>>> Parallel   sn1    sn2 = Parallel   (f ^>>> sn1) (f ^>>> sn2)
-f ^>>> Postcompose sn clsf = Postcompose (f ^>>> sn) clsf
-f ^>>> Precompose clsf sn = Precompose (f ^>> clsf) sn
-f ^>>> Feedback buf sn = Feedback buf $ first f ^>>> sn
-f ^>>> firstResampling@(FirstResampling _ _) = Precompose (arr f) firstResampling
+f ^>>> SN {getSN} = SN $ getSN <&> (arr (fmap (fmap f)) >>>)
 
 -- | Postcompose a signal network with a 'ClSF'.
 (>--^)
-  :: ( Clock m (Out cl)
+  :: ( GetClockProxy cl , Clock m (Out cl)
      , Time cl ~ Time (Out cl)
+     , Monad m
      )
   => SN    m      cl  a b
   -> ClSF  m (Out cl)   b c
   -> SN    m      cl  a   c
-(>--^) = Postcompose
+(>--^) = postcompose
 
 -- | Precompose a signal network with a 'ClSF'.
 (^-->)
-  :: ( Clock m (In cl)
+  :: ( Clock m (In cl), GetClockProxy cl, Monad m
      , Time cl ~ Time (In cl)
      )
   => ClSF m (In cl) a b
   -> SN   m     cl    b c
   -> SN   m     cl  a   c
-(^-->) = Precompose
+(^-->) = precompose
 
 -- | Compose two signal networks on the same clock in data-parallel.
 --   At one tick of @cl@, both networks are stepped.
@@ -70,28 +60,10 @@ f ^>>> firstResampling@(FirstResampling _ _) = Precompose (arr f) firstResamplin
   => SN m cl  a      b
   -> SN m cl     c      d
   -> SN m cl (a, c) (b, d)
-Synchronous clsf1 **** Synchronous clsf2 = Synchronous $ clsf1 *** clsf2
-Sequential sn11 rb1 sn12 **** Sequential sn21 rb2 sn22 = Sequential sn1 rb sn2
-  where
-    sn1 = sn11 **** sn21
-    sn2 = sn12 **** sn22
-    rb = rb1 *-* rb2
-Parallel sn11 sn12 **** Parallel sn21 sn22 =
-  Parallel (sn11 **** sn21) (sn12 **** sn22)
-Precompose clsf sn1 **** sn2 = Precompose (first clsf) $ sn1 **** sn2
-sn1 **** Precompose clsf sn2 = Precompose (second clsf) $ sn1 **** sn2
-Postcompose sn1 clsf **** sn2 = Postcompose (sn1 **** sn2) (first clsf)
-sn1 **** Postcompose sn2 clsf = Postcompose (sn1 **** sn2) (second clsf)
-Feedback buf sn1 **** sn2 = Feedback buf $ (\((a, c), c1) -> ((a, c1), c)) ^>>> (sn1 **** sn2) >>>^ (\((b, d1), d) -> ((b, d), d1))
-sn1 **** Feedback buf sn2 = Feedback buf $ (\((a, c), c1) -> (a, (c, c1))) ^>>> (sn1 **** sn2) >>>^ (\(b, (d, d1)) -> ((b, d), d1))
-FirstResampling sn1 buf **** sn2 = (\((a1, c1), c) -> ((a1, c), c1)) ^>>> FirstResampling (sn1 **** sn2) buf >>>^ (\((b1, d), d1) -> ((b1, d1), d))
-sn1 **** FirstResampling sn2 buf = (\(a, (a1, c1)) -> ((a, a1), c1)) ^>>> FirstResampling (sn1 **** sn2) buf >>>^ (\((b, b1), d1) -> (b, (b1, d1)))
--- Note that the patterns above are the only ones that can occur.
--- This is ensured by the clock constraints in the SF constructors.
-Synchronous _ **** Parallel _ _ = error "Impossible pattern: Synchronous _ **** Parallel _ _"
-Parallel _ _ **** Synchronous _ = error "Impossible pattern: Parallel _ _ **** Synchronous _"
-Synchronous _ **** Sequential {} = error "Impossible pattern: Synchronous _ **** Sequential {}"
-Sequential {} **** Synchronous _ = error "Impossible pattern: Sequential {} **** Synchronous _"
+SN sn1 **** SN sn2 = SN $ do
+  sn1' <- sn1
+  sn2' <- sn2
+  pure $ arr (\(time, tag, mac) -> ((time, tag, fst <$> mac), (time, tag, snd <$> mac))) >>> (sn1' *** sn2') >>> arr (\(mb, md) -> (,) <$> mb <*> md)
 
 -- | Compose two signal networks on different clocks in clock-parallel.
 --   At one tick of @ParClock cl1 cl2@, one of the networks is stepped,
@@ -109,7 +81,7 @@ Sequential {} **** Synchronous _ = error "Impossible pattern: Sequential {} ****
   => SN m             clL      a b
   -> SN m                 clR  a b
   -> SN m (ParClock clL clR) a b
-(||||) = Parallel
+(||||) = parallel
 
 -- | Compose two signal networks on different clocks in clock-parallel.
 --   At one tick of @ParClock cl1 cl2@, one of the networks is stepped,
diff --git a/rhine/src/FRP/Rhine/Type.hs b/rhine/src/FRP/Rhine/Type.hs
index 291a02c4..c7b7b3e1 100644
--- a/rhine/src/FRP/Rhine/Type.hs
+++ b/rhine/src/FRP/Rhine/Type.hs
@@ -18,7 +18,6 @@ import FRP.Rhine.Clock
 import FRP.Rhine.Clock.Proxy
 import FRP.Rhine.Reactimation.ClockErasure
 import FRP.Rhine.ResamplingBuffer (ResamplingBuffer)
-import FRP.Rhine.SN
 import FRP.Rhine.Schedule (In, Out)
 
 {- |
@@ -70,14 +69,14 @@ feedbackRhine ::
   ( Clock m (In cl)
   , Clock m (Out cl)
   , Time (In cl) ~ Time cl
-  , Time (Out cl) ~ Time cl
+  , Time (Out cl) ~ Time cl, GetClockProxy cl, Monad m
   ) =>
   ResamplingBuffer m (Out cl) (In cl) d c ->
   Rhine m cl (a, c) (b, d) ->
   Rhine m cl a b
 feedbackRhine buf Rhine {..} =
   Rhine
-    { sn = Feedback buf sn
+    { sn = feedbackSN buf sn
     , clock
     }
 {-# INLINE feedbackRhine #-}

From cf8b942ad9275fd1041b545590bbea256e4e3d09 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Mon, 10 Jun 2024 15:48:31 +0200
Subject: [PATCH 2/9] Inlines

---
 rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs b/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs
index 842a64a1..0bc2ba51 100644
--- a/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs
+++ b/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs
@@ -49,6 +49,7 @@ instance GetClockProxy cl => ToClockProxy (SN m cl a b) where
 
 eraseClockSN :: Time cl -> SN m cl a b -> (Automaton m (Time cl, Tag cl, Maybe a) (Maybe b))
 eraseClockSN time = flip runReader time . getSN
+{-# INLINE eraseClockSN #-}
 
 -- A synchronous signal network is run by erasing the clock from the clocked signal function.
 synchronous :: forall cl m a b .     ( cl ~ In cl, cl ~ Out cl, Monad m, Clock m cl, GetClockProxy cl) =>
@@ -58,6 +59,7 @@ synchronous :: forall cl m a b .     ( cl ~ In cl, cl ~ Out cl, Monad m, Clock m
 synchronous clsf = SN $ reader $ \initialTime -> proc (time, tag, Just a) -> do
   b <- eraseClockClSF (getClockProxy @cl) initialTime clsf -< (time, tag, a)
   returnA -< Just b
+{-# INLINE synchronous #-}
 
 -- A sequentially composed signal network may either be triggered in its first component,
 -- or its second component. In either case,
@@ -94,11 +96,13 @@ sequential sn1 resBuf sn2  = SN $ reader $ \initialTime ->
           returnA -< Nothing
         Right tagR -> do
           eraseClockSN initialTime sn2 -< (time, tagR, join maybeC)
+{-# INLINE sequential #-}
 
 parallel snL snR = SN $ reader$ \initialTime -> proc (time, tag, maybeA) -> do
   case tag of
     Left tagL -> eraseClockSN initialTime snL -< (time, tagL, maybeA)
     Right tagR -> eraseClockSN initialTime snR -< (time, tagR, maybeA)
+{-# INLINE parallel #-}
 
 postcompose sn clsf = SN $ reader $ \initialTime  ->
   let
@@ -107,6 +111,7 @@ postcompose sn clsf = SN $ reader $ \initialTime  ->
     proc input@(time, tag, _) -> do
       bMaybe <- eraseClockSN initialTime sn -< input
       mapMaybeS $ eraseClockClSF (outProxy proxy) initialTime clsf -< (time,,) <$> outTag proxy tag <*> bMaybe
+{-# INLINE postcompose #-}
 
 precompose clsf sn = SN $ reader $ \initialTime ->
   let
@@ -115,6 +120,7 @@ precompose clsf sn = SN $ reader $ \initialTime ->
     proc (time, tag, aMaybe) -> do
       bMaybe <- mapMaybeS $ eraseClockClSF (inProxy proxy) initialTime clsf -< (time,,) <$> inTag proxy tag <*> aMaybe
       eraseClockSN initialTime sn -< (time, tag, bMaybe)
+{-# INLINE precompose #-}
 
 feedbackSN ResamplingBuffer {buffer, put, get} sn = SN $ reader $ \initialTime  ->
   let
@@ -136,6 +142,8 @@ feedbackSN ResamplingBuffer {buffer, put, get} sn = SN $ reader $ \initialTime
           timeInfo <- genTimeInfo (outProxy proxy) initialTime -< (time, tagOut)
           buf'' <- arrM $ uncurry $ uncurry put -< ((timeInfo, d), buf')
           returnA -< (Just b, buf'')
+{-# INLINE feedbackSN #-}
+
 firstResampling sn buf = SN $ reader $ \initialTime ->
   let
     proxy = toClockProxy sn

From 2d9db231af468509df4ab9f68c07238edc03f4f3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Fri, 2 Aug 2024 16:43:05 +0200
Subject: [PATCH 3/9] Inline more library functions

---
 automaton/src/Data/Automaton.hs   | 9 +++++++++
 rhine/src/FRP/Rhine/Clock/Util.hs | 1 +
 2 files changed, 10 insertions(+)

diff --git a/automaton/src/Data/Automaton.hs b/automaton/src/Data/Automaton.hs
index f97ddfc6..5eff8869 100644
--- a/automaton/src/Data/Automaton.hs
+++ b/automaton/src/Data/Automaton.hs
@@ -257,6 +257,13 @@ instance (Monad m) => ArrowChoice (Automaton m) where
   right (Automaton (Stateless ma)) = Automaton $! Stateless $! ReaderT $! either (pure . Left) (fmap Right . runReaderT ma)
   {-# INLINE right #-}
 
+  f ||| g = f +++ g >>> arr untag
+    where
+      untag (Left x) = x
+      untag (Right y) = y
+
+  {-# INLINE (|||) #-}
+
 -- | Caution, this can make your program hang. Try to use 'feedback' or 'unfold' where possible, or combine 'loop' with 'delay'.
 instance (MonadFix m) => ArrowLoop (Automaton m) where
   loop (Automaton (Stateless ma)) = Automaton $! Stateless $! ReaderT (\b -> fst <$> mfix ((. snd) $ ($ b) $ curry $ runReaderT ma))
@@ -514,10 +521,12 @@ sumS = sumFrom zeroVector
 -- | Sum up all inputs so far, initialised at 0.
 sumN :: (Monad m, Num a) => Automaton m a a
 sumN = arr Sum >>> mappendS >>> arr getSum
+{-# INLINE sumN #-}
 
 -- | Count the natural numbers, beginning at 1.
 count :: (Num n, Monad m) => Automaton m a n
 count = feedback 0 $! arr (\(_, n) -> let n' = n + 1 in (n', n'))
+{-# INLINE count #-}
 
 -- | Remembers the last 'Just' value, defaulting to the given initialisation value.
 lastS :: (Monad m) => a -> Automaton m (Maybe a) a
diff --git a/rhine/src/FRP/Rhine/Clock/Util.hs b/rhine/src/FRP/Rhine/Clock/Util.hs
index 0f95f960..a7690049 100644
--- a/rhine/src/FRP/Rhine/Clock/Util.hs
+++ b/rhine/src/FRP/Rhine/Clock/Util.hs
@@ -35,3 +35,4 @@ genTimeInfo _ initialTime = proc (absolute, tag) -> do
         , sinceInit = absolute `diffTime` initialTime
         , ..
         }
+{-# INLINE genTimeInfo #-}

From ea53906f47d2c1d9b451a08fb09448aaf0cd2414 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Fri, 2 Aug 2024 16:42:44 +0200
Subject: [PATCH 4/9] WIP extend sum benchmark

---
 rhine/bench/Sum.hs  | 26 ++++++++++++++++++++++++--
 rhine/bench/Test.hs |  2 ++
 2 files changed, 26 insertions(+), 2 deletions(-)

diff --git a/rhine/bench/Sum.hs b/rhine/bench/Sum.hs
index 15de5120..59c407ef 100644
--- a/rhine/bench/Sum.hs
+++ b/rhine/bench/Sum.hs
@@ -14,6 +14,8 @@ import "base" Data.Void (absurd)
 
 import "criterion" Criterion.Main
 
+import "transformers" Control.Monad.Trans.Class (lift)
+
 import "automaton" Data.Stream as Stream (StreamT (..))
 import "automaton" Data.Stream.Optimized (OptimizedStreamT (Stateful))
 import "rhine" FRP.Rhine
@@ -25,9 +27,11 @@ benchmarks :: Benchmark
 benchmarks =
   bgroup
     "Sum"
-    [ bench "rhine" $ nf rhine nMax
+    [ bench "rhine embed" $ nf rhine nMax
     , bench "rhine flow" $ nf rhineFlow nMax
-    , bench "automaton" $ nf automaton nMax
+    , bench "automaton embed" $ nf automaton nMax
+    , bench "automatonNoEmbed" $ nf automatonNoEmbed nMax
+    , bench "automatonNoEmbedInlined" $ nf automatonNoEmbedInlined nMax
     , bench "direct" $ nf direct nMax
     , bench "direct monad" $ nf directM nMax
     ]
@@ -59,6 +63,24 @@ automaton n = sum $ runIdentity $ embed myCount $ replicate n ()
             , Stream.step = \s -> return $! Result (s + 1) s
             }
 
+automatonNoEmbed :: Int -> Int
+automatonNoEmbed n = either id absurd $ reactimate $ proc () -> do
+  k <- count -< ()
+  s <- sumN -< k
+  if k < n
+    then returnA -< ()
+    else arrM Left -< s
+
+automatonNoEmbedInlined :: Int -> Int
+automatonNoEmbedInlined k = either id absurd $ reactimate $ Automaton $ Stateful           StreamT
+            { state = (1, 0)
+            , Stream.step = \(n, s) ->
+              let n' = n + 1
+                  s' = s + n
+              in if n' > k then lift $ Left s' else return $! Result (n', s') ()
+            }
+
+
 direct :: Int -> Int
 direct n = sum [0 .. n]
 
diff --git a/rhine/bench/Test.hs b/rhine/bench/Test.hs
index 5145523b..c6c184a8 100644
--- a/rhine/bench/Test.hs
+++ b/rhine/bench/Test.hs
@@ -26,6 +26,8 @@ main =
           "Sum"
           [ testCase "rhine" $ Sum.rhine Sum.nMax @?= Sum.direct Sum.nMax
           , testCase "automaton" $ Sum.automaton Sum.nMax @?= Sum.direct Sum.nMax
+          , testCase "automatonNoEmbed" $ Sum.automatonNoEmbed Sum.nMax @?= Sum.direct Sum.nMax
+          , testCase "automatonNoEmbedInlined" $ Sum.automatonNoEmbedInlined Sum.nMax @?= Sum.direct Sum.nMax
           , testCase "rhine flow" $ Sum.rhineFlow Sum.nMax @?= Sum.direct Sum.nMax
           ]
       ]

From 54cdaf7cf73529fd147c375ea19eb23b48f849a2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Tue, 6 Aug 2024 19:07:52 +0200
Subject: [PATCH 5/9] WIP benchmarks

---
 rhine/bench/Sum.hs  | 18 +++++++++++++-----
 rhine/bench/Test.hs |  1 +
 2 files changed, 14 insertions(+), 5 deletions(-)

diff --git a/rhine/bench/Sum.hs b/rhine/bench/Sum.hs
index 59c407ef..902fbd4c 100644
--- a/rhine/bench/Sum.hs
+++ b/rhine/bench/Sum.hs
@@ -9,14 +9,13 @@ Most of the implementations really benchmark 'embed', as the lazy list is create
 module Sum where
 
 import "base" Control.Monad (foldM)
+import "base" Data.Either (fromLeft)
 import "base" Data.Functor.Identity
 import "base" Data.Void (absurd)
-
 import "criterion" Criterion.Main
 
-import "transformers" Control.Monad.Trans.Class (lift)
-
 import "automaton" Data.Stream as Stream (StreamT (..))
+import qualified "automaton" Data.Stream as Stream (reactimate)
 import "automaton" Data.Stream.Optimized (OptimizedStreamT (Stateful))
 import "rhine" FRP.Rhine
 
@@ -31,6 +30,7 @@ benchmarks =
     , bench "rhine flow" $ nf rhineFlow nMax
     , bench "automaton embed" $ nf automaton nMax
     , bench "automatonNoEmbed" $ nf automatonNoEmbed nMax
+    , bench "automatonEmbed" $ nf automatonEmbed nMax
     , bench "automatonNoEmbedInlined" $ nf automatonNoEmbedInlined nMax
     , bench "direct" $ nf direct nMax
     , bench "direct monad" $ nf directM nMax
@@ -63,6 +63,14 @@ automaton n = sum $ runIdentity $ embed myCount $ replicate n ()
             , Stream.step = \s -> return $! Result (s + 1) s
             }
 
+automatonEmbed :: Int -> Int
+automatonEmbed n = fromLeft (error "nope") $ flip embed (repeat ()) $ proc () -> do
+  k <- count -< ()
+  s <- sumN -< k
+  if k < n
+    then returnA -< ()
+    else arrM Left -< s
+
 automatonNoEmbed :: Int -> Int
 automatonNoEmbed n = either id absurd $ reactimate $ proc () -> do
   k <- count -< ()
@@ -72,12 +80,12 @@ automatonNoEmbed n = either id absurd $ reactimate $ proc () -> do
     else arrM Left -< s
 
 automatonNoEmbedInlined :: Int -> Int
-automatonNoEmbedInlined k = either id absurd $ reactimate $ Automaton $ Stateful           StreamT
+automatonNoEmbedInlined k = either id absurd $ Stream.reactimate StreamT
             { state = (1, 0)
             , Stream.step = \(n, s) ->
               let n' = n + 1
                   s' = s + n
-              in if n' > k then lift $ Left s' else return $! Result (n', s') ()
+              in if n' > k then Left s' else return $! Result (n', s') ()
             }
 
 
diff --git a/rhine/bench/Test.hs b/rhine/bench/Test.hs
index c6c184a8..329e5f72 100644
--- a/rhine/bench/Test.hs
+++ b/rhine/bench/Test.hs
@@ -27,6 +27,7 @@ main =
           [ testCase "rhine" $ Sum.rhine Sum.nMax @?= Sum.direct Sum.nMax
           , testCase "automaton" $ Sum.automaton Sum.nMax @?= Sum.direct Sum.nMax
           , testCase "automatonNoEmbed" $ Sum.automatonNoEmbed Sum.nMax @?= Sum.direct Sum.nMax
+          , testCase "automatonEmbed" $ Sum.automatonEmbed Sum.nMax @?= Sum.direct Sum.nMax
           , testCase "automatonNoEmbedInlined" $ Sum.automatonNoEmbedInlined Sum.nMax @?= Sum.direct Sum.nMax
           , testCase "rhine flow" $ Sum.rhineFlow Sum.nMax @?= Sum.direct Sum.nMax
           ]

From ada6b670a1eb58a48842e54f98afbe39ef0a5e3d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Thu, 8 Aug 2024 20:43:47 +0200
Subject: [PATCH 6/9] IO benchmark

---
 rhine/bench/Sum.hs | 16 ++++++++++++++++
 1 file changed, 16 insertions(+)

diff --git a/rhine/bench/Sum.hs b/rhine/bench/Sum.hs
index 902fbd4c..e1067d81 100644
--- a/rhine/bench/Sum.hs
+++ b/rhine/bench/Sum.hs
@@ -28,6 +28,7 @@ benchmarks =
     "Sum"
     [ bench "rhine embed" $ nf rhine nMax
     , bench "rhine flow" $ nf rhineFlow nMax
+    , bench "rhine flow IO" $ nfAppIO rhineMS nMax
     , bench "automaton embed" $ nf automaton nMax
     , bench "automatonNoEmbed" $ nf automatonNoEmbed nMax
     , bench "automatonEmbed" $ nf automatonEmbed nMax
@@ -51,6 +52,21 @@ rhineFlow n =
           then returnA -< ()
           else arrMCl Left -< s
 
+myclock :: IOClock (ExceptT Int IO) (Millisecond 0)
+myclock = ioClock waitClock
+
+rhineMS :: Int -> IO Int
+rhineMS n =
+  fmap (either id absurd) $
+  runExceptT $
+    flow $
+      (@@ myclock) $ proc () -> do
+        k <- count -< ()
+        s <- sumN -< k
+        if k < n
+          then returnA -< ()
+          else throwS -< s
+
 automaton :: Int -> Int
 automaton n = sum $ runIdentity $ embed myCount $ replicate n ()
   where

From fb191f1896b3f400107ede6f3e55d4a9918ee178 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Thu, 8 Aug 2024 20:44:35 +0200
Subject: [PATCH 7/9] Further inlining

---
 rhine/src/FRP/Rhine/Clock.hs                      | 3 +++
 rhine/src/FRP/Rhine/Clock/Realtime.hs             | 1 +
 rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs | 2 ++
 rhine/src/FRP/Rhine/Clock/Unschedule.hs           | 1 +
 4 files changed, 7 insertions(+)

diff --git a/rhine/src/FRP/Rhine/Clock.hs b/rhine/src/FRP/Rhine/Clock.hs
index f9f526b8..50fc2299 100644
--- a/rhine/src/FRP/Rhine/Clock.hs
+++ b/rhine/src/FRP/Rhine/Clock.hs
@@ -148,6 +148,7 @@ instance
       ( runningClock >>> first (arr f)
       , f initTime
       )
+  {-# INLINE initClock #-}
 
 {- | Instead of a mere function as morphism of time domains,
    we can transform one time domain into the other with an effectful morphism.
@@ -205,6 +206,7 @@ instance
       ( runningClock >>> rescaling
       , rescaledInitTime
       )
+  {-# INLINE initClock #-}
 
 -- | A 'RescaledClockM' is trivially a 'RescaledClockS'.
 rescaledClockMToS ::
@@ -242,6 +244,7 @@ instance
       ( hoistS monadMorphism runningClock
       , initialTime
       )
+  {-# INLINE initClock #-}
 
 -- | Lift a clock type into a monad transformer.
 type LiftClock m t cl = HoistClock m (t m) cl
diff --git a/rhine/src/FRP/Rhine/Clock/Realtime.hs b/rhine/src/FRP/Rhine/Clock/Realtime.hs
index efc780e2..70ba90f0 100644
--- a/rhine/src/FRP/Rhine/Clock/Realtime.hs
+++ b/rhine/src/FRP/Rhine/Clock/Realtime.hs
@@ -92,3 +92,4 @@ waitUTC unscaledClockS =
             return (now, (tag, guard (remaining > 0) >> return (fromRational remaining)))
         return (runningClock, initTime)
     }
+{-# INLINE waitUTC #-}
diff --git a/rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs b/rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs
index f3ccccbf..a84076c4 100644
--- a/rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs
+++ b/rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs
@@ -41,9 +41,11 @@ instance Clock IO (Millisecond n) where
   type Time (Millisecond n) = UTCTime
   type Tag (Millisecond n) = Maybe Double
   initClock (Millisecond cl) = initClock cl <&> first (>>> arr (second snd))
+  {-# INLINE initClock #-}
 
 instance GetClockProxy (Millisecond n)
 
 -- | Tries to achieve real time by using 'waitUTC', see its docs.
 waitClock :: (KnownNat n) => Millisecond n
 waitClock = Millisecond $ waitUTC $ RescaledClock (unyieldClock FixedStep) ((/ 1000) . fromInteger)
+{-# INLINE waitClock #-}
diff --git a/rhine/src/FRP/Rhine/Clock/Unschedule.hs b/rhine/src/FRP/Rhine/Clock/Unschedule.hs
index 06193188..4bb05b57 100644
--- a/rhine/src/FRP/Rhine/Clock/Unschedule.hs
+++ b/rhine/src/FRP/Rhine/Clock/Unschedule.hs
@@ -43,3 +43,4 @@ instance (TimeDomain (Time cl), Clock (ScheduleT (Diff (Time cl)) m) cl, Monad m
     where
       run :: ScheduleT (Diff (Time cl)) m a -> m a
       run = runScheduleT scheduleWait
+  {-# INLINE initClock #-}

From 3e50914336e89962484f71d634795c8023d8f37d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Tue, 13 Aug 2024 21:01:47 +0200
Subject: [PATCH 8/9] Refactor embed with foldM

---
 automaton/src/Data/Automaton.hs | 9 ++-------
 1 file changed, 2 insertions(+), 7 deletions(-)

diff --git a/automaton/src/Data/Automaton.hs b/automaton/src/Data/Automaton.hs
index 5eff8869..280fd61b 100644
--- a/automaton/src/Data/Automaton.hs
+++ b/automaton/src/Data/Automaton.hs
@@ -13,7 +13,7 @@ module Data.Automaton where
 import Control.Applicative (Alternative (..))
 import Control.Arrow
 import Control.Category
-import Control.Monad ((<=<))
+import Control.Monad ((<=<), foldM)
 import Control.Monad.Fix (MonadFix (mfix))
 import Data.Coerce (coerce)
 import Data.Function ((&))
@@ -371,12 +371,7 @@ embed ::
   -- | The input values
   [a] ->
   m [b]
-embed (Automaton (Stateful StreamT {state, step})) = go state
-  where
-    go _s [] = return []
-    go s (a : as) = do
-      Result s' b <- runReaderT (step s) a
-      (b :) <$> go s' as
+embed (Automaton (Stateful StreamT {state, step})) = fmap (fmap output) $ foldM (\(Result s bs) a -> fmap (: bs) <$> runReaderT (step s) a) $ Result state []
 embed (Automaton (Stateless m)) = mapM $ runReaderT m
 
 -- * Modifying automata

From 46cb5ce64d5dbe4bbb8e45bbf502eaac739645b7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Tue, 13 Aug 2024 22:03:41 +0200
Subject: [PATCH 9/9] Comment

---
 rhine/bench/Sum.hs | 1 +
 1 file changed, 1 insertion(+)

diff --git a/rhine/bench/Sum.hs b/rhine/bench/Sum.hs
index e1067d81..0886d942 100644
--- a/rhine/bench/Sum.hs
+++ b/rhine/bench/Sum.hs
@@ -67,6 +67,7 @@ rhineMS n =
           then returnA -< ()
           else throwS -< s
 
+-- embed cannot be faster because it receives a list of boxed ints, whereas the flow version can unbox it.
 automaton :: Int -> Int
 automaton n = sum $ runIdentity $ embed myCount $ replicate n ()
   where