From 504b5dc16019bcd664a1a811b740c606eadabd3f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Mon, 10 Jun 2024 15:18:49 +0200 Subject: [PATCH 1/7] Replace SN by functions --- .../FRP/Rhine/Reactimation/ClockErasure.hs | 70 +++++++++++++------ .../src/FRP/Rhine/Reactimation/Combinators.hs | 14 ++-- rhine/src/FRP/Rhine/SN/Combinators.hs | 57 ++++----------- rhine/src/FRP/Rhine/Type.hs | 5 +- 4 files changed, 73 insertions(+), 73 deletions(-) diff --git a/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs b/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs index 344e197e..081e8d59 100644 --- a/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs +++ b/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs @@ -1,6 +1,8 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {- | 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,23 @@ 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 +65,25 @@ 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 +101,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 +143,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 +156,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..676682b7 100644 --- a/rhine/src/FRP/Rhine/Reactimation/Combinators.hs +++ b/rhine/src/FRP/Rhine/Reactimation/Combinators.hs @@ -21,8 +21,8 @@ module FRP.Rhine.Reactimation.Combinators where import FRP.Rhine.ClSF.Core import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy +import FRP.Rhine.Reactimation.ClockErasure import FRP.Rhine.ResamplingBuffer -import FRP.Rhine.SN import FRP.Rhine.SN.Combinators import FRP.Rhine.Schedule import FRP.Rhine.Type @@ -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..cb8b1bcc 100644 --- a/rhine/src/FRP/Rhine/SN/Combinators.hs +++ b/rhine/src/FRP/Rhine/SN/Combinators.hs @@ -7,11 +7,11 @@ Combinators for composing signal networks sequentially and parallely. module FRP.Rhine.SN.Combinators where -- rhine +import Data.Functor ((<&>)) 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.Reactimation.ClockErasure import FRP.Rhine.Schedule {- FOURMOLU_DISABLE -} @@ -21,13 +21,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 +29,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 +59,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 +80,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..218ccf7f 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) {- | @@ -71,13 +70,15 @@ feedbackRhine :: , Clock m (Out cl) , Time (In 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 78f87be6814ec82fb046ca9333fccf19fc3ed3ef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Mon, 10 Jun 2024 15:48:31 +0200 Subject: [PATCH 2/7] 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 081e8d59..a64baaa3 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 :: @@ -59,6 +60,7 @@ synchronous :: 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, @@ -101,11 +103,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 @@ -114,6 +118,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 @@ -122,6 +127,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 @@ -143,6 +149,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 f1d8ce2322ee74e750eb63aff31de9029e26675a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Fri, 2 Aug 2024 16:43:05 +0200 Subject: [PATCH 3/7] Inline more library functions --- automaton/src/Data/Automaton.hs | 8 ++++++++ rhine/src/FRP/Rhine/Clock/Util.hs | 1 + 2 files changed, 9 insertions(+) diff --git a/automaton/src/Data/Automaton.hs b/automaton/src/Data/Automaton.hs index 499d5396..81def435 100644 --- a/automaton/src/Data/Automaton.hs +++ b/automaton/src/Data/Automaton.hs @@ -257,6 +257,12 @@ 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)) @@ -519,10 +525,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 9ef48f913988e15cfa793c4721b398bec8cfb07c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Fri, 29 Nov 2024 15:46:41 +0100 Subject: [PATCH 4/7] Clean up module structure --- rhine/rhine.cabal | 1 + .../FRP/Rhine/Reactimation/ClockErasure.hs | 137 +---------- .../src/FRP/Rhine/Reactimation/Combinators.hs | 2 +- rhine/src/FRP/Rhine/SN.hs | 221 +++++++++++------- rhine/src/FRP/Rhine/SN/Combinators.hs | 6 +- rhine/src/FRP/Rhine/SN/Type.hs | 30 +++ rhine/src/FRP/Rhine/Type.hs | 1 + 7 files changed, 182 insertions(+), 216 deletions(-) create mode 100644 rhine/src/FRP/Rhine/SN/Type.hs diff --git a/rhine/rhine.cabal b/rhine/rhine.cabal index a9dc9a42..5aace1e6 100644 --- a/rhine/rhine.cabal +++ b/rhine/rhine.cabal @@ -133,6 +133,7 @@ library FRP.Rhine.ResamplingBuffer.Util FRP.Rhine.SN FRP.Rhine.SN.Combinators + FRP.Rhine.SN.Type FRP.Rhine.Schedule FRP.Rhine.Type diff --git a/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs b/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs index a64baaa3..0d1ad888 100644 --- a/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs +++ b/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs @@ -3,7 +3,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {- | Translate clocked signal processing components to stream functions without explicit clock types. @@ -12,9 +11,6 @@ and is thus not exported from 'FRP.Rhine'. -} module FRP.Rhine.Reactimation.ClockErasure where --- base -import Control.Monad (join) - -- automaton import Data.Automaton.Trans.Reader import Data.Stream.Result (Result (..)) @@ -25,7 +21,7 @@ import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy import FRP.Rhine.Clock.Util import FRP.Rhine.ResamplingBuffer -import FRP.Rhine.Schedule (In, Out, SequentialClock) +import FRP.Rhine.SN.Type (SN (..)) {- | Run a clocked signal function as an automaton, accepting the timestamps and tags as explicit inputs. @@ -41,131 +37,20 @@ eraseClockClSF proxy initialTime clsf = proc (time, tag, a) -> do runReaderS clsf -< (timeInfo, a) {-# INLINE eraseClockClSF #-} --- 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 +{- | Remove the signal network type abstraction and reveal the underlying automaton. -eraseClockSN :: Time cl -> SN m cl a b -> (Automaton m (Time cl, Tag cl, Maybe a) (Maybe b)) +* To drive the network, the timestamps and tags of the clock are needed +* Since the input and output clocks are not always guaranteed to tick, the inputs and outputs are 'Maybe'. +-} +eraseClockSN :: + -- | Initial time + Time cl -> + -- The original signal network + 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) => - 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 -{-# INLINE synchronous #-} - --- A sequentially composed signal network may either be triggered in its first component, --- or its second component. In either case, --- 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. -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 - 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) -{-# 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 - 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 -{-# INLINE postcompose #-} - -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) -{-# INLINE precompose #-} - -feedbackSN ResamplingBuffer {buffer, put, get} sn = SN $ reader $ \initialTime -> - let - proxy = toClockProxy sn - in - feedback buffer $ proc ((time, tag, aMaybe), buf) -> do - (cMaybe, buf') <- case inTag proxy tag of - Nothing -> do - returnA -< (Nothing, buf) - Just tagIn -> do - timeInfo <- genTimeInfo (inProxy proxy) initialTime -< (time, tagIn) - Result buf' c <- arrM $ uncurry get -< (timeInfo, buf) - returnA -< (Just c, buf') - bdMaybe <- eraseClockSN initialTime sn -< (time, tag, (,) <$> aMaybe <*> cMaybe) - case (,) <$> outTag proxy tag <*> bdMaybe of - Nothing -> do - returnA -< (Nothing, buf') - Just (tagOut, (b, d)) -> do - 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 - in - proc (time, tag, acMaybe) -> do - bMaybe <- eraseClockSN initialTime sn -< (time, tag, fst <$> acMaybe) - let - resBufInput = case (inTag proxy tag, outTag proxy tag, snd <$> acMaybe) of - (Just tagIn, _, Just c) -> Just $ Left (time, tagIn, c) - (_, Just tagOut, _) -> Just $ Right (time, tagOut) - _ -> Nothing - dMaybe <- mapMaybeS $ eraseClockResBuf (inProxy proxy) (outProxy proxy) initialTime buf -< resBufInput - returnA -< (,) <$> bMaybe <*> join dMaybe -{-# INLINE firstResampling #-} - {- | Translate a resampling buffer into an automaton. The input decides whether the buffer is to accept input or has to produce output. diff --git a/rhine/src/FRP/Rhine/Reactimation/Combinators.hs b/rhine/src/FRP/Rhine/Reactimation/Combinators.hs index 676682b7..0b8572f5 100644 --- a/rhine/src/FRP/Rhine/Reactimation/Combinators.hs +++ b/rhine/src/FRP/Rhine/Reactimation/Combinators.hs @@ -21,8 +21,8 @@ module FRP.Rhine.Reactimation.Combinators where import FRP.Rhine.ClSF.Core import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy -import FRP.Rhine.Reactimation.ClockErasure import FRP.Rhine.ResamplingBuffer +import FRP.Rhine.SN import FRP.Rhine.SN.Combinators import FRP.Rhine.Schedule import FRP.Rhine.Type diff --git a/rhine/src/FRP/Rhine/SN.hs b/rhine/src/FRP/Rhine/SN.hs index 8cc92a67..0f27653a 100644 --- a/rhine/src/FRP/Rhine/SN.hs +++ b/rhine/src/FRP/Rhine/SN.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {- | @@ -11,105 +12,151 @@ all satisfying the appropriate clock type constraints. This module defines the 'SN' type, combinators are found in a submodule. -} -module FRP.Rhine.SN where +module FRP.Rhine.SN ( + module FRP.Rhine.SN, + module FRP.Rhine.SN.Type, +) where + +-- base +import Control.Monad (join) + +-- transformers +import Control.Monad.Trans.Reader (reader) + +-- automata +import Data.Stream.Result (Result (..)) -- rhine import FRP.Rhine.ClSF.Core import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy +import FRP.Rhine.Clock.Util (genTimeInfo) +import FRP.Rhine.Reactimation.ClockErasure import FRP.Rhine.ResamplingBuffer +import FRP.Rhine.SN.Type import FRP.Rhine.Schedule -{- FOURMOLU_DISABLE -} - -{- | An 'SN' is a side-effectful asynchronous /__s__ignal __n__etwork/, -where input, data processing (including side effects) and output -need not happen at the same time. - -The type parameters are: - -* 'm': The monad in which side effects take place. -* 'cl': The clock of the whole signal network. - It may be sequentially or parallely composed from other clocks. -* 'a': The input type. Input arrives at the rate @In cl@. -* 'b': The output type. Output arrives at the rate @Out cl@. +{- | A synchronous automaton is the basic building block. + For such an 'SN', data enters and leaves the system at the same rate as it is processed. -} -data SN m cl a b where - -- | A synchronous automaton is the basic building block. - -- For such an 'SN', data enters and leaves the system at the same rate as it is processed. - Synchronous :: - ( cl ~ In cl, cl ~ Out cl) => - ClSF m cl a b -> - SN m cl a b +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 +{-# INLINE synchronous #-} - -- | Two 'SN's may be sequentially composed if there is a matching 'ResamplingBuffer' between them. - 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) - ) => - 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 +-- | Two 'SN's may be sequentially composed if there is a matching 'ResamplingBuffer' between them. +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 +-- A sequentially composed signal network may either be triggered in its first component, +-- or its second component. In either case, +-- 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. +sequential sn1 resBuf sn2 = SN $ reader $ \initialTime -> + 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) +{-# INLINE sequential #-} - -- | Two 'SN's with the same input and output data may be parallely composed. - Parallel :: - ( Clock m cl1, Clock m cl2 - , Clock m (Out cl1), Clock m (Out cl2) - , GetClockProxy cl1, GetClockProxy cl2 - , Time cl1 ~ Time (Out cl1) - , Time cl2 ~ Time (Out cl2) - , Time cl1 ~ Time cl2 - , Time cl1 ~ Time (In cl1) - , Time cl2 ~ Time (In cl2) - ) => - SN m cl1 a b -> - SN m cl2 a b -> - SN m (ParallelClock cl1 cl2) a b +-- | Two 'SN's with the same input and output data may be parallely composed. +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 #-} - -- | Bypass the signal network by forwarding data in parallel through a 'ResamplingBuffer'. - FirstResampling :: - ( Clock m (In cl), Clock m (Out cl) - , Time cl ~ Time (Out cl) - , Time cl ~ Time (In cl) - ) => - SN m cl a b -> - ResamplingBuffer m (In cl) (Out cl) c d -> - SN m cl (a, c) (b, d) +-- | A 'ClSF' can always be postcomposed onto an 'SN' if the clocks match on the output. +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 +{-# INLINE postcompose #-} - -- | A 'ClSF' can always be postcomposed onto an 'SN' if the clocks match on the output. - Postcompose :: - ( Clock m (Out cl) - , Time cl ~ Time (Out cl) - ) => - SN m cl a b -> - ClSF m (Out cl) b c -> - SN m cl a c +-- | A 'ClSF' can always be precomposed onto an 'SN' if the clocks match on the input. +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) +{-# INLINE precompose #-} - -- | A 'ClSF' can always be precomposed onto an 'SN' if the clocks match on the input. - Precompose :: - ( Clock m (In cl) - , Time cl ~ Time (In cl) - ) => - ClSF m (In cl) a b -> - SN m cl b c -> - SN m cl a c - - -- | Data can be looped back to the beginning of an 'SN', - -- but it must be resampled since the 'Out' and 'In' clocks are generally different. - Feedback :: - ( Clock m (In cl), Clock m (Out cl) - , Time (In cl) ~ Time cl - , Time (Out cl) ~ Time cl - ) => - ResBuf m (Out cl) (In cl) d c -> - SN m cl (a, c) (b, d) -> - SN m cl a b +{- | Data can be looped back to the beginning of an 'SN', + but it must be resampled since the 'Out' and 'In' clocks are generally different. +-} +feedbackSN ResamplingBuffer {buffer, put, get} sn = SN $ reader $ \initialTime -> + let + proxy = toClockProxy sn + in + feedback buffer $ proc ((time, tag, aMaybe), buf) -> do + (cMaybe, buf') <- case inTag proxy tag of + Nothing -> do + returnA -< (Nothing, buf) + Just tagIn -> do + timeInfo <- genTimeInfo (inProxy proxy) initialTime -< (time, tagIn) + Result buf' c <- arrM $ uncurry get -< (timeInfo, buf) + returnA -< (Just c, buf') + bdMaybe <- eraseClockSN initialTime sn -< (time, tag, (,) <$> aMaybe <*> cMaybe) + case (,) <$> outTag proxy tag <*> bdMaybe of + Nothing -> do + returnA -< (Nothing, buf') + Just (tagOut, (b, d)) -> do + timeInfo <- genTimeInfo (outProxy proxy) initialTime -< (time, tagOut) + buf'' <- arrM $ uncurry $ uncurry put -< ((timeInfo, d), buf') + returnA -< (Just b, buf'') +{-# INLINE feedbackSN #-} -instance GetClockProxy cl => ToClockProxy (SN m cl a b) where - type Cl (SN m cl a b) = cl +-- | Bypass the signal network by forwarding data in parallel through a 'ResamplingBuffer'. +firstResampling sn buf = SN $ reader $ \initialTime -> + let + proxy = toClockProxy sn + in + proc (time, tag, acMaybe) -> do + bMaybe <- eraseClockSN initialTime sn -< (time, tag, fst <$> acMaybe) + let + resBufInput = case (inTag proxy tag, outTag proxy tag, snd <$> acMaybe) of + (Just tagIn, _, Just c) -> Just $ Left (time, tagIn, c) + (_, Just tagOut, _) -> Just $ Right (time, tagOut) + _ -> Nothing + dMaybe <- mapMaybeS $ eraseClockResBuf (inProxy proxy) (outProxy proxy) initialTime buf -< resBufInput + returnA -< (,) <$> bMaybe <*> join dMaybe +{-# INLINE firstResampling #-} diff --git a/rhine/src/FRP/Rhine/SN/Combinators.hs b/rhine/src/FRP/Rhine/SN/Combinators.hs index cb8b1bcc..f439ecde 100644 --- a/rhine/src/FRP/Rhine/SN/Combinators.hs +++ b/rhine/src/FRP/Rhine/SN/Combinators.hs @@ -6,12 +6,14 @@ Combinators for composing signal networks sequentially and parallely. -} module FRP.Rhine.SN.Combinators where --- rhine +-- base import Data.Functor ((<&>)) + +-- rhine import FRP.Rhine.ClSF.Core import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy -import FRP.Rhine.Reactimation.ClockErasure +import FRP.Rhine.SN import FRP.Rhine.Schedule {- FOURMOLU_DISABLE -} diff --git a/rhine/src/FRP/Rhine/SN/Type.hs b/rhine/src/FRP/Rhine/SN/Type.hs new file mode 100644 index 00000000..cde41471 --- /dev/null +++ b/rhine/src/FRP/Rhine/SN/Type.hs @@ -0,0 +1,30 @@ +module FRP.Rhine.SN.Type where + +-- transformers +import Control.Monad.Trans.Reader (Reader) + +-- automaton +import Data.Automaton + +-- rhine +import FRP.Rhine.Clock +import FRP.Rhine.Clock.Proxy + +-- Andras Kovacs' trick: Encode in the domain + +{- | An 'SN' is a side-effectful asynchronous /__s__ignal __n__etwork/, +where input, data processing (including side effects) and output +need not happen at the same time. + +The type parameters are: + +* 'm': The monad in which side effects take place. +* 'cl': The clock of the whole signal network. + It may be sequentially or parallely composed from other clocks. +* 'a': The input type. Input arrives at the rate @In cl@. +* 'b': The output type. Output arrives at the rate @Out cl@. +-} +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 diff --git a/rhine/src/FRP/Rhine/Type.hs b/rhine/src/FRP/Rhine/Type.hs index 218ccf7f..03a2e6e8 100644 --- a/rhine/src/FRP/Rhine/Type.hs +++ b/rhine/src/FRP/Rhine/Type.hs @@ -18,6 +18,7 @@ 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) {- | From 11fabe50e49ba027e51b5e66c6c6976a7bb113f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Fri, 29 Nov 2024 15:56:25 +0100 Subject: [PATCH 5/7] Inline initClock everywhere --- rhine-gloss/src/FRP/Rhine/Gloss/IO.hs | 2 ++ rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs | 1 + rhine-terminal/src/FRP/Rhine/Terminal.hs | 1 + rhine/src/FRP/Rhine/Clock.hs | 4 ++++ rhine/src/FRP/Rhine/Clock/Except.hs | 3 +++ rhine/src/FRP/Rhine/Clock/FixedStep.hs | 1 + rhine/src/FRP/Rhine/Clock/Periodic.hs | 1 + rhine/src/FRP/Rhine/Clock/Realtime/Audio.hs | 2 ++ rhine/src/FRP/Rhine/Clock/Realtime/Busy.hs | 1 + rhine/src/FRP/Rhine/Clock/Realtime/Event.hs | 1 + rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs | 1 + rhine/src/FRP/Rhine/Clock/Realtime/Never.hs | 1 + rhine/src/FRP/Rhine/Clock/Realtime/Stdin.hs | 1 + rhine/src/FRP/Rhine/Clock/Select.hs | 1 + rhine/src/FRP/Rhine/Clock/Trivial.hs | 1 + rhine/src/FRP/Rhine/Clock/Unschedule.hs | 1 + rhine/src/FRP/Rhine/Schedule.hs | 2 ++ rhine/test/Clock/Except.hs | 1 + 18 files changed, 26 insertions(+) diff --git a/rhine-gloss/src/FRP/Rhine/Gloss/IO.hs b/rhine-gloss/src/FRP/Rhine/Gloss/IO.hs index a59ee7cf..49b6247d 100644 --- a/rhine-gloss/src/FRP/Rhine/Gloss/IO.hs +++ b/rhine-gloss/src/FRP/Rhine/Gloss/IO.hs @@ -134,6 +134,7 @@ instance (MonadIO m) => Clock (GlossConcT m) GlossEventClockIO where liftIO $ do time <- readIORef timeRef return (time, event) + {-# INLINE initClock #-} instance GetClockProxy GlossEventClockIO @@ -153,6 +154,7 @@ instance (MonadIO m) => Clock (GlossConcT m) GlossSimClockIO where getTime = GlossConcT $ do GlossEnv {timeVar} <- ask lift $ asyncMVar timeVar + {-# INLINE initClock #-} instance GetClockProxy GlossSimClockIO diff --git a/rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs b/rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs index 465ac3a7..23d18e8f 100644 --- a/rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs +++ b/rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs @@ -83,6 +83,7 @@ instance Clock GlossM GlossClock where type Time GlossClock = Float type Tag GlossClock = Maybe Event initClock _ = return (constM (GlossM $ yield >> lift ask) >>> (sumS *** Category.id), 0) + {-# INLINE initClock #-} instance GetClockProxy GlossClock diff --git a/rhine-terminal/src/FRP/Rhine/Terminal.hs b/rhine-terminal/src/FRP/Rhine/Terminal.hs index 475a5422..d91e7612 100644 --- a/rhine-terminal/src/FRP/Rhine/Terminal.hs +++ b/rhine-terminal/src/FRP/Rhine/Terminal.hs @@ -53,6 +53,7 @@ instance (MonadInput m, MonadIO m) => Clock m TerminalEventClock where return (time, event) , initialTime ) + {-# INLINE initClock #-} instance GetClockProxy TerminalEventClock diff --git a/rhine/src/FRP/Rhine/Clock.hs b/rhine/src/FRP/Rhine/Clock.hs index f9f526b8..dea2e355 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. @@ -172,6 +173,7 @@ instance ( runningClock >>> first (arrM rescaleM) , rescaledInitTime ) + {-# INLINE initClock #-} -- | A 'RescaledClock' is trivially a 'RescaledClockM'. rescaledClockToM :: (Monad m) => RescaledClock cl time -> RescaledClockM m cl time @@ -205,6 +207,7 @@ instance ( runningClock >>> rescaling , rescaledInitTime ) + {-# INLINE initClock #-} -- | A 'RescaledClockM' is trivially a 'RescaledClockS'. rescaledClockMToS :: @@ -242,6 +245,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/Except.hs b/rhine/src/FRP/Rhine/Clock/Except.hs index f153822c..2f3dab77 100644 --- a/rhine/src/FRP/Rhine/Clock/Except.hs +++ b/rhine/src/FRP/Rhine/Clock/Except.hs @@ -58,6 +58,7 @@ instance (Exception e, Clock IO cl, MonadIO eio, MonadError e eio) => Clock eio where ioerror :: (MonadError e eio, MonadIO eio) => IO (Either e a) -> eio a ioerror = liftEither <=< liftIO + {-# INLINE initClock #-} instance GetClockProxy (ExceptClock cl e) @@ -87,6 +88,7 @@ instance (Time cl1 ~ Time cl2, Clock (ExceptT e m) cl1, Clock m cl2, Monad m) => safe $ runningClock' >>> arr (second Left) return (catchingClock, initTime) Left e -> (fmap (first (>>> arr (second Left))) . initClock) $ handler e + {-# INLINE initClock #-} instance (GetClockProxy (CatchClock cl1 e cl2)) @@ -142,6 +144,7 @@ instance (TimeDomain time, MonadError e m) => Clock m (Single m time tag e) wher errorT :: (MonadError e m) => m (Either e a) -> m a errorT = (>>= liftEither) return (runningClock, initTime) + {-# INLINE initClock #-} -- * 'DelayException' diff --git a/rhine/src/FRP/Rhine/Clock/FixedStep.hs b/rhine/src/FRP/Rhine/Clock/FixedStep.hs index 551df585..cbc0e6aa 100644 --- a/rhine/src/FRP/Rhine/Clock/FixedStep.hs +++ b/rhine/src/FRP/Rhine/Clock/FixedStep.hs @@ -57,6 +57,7 @@ instance (MonadSchedule m, Monad m) => Clock (ScheduleT Integer m) (FixedStep n) >>> arrM (\time -> wait step $> (time, ())) , 0 ) + {-# INLINE initClock #-} instance GetClockProxy (FixedStep n) diff --git a/rhine/src/FRP/Rhine/Clock/Periodic.hs b/rhine/src/FRP/Rhine/Clock/Periodic.hs index 01ae458c..9d6bd01d 100644 --- a/rhine/src/FRP/Rhine/Clock/Periodic.hs +++ b/rhine/src/FRP/Rhine/Clock/Periodic.hs @@ -52,6 +52,7 @@ instance ( cycleS (theList cl) >>> withSideEffect wait >>> accumulateWith (+) 0 &&& arr (const ()) , 0 ) + {-# INLINE initClock #-} instance GetClockProxy (Periodic v) diff --git a/rhine/src/FRP/Rhine/Clock/Realtime/Audio.hs b/rhine/src/FRP/Rhine/Clock/Realtime/Audio.hs index c9ddf733..af511cbd 100644 --- a/rhine/src/FRP/Rhine/Clock/Realtime/Audio.hs +++ b/rhine/src/FRP/Rhine/Clock/Realtime/Audio.hs @@ -126,6 +126,7 @@ instance ( runningClock initialTime Nothing , initialTime ) + {-# INLINE initClock #-} instance GetClockProxy (AudioClock rate bufferSize) @@ -155,6 +156,7 @@ instance (Monad m, PureAudioClockRate rate) => Clock m (PureAudioClock rate) whe ( arr (const (1 / thePureRateNum audioClock)) >>> sumS &&& arr (const ()) , 0 ) + {-# INLINE initClock #-} instance GetClockProxy (PureAudioClock rate) diff --git a/rhine/src/FRP/Rhine/Clock/Realtime/Busy.hs b/rhine/src/FRP/Rhine/Clock/Realtime/Busy.hs index f0ddecce..039e9128 100644 --- a/rhine/src/FRP/Rhine/Clock/Realtime/Busy.hs +++ b/rhine/src/FRP/Rhine/Clock/Realtime/Busy.hs @@ -36,5 +36,6 @@ instance (MonadIO m) => Clock m Busy where &&& arr (const ()) , initialTime ) + {-# INLINE initClock #-} instance GetClockProxy Busy diff --git a/rhine/src/FRP/Rhine/Clock/Realtime/Event.hs b/rhine/src/FRP/Rhine/Clock/Realtime/Event.hs index 72172a80..1f233c3c 100644 --- a/rhine/src/FRP/Rhine/Clock/Realtime/Event.hs +++ b/rhine/src/FRP/Rhine/Clock/Realtime/Event.hs @@ -160,6 +160,7 @@ instance (MonadIO m) => Clock (EventChanT event m) (EventClock event) where return (time, event) , initialTime ) + {-# INLINE initClock #-} instance GetClockProxy (EventClock event) diff --git a/rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs b/rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs index f3ccccbf..130102eb 100644 --- a/rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs +++ b/rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs @@ -41,6 +41,7 @@ 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) diff --git a/rhine/src/FRP/Rhine/Clock/Realtime/Never.hs b/rhine/src/FRP/Rhine/Clock/Realtime/Never.hs index a68e1783..7ac2a8ae 100644 --- a/rhine/src/FRP/Rhine/Clock/Realtime/Never.hs +++ b/rhine/src/FRP/Rhine/Clock/Realtime/Never.hs @@ -33,5 +33,6 @@ instance (MonadIO m) => Clock m Never where ( constM (liftIO . forever . threadDelay $ 10 ^ 9) , initialTime ) + {-# INLINE initClock #-} instance GetClockProxy Never diff --git a/rhine/src/FRP/Rhine/Clock/Realtime/Stdin.hs b/rhine/src/FRP/Rhine/Clock/Realtime/Stdin.hs index 9246f65c..206097da 100644 --- a/rhine/src/FRP/Rhine/Clock/Realtime/Stdin.hs +++ b/rhine/src/FRP/Rhine/Clock/Realtime/Stdin.hs @@ -45,6 +45,7 @@ instance (MonadIO m) => Clock m StdinClock where return (time, line) , initialTime ) + {-# INLINE initClock #-} instance GetClockProxy StdinClock diff --git a/rhine/src/FRP/Rhine/Clock/Select.hs b/rhine/src/FRP/Rhine/Clock/Select.hs index 63dedbdd..1aba8330 100644 --- a/rhine/src/FRP/Rhine/Clock/Select.hs +++ b/rhine/src/FRP/Rhine/Clock/Select.hs @@ -64,6 +64,7 @@ instance (Monad m, Clock m cl) => Clock m (SelectClock cl a) where (time, tag) <- runningClock -< () returnA -< (time,) <$> select tag return (runningSelectClock, initialTime) + {-# INLINE initClock #-} instance GetClockProxy (SelectClock cl a) diff --git a/rhine/src/FRP/Rhine/Clock/Trivial.hs b/rhine/src/FRP/Rhine/Clock/Trivial.hs index 8518a303..0ca1ee0d 100644 --- a/rhine/src/FRP/Rhine/Clock/Trivial.hs +++ b/rhine/src/FRP/Rhine/Clock/Trivial.hs @@ -14,5 +14,6 @@ instance (Monad m) => Clock m Trivial where type Time Trivial = () type Tag Trivial = () initClock _ = return (arr $ const ((), ()), ()) + {-# INLINE initClock #-} instance GetClockProxy Trivial 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 #-} diff --git a/rhine/src/FRP/Rhine/Schedule.hs b/rhine/src/FRP/Rhine/Schedule.hs index d2dbbbc4..1301a32c 100644 --- a/rhine/src/FRP/Rhine/Schedule.hs +++ b/rhine/src/FRP/Rhine/Schedule.hs @@ -113,6 +113,7 @@ instance type Tag (SequentialClock cl1 cl2) = Either (Tag cl1) (Tag cl2) initClock SequentialClock {..} = initSchedule sequentialCl1 sequentialCl2 + {-# INLINE initClock #-} -- ** Parallelly combined clocks @@ -136,6 +137,7 @@ instance type Tag (ParallelClock cl1 cl2) = Either (Tag cl1) (Tag cl2) initClock ParallelClock {..} = initSchedule parallelCl1 parallelCl2 + {-# INLINE initClock #-} -- * Navigating the clock tree diff --git a/rhine/test/Clock/Except.hs b/rhine/test/Clock/Except.hs index 0417c3be..81c84509 100644 --- a/rhine/test/Clock/Except.hs +++ b/rhine/test/Clock/Except.hs @@ -102,6 +102,7 @@ instance (Monad m) => Clock (ExceptT () m) FailingClock where type Time FailingClock = UTCTime type Tag FailingClock = () initClock FailingClock = throwE () + {-# INLINE initClock #-} instance GetClockProxy FailingClock From 19b1a23723bf02979ec558cef07ee44b074ae9c5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Fri, 29 Nov 2024 15:56:47 +0100 Subject: [PATCH 6/7] Inline lastS --- automaton/src/Data/Automaton.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/automaton/src/Data/Automaton.hs b/automaton/src/Data/Automaton.hs index 81def435..2d0a5e30 100644 --- a/automaton/src/Data/Automaton.hs +++ b/automaton/src/Data/Automaton.hs @@ -535,3 +535,4 @@ count = feedback 0 $! arr (\(_, n) -> let n' = n + 1 in (n', n')) -- | Remembers the last 'Just' value, defaulting to the given initialisation value. lastS :: (Monad m) => a -> Automaton m (Maybe a) a lastS a = arr Last >>> mappendS >>> arr (getLast >>> fromMaybe a) +{-# INLINE lastS #-} From 745f23fc358d9b4a4dde703bc3310e334b625ac0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Fri, 29 Nov 2024 15:57:47 +0100 Subject: [PATCH 7/7] Update changelog --- rhine/ChangeLog.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/rhine/ChangeLog.md b/rhine/ChangeLog.md index e14d7e5e..852570d5 100644 --- a/rhine/ChangeLog.md +++ b/rhine/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for rhine +## Upcoming + +* Removed `SN` GADT in favour of semantic functions, for a > 100x speedup in some benchmarks + (https://github.com/turion/rhine/pull/348) + ## 1.5 * Added `forever` utility for recursion in `ClSFExcept`