rhine 1.5 → 1.6

raw patch · 28 files changed

+269/−255 lines, 28 filesdep ~automatondep ~basedep ~monad-schedule

Dependency ranges changed: automaton, base, monad-schedule, time-domain

Files

• ChangeLog.md +10/−0
• rhine.cabal +14/−12
• src/FRP/Rhine/Clock.hs +5/−1
• src/FRP/Rhine/Clock/Except.hs +4/−1
• src/FRP/Rhine/Clock/FixedStep.hs +1/−0
• src/FRP/Rhine/Clock/Periodic.hs +1/−0
• src/FRP/Rhine/Clock/Realtime/Audio.hs +2/−0
• src/FRP/Rhine/Clock/Realtime/Busy.hs +1/−0
• src/FRP/Rhine/Clock/Realtime/Event.hs +1/−0
• src/FRP/Rhine/Clock/Realtime/Millisecond.hs +1/−0
• src/FRP/Rhine/Clock/Realtime/Never.hs +1/−0
• src/FRP/Rhine/Clock/Realtime/Stdin.hs +1/−0
• src/FRP/Rhine/Clock/Select.hs +1/−0
• src/FRP/Rhine/Clock/Trivial.hs +1/−0
• src/FRP/Rhine/Clock/Unschedule.hs +1/−0
• src/FRP/Rhine/Clock/Util.hs +1/−0
• src/FRP/Rhine/Reactimation/ClockErasure.hs +9/−92
• src/FRP/Rhine/Reactimation/Combinators.hs +8/−4
• src/FRP/Rhine/ResamplingBuffer.hs +2/−1
• src/FRP/Rhine/ResamplingBuffer/ClSF.hs +3/−3
• src/FRP/Rhine/ResamplingBuffer/Util.hs +5/−5
• src/FRP/Rhine/SN.hs +134/−87
• src/FRP/Rhine/SN/Combinators.hs +15/−42
• src/FRP/Rhine/SN/Type.hs +30/−0
• src/FRP/Rhine/Schedule.hs +8/−4
• src/FRP/Rhine/Schedule/Internal.hs +5/−2
• src/FRP/Rhine/Type.hs +3/−1
• test/Clock/Except.hs +1/−0

@@ -1,5 +1,15 @@ # 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.6++* Support GHC 9.12+* Replace 'SN' GADT definition by newtype. Thanks to András Kovács for the suggestion.+ ## 1.5  * Added `forever` utility for recursion in `ClSFExcept`

@@ -1,6 +1,6 @@ cabal-version: 2.2 name: rhine-version: 1.5+version: 1.6 synopsis: Functional Reactive Programming with type-level clocks description:   Rhine is a library for synchronous and asynchronous Functional Reactive Programming (FRP).@@ -31,11 +31,12 @@   test/assets/*.txt  tested-with:-  ghc ==9.2.8-  ghc ==9.4.7-  ghc ==9.6.4-  ghc ==9.8.2-  ghc ==9.10.1+  ghc ==9.2+  ghc ==9.4+  ghc ==9.6+  ghc ==9.8+  ghc ==9.10+  ghc ==9.12  source-repository head   type: git@@ -44,13 +45,13 @@ source-repository this   type: git   location: https://github.com/turion/rhine.git-  tag: v1.5+  tag: v1.6  common opts   build-depends:-    automaton ^>=1.5,-    base >=4.16 && <4.21,-    monad-schedule ^>=0.2,+    automaton ^>=1.6,+    base >=4.16 && <4.22,+    monad-schedule ^>=1.6,     mtl >=2.2 && <2.4,     selective ^>=0.7,     text >=1.2 && <2.2,@@ -86,7 +87,7 @@     QuickCheck >=2.14 && <2.16,     tasty >=1.4 && <1.6,     tasty-hunit ^>=0.10,-    tasty-quickcheck ^>=0.10,+    tasty-quickcheck >=0.10 && <1.12,  common bench-deps   build-depends:@@ -133,6 +134,7 @@     FRP.Rhine.ResamplingBuffer.Util     FRP.Rhine.SN     FRP.Rhine.SN.Combinators+    FRP.Rhine.SN.Type     FRP.Rhine.Schedule     FRP.Rhine.Type @@ -157,7 +159,7 @@     sop-core ^>=0.5,     text >=1.2 && <2.2,     time >=1.8,-    time-domain ^>=0.1.0.2,+    time-domain ^>=1.6,     transformers >=0.5,    -- Directories containing source files.

@@ -148,6 +148,7 @@       ( 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 @@       ( 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 @@       ( runningClock >>> rescaling       , rescaledInitTime       )+  {-# INLINE initClock #-}  -- | A 'RescaledClockM' is trivially a 'RescaledClockS'. rescaledClockMToS ::@@ -242,9 +245,10 @@       ( hoistS monadMorphism runningClock       , initialTime       )+  {-# INLINE initClock #-}  -- | Lift a clock type into a monad transformer.-type LiftClock m t cl = HoistClock m (t m) cl+type LiftClock m t = HoistClock m (t m)  -- | Lift a clock value into a monad transformer. liftClock :: (Monad m, MonadTrans t) => cl -> LiftClock m t cl

@@ -5,6 +5,7 @@ import Control.Exception import Control.Exception qualified as Exception import Control.Monad ((<=<))+import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Functor ((<&>)) import Data.Void @@ -13,7 +14,6 @@  -- mtl import Control.Monad.Error.Class-import Control.Monad.IO.Class (MonadIO, liftIO)  -- time-domain import Data.TimeDomain (TimeDomain)@@ -58,6 +58,7 @@     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 @@               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 @@         errorT :: (MonadError e m) => m (Either e a) -> m a         errorT = (>>= liftEither)     return (runningClock, initTime)+  {-# INLINE initClock #-}  -- * 'DelayException' 

@@ -57,6 +57,7 @@               >>> arrM (\time -> wait step $> (time, ()))           , 0           )+  {-# INLINE initClock #-}  instance GetClockProxy (FixedStep n) 

@@ -52,6 +52,7 @@       ( cycleS (theList cl) >>> withSideEffect wait >>> accumulateWith (+) 0 &&& arr (const ())       , 0       )+  {-# INLINE initClock #-}  instance GetClockProxy (Periodic v) 

@@ -126,6 +126,7 @@       ( runningClock initialTime Nothing       , initialTime       )+  {-# INLINE initClock #-}  instance GetClockProxy (AudioClock rate bufferSize) @@ -155,6 +156,7 @@       ( arr (const (1 / thePureRateNum audioClock)) >>> sumS &&& arr (const ())       , 0       )+  {-# INLINE initClock #-}  instance GetClockProxy (PureAudioClock rate) 

@@ -36,5 +36,6 @@           &&& arr (const ())       , initialTime       )+  {-# INLINE initClock #-}  instance GetClockProxy Busy

@@ -160,6 +160,7 @@           return (time, event)       , initialTime       )+  {-# INLINE initClock #-}  instance GetClockProxy (EventClock event) 

@@ -41,6 +41,7 @@   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) 

@@ -33,5 +33,6 @@       ( constM (liftIO . forever . threadDelay $ 10 ^ 9)       , initialTime       )+  {-# INLINE initClock #-}  instance GetClockProxy Never

@@ -45,6 +45,7 @@           return (time, line)       , initialTime       )+  {-# INLINE initClock #-}  instance GetClockProxy StdinClock 

@@ -64,6 +64,7 @@         (time, tag) <- runningClock -< ()         returnA -< (time,) <$> select tag     return (runningSelectClock, initialTime)+  {-# INLINE initClock #-}  instance GetClockProxy (SelectClock cl a) 

@@ -14,5 +14,6 @@   type Time Trivial = ()   type Tag Trivial = ()   initClock _ = return (arr $ const ((), ()), ())+  {-# INLINE initClock #-}  instance GetClockProxy Trivial

@@ -43,3 +43,4 @@     where       run :: ScheduleT (Diff (Time cl)) m a -> m a       run = runScheduleT scheduleWait+  {-# INLINE initClock #-}

@@ -35,3 +35,4 @@         , sinceInit = absolute `diffTime` initialTime         , ..         }+{-# INLINE genTimeInfo #-}

@@ -1,7 +1,8 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}  {- | Translate clocked signal processing components to stream functions without explicit clock types. @@ -10,9 +11,6 @@ -} module FRP.Rhine.Reactimation.ClockErasure where --- base-import Control.Monad (join)- -- automaton import Data.Automaton.Trans.Reader import Data.Stream.Result (Result (..))@@ -23,7 +21,7 @@ import FRP.Rhine.Clock.Proxy import FRP.Rhine.Clock.Util import FRP.Rhine.ResamplingBuffer-import FRP.Rhine.SN+import FRP.Rhine.SN.Type (SN (..))  {- | Run a clocked signal function as an automaton,    accepting the timestamps and tags as explicit inputs.@@ -39,99 +37,18 @@   runReaderS clsf -< (timeInfo, a) {-# INLINE eraseClockClSF #-} -{- | Run a signal network as an automaton.+{- | Remove the signal network type abstraction and reveal the underlying automaton. -   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.+* 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 ::-  (Monad m, Clock m cl, GetClockProxy cl) =>+  -- | Initial time   Time cl ->+  -- The original signal network   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)-  returnA -< Just b---- 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.-eraseClockSN initialTime (Sequential sn1 resBuf sn2) =-  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)-eraseClockSN initialTime (Parallel snL snR) = 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) =-  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) =-  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) =-  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'')-eraseClockSN initialTime (FirstResampling sn buf) =-  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+eraseClockSN time = flip runReader time . getSN {-# INLINE eraseClockSN #-}  {- | Translate a resampling buffer into an automaton.

@@ -39,11 +39,14 @@ (@@) ::   ( 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 @@ (-->) ::   ( 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 @@   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 @@  -- | 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 @@  -- | 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   ->

@@ -43,7 +43,8 @@ * 'a': The input type * 'b': The output type -}-data ResamplingBuffer m cla clb a b = forall s.+data ResamplingBuffer m cla clb a b+  = forall s.   ResamplingBuffer   { buffer :: s   -- ^ The internal state of the buffer.

@@ -7,13 +7,13 @@ import Control.Monad.Trans.Reader (ReaderT, runReaderT)  -- automaton-import Data.Automaton+import Data.Automaton hiding (toStreamT) import Data.Stream import Data.Stream.Optimized (toStreamT) import Data.Stream.Result (mapResultState)  -- rhine-import FRP.Rhine.ClSF.Core+import FRP.Rhine.ClSF.Core hiding (toStreamT) import FRP.Rhine.ResamplingBuffer  {- | Given a clocked signal function that accepts@@ -39,6 +39,6 @@     clsfBuffer' StreamT {state, step} =       ResamplingBuffer         { buffer = (state, [])-        , put = \ti1 a (s, as) -> return (s, (ti1, a) : as)+        , put = \ti1 a (s, as) -> pure (s, (ti1, a) : as)         , get = \ti2 (s, as) -> mapResultState (,[]) <$> runReaderT (runReaderT (step s) as) ti2         }

@@ -15,7 +15,7 @@ import Data.Stream.Result (Result (..), mapResultState)  -- rhine-import FRP.Rhine.ClSF hiding (step)+import FRP.Rhine.ClSF hiding (step, toStreamT) import FRP.Rhine.Clock import FRP.Rhine.ResamplingBuffer @@ -39,7 +39,7 @@       , get = \theTimeInfo (JointState b s) -> do           Result b' b <- get theTimeInfo b           Result s' c <- step s `runReaderT` b `runReaderT` theTimeInfo-          return $! Result (JointState b' s') c+          pure $! Result (JointState b' s') c       }  infix 1 ^->>@@ -58,7 +58,7 @@     , put = \theTimeInfo a (JointState buf s) -> do       Result s' b <- step s `runReaderT` a `runReaderT` theTimeInfo       buf' <- put theTimeInfo b buf-      return $! JointState buf' s'+      pure $! JointState buf' s'     , get = \theTimeInfo (JointState buf s) -> mapResultState (`JointState` s) <$> get theTimeInfo buf       } @@ -76,11 +76,11 @@   , put = \theTimeInfo (a, c) (JointState s1 s2) -> do       s1' <- put1 theTimeInfo a s1       s2' <- put2 theTimeInfo c s2-      return $! JointState s1' s2'+      pure $! JointState s1' s2'   , get = \theTimeInfo (JointState s1 s2) -> do       Result s1' b <- get1 theTimeInfo s1       Result s2' d <- get2 theTimeInfo s2-      return $! Result (JointState s1' s2') (b, d)+      pure $! Result (JointState s1' s2') (b, d)   }  infixl 4 &-&

@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}  {- |@@ -11,105 +12,151 @@ 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--  -- | 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+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 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 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 #-} -  -- | 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)+-- | 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 #-} -  -- | 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 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 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+-- | 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 #-} -  -- | 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 #-}

@@ -6,11 +6,13 @@ -} module FRP.Rhine.SN.Combinators where +-- base+import Data.Functor ((<&>))+ -- rhine 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 @@ -21,13 +23,7 @@   => 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 +31,28 @@   =>        (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 +61,10 @@   => 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 +82,7 @@   => 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,

@@ -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

@@ -24,7 +24,7 @@ import Control.Monad.Schedule.Class  -- automaton-import Data.Automaton+import Data.Automaton hiding (toStreamT) import Data.Stream.Optimized (OptimizedStreamT (..), toStreamT)  -- rhine@@ -84,7 +84,7 @@ initSchedule cl1 cl2 = do   (runningClock1, initTime) <- initClock cl1   (runningClock2, _) <- initClock cl2-  return+  pure     ( runningSchedule cl1 cl2 runningClock1 runningClock2     , initTime     )@@ -96,7 +96,8 @@ {- | Two clocks can be combined with a schedule as a clock    for an asynchronous sequential composition of signal networks. -}-data SequentialClock cl1 cl2 = (Time cl1 ~ Time cl2) =>+data SequentialClock cl1 cl2+  = (Time cl1 ~ Time cl2) =>   SequentialClock   { sequentialCl1 :: cl1   , sequentialCl2 :: cl2@@ -113,13 +114,15 @@   type Tag (SequentialClock cl1 cl2) = Either (Tag cl1) (Tag cl2)   initClock SequentialClock {..} =     initSchedule sequentialCl1 sequentialCl2+  {-# INLINE initClock #-}  -- ** Parallelly combined clocks  {- | Two clocks can be combined with a schedule as a clock    for an asynchronous parallel composition of signal networks. -}-data ParallelClock cl1 cl2 = (Time cl1 ~ Time cl2) =>+data ParallelClock cl1 cl2+  = (Time cl1 ~ Time cl2) =>   ParallelClock   { parallelCl1 :: cl1   , parallelCl2 :: cl2@@ -136,6 +139,7 @@   type Tag (ParallelClock cl1 cl2) = Either (Tag cl1) (Tag cl2)   initClock ParallelClock {..} =     initSchedule parallelCl1 parallelCl2+  {-# INLINE initClock #-}  -- * Navigating the clock tree 

@@ -29,12 +29,15 @@ -- | The result of a stream, with the type arguments swapped, so it's usable with sop-core newtype RunningResult b state = RunningResult {getRunningResult :: Result state b} +{- HLINT ignore apInjs_NPNonEmpty "Use camelCase" -}+ -- | Transform an n-ary product of at least one type into a nonempty list of all its content. apInjs_NPNonEmpty :: (SListI xs) => NP f (x ': xs) -> NonEmpty (NS f (x ': xs)) apInjs_NPNonEmpty (fx :* fxs) = Z fx :| (S <$> apInjs_NP fxs)  -- | A nonempty list of 'StreamT's, unzipped into their states and their steps.-data Streams m b = forall state (states :: [Type]).+data Streams m b+  = forall state (states :: [Type]).   (SListI states) =>   Streams   { states :: NP I (state ': states)@@ -58,7 +61,7 @@             -- Separate into finished streams and still running streams             & fmap               ( \(finished, running) ->-                  let finishedStates = finished <&> (hliftA (getRunningResult >>> resultState >>> I))+                  let finishedStates = finished <&> hliftA (getRunningResult >>> resultState >>> I)                       outputs =                         finished                           <&> (hliftA (getRunningResult >>> output >>> K) >>> hcollapse)

@@ -71,13 +71,15 @@   , 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 #-}

@@ -102,6 +102,7 @@   type Time FailingClock = UTCTime   type Tag FailingClock = ()   initClock FailingClock = throwE ()+  {-# INLINE initClock #-}  instance GetClockProxy FailingClock