diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,7 +1,10 @@ # Revision history for rhine -## Upcoming +## 1.8 +* Remove dependency on `monad-schedule` because of performance problems. + See https://github.com/turion/rhine/issues/377. +* Added scheduling for automata in `Data.Automaton.Schedule`. * Removed `SN` GADT in favour of semantic functions, for a > 100x speedup in some benchmarks (https://github.com/turion/rhine/pull/348) diff --git a/rhine.cabal b/rhine.cabal --- a/rhine.cabal +++ b/rhine.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: rhine -version: 1.7 +version: 1.8 synopsis: Functional Reactive Programming with type-level clocks description: Rhine is a library for synchronous and asynchronous Functional Reactive Programming (FRP). @@ -31,8 +31,6 @@ test/assets/*.txt tested-with: - ghc ==9.2 - ghc ==9.4 ghc ==9.6 ghc ==9.8 ghc ==9.10 @@ -49,14 +47,13 @@ common opts build-depends: - automaton ^>=1.7, - base >=4.16 && <4.22, - monad-schedule ^>=1.7, + automaton ^>=1.8, + base >=4.18 && <4.22, mtl >=2.2 && <2.4, selective ^>=0.7, text >=1.2 && <2.2, time >=1.8, - time-domain ^>=1.7, + time-domain ^>=1.8, transformers >=0.5, vector-sized >=1.4, @@ -118,8 +115,8 @@ FRP.Rhine.Clock.Realtime.Never FRP.Rhine.Clock.Realtime.Stdin FRP.Rhine.Clock.Select + FRP.Rhine.Clock.Skip FRP.Rhine.Clock.Trivial - FRP.Rhine.Clock.Unschedule FRP.Rhine.Clock.Util FRP.Rhine.Reactimation FRP.Rhine.Reactimation.ClockErasure @@ -142,7 +139,6 @@ other-modules: FRP.Rhine.ClSF.Except.Util FRP.Rhine.ClSF.Random.Util - FRP.Rhine.Schedule.Internal -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -157,7 +153,6 @@ profunctors ^>=5.6, random >=1.1, simple-affine-space ^>=0.2, - sop-core ^>=0.5, text >=1.2 && <2.2, time >=1.8, transformers >=0.5, diff --git a/src/FRP/Rhine.hs b/src/FRP/Rhine.hs --- a/src/FRP/Rhine.hs +++ b/src/FRP/Rhine.hs @@ -13,30 +13,21 @@ module FRP.Rhine (module X) where -- time-domain -import Data.TimeDomain as X -- automaton import Data.Automaton as X import Data.Stream.Result as X (Result (..)) +import Data.TimeDomain as X -- rhine import Data.VectorSpace as X import FRP.Rhine.ClSF as X import FRP.Rhine.Clock as X -import FRP.Rhine.Clock.Proxy as X -import FRP.Rhine.Clock.Util as X -import FRP.Rhine.Reactimation as X -import FRP.Rhine.Reactimation.Combinators as X -import FRP.Rhine.ResamplingBuffer as X -import FRP.Rhine.ResamplingBuffer.Util as X -import FRP.Rhine.SN as X -import FRP.Rhine.SN.Combinators as X -import FRP.Rhine.Schedule as X -import FRP.Rhine.Type as X -- rhine (components) import FRP.Rhine.Clock.FixedStep as X import FRP.Rhine.Clock.Periodic as X +import FRP.Rhine.Clock.Proxy as X import FRP.Rhine.Clock.Realtime.Audio as X import FRP.Rhine.Clock.Realtime.Busy as X import FRP.Rhine.Clock.Realtime.Event as X @@ -45,8 +36,10 @@ import FRP.Rhine.Clock.Realtime.Stdin as X import FRP.Rhine.Clock.Select as X import FRP.Rhine.Clock.Trivial as X -import FRP.Rhine.Clock.Unschedule as X - +import FRP.Rhine.Clock.Util as X +import FRP.Rhine.Reactimation as X +import FRP.Rhine.Reactimation.Combinators as X +import FRP.Rhine.ResamplingBuffer as X import FRP.Rhine.ResamplingBuffer.ClSF as X import FRP.Rhine.ResamplingBuffer.Collect as X import FRP.Rhine.ResamplingBuffer.FIFO as X @@ -54,3 +47,8 @@ import FRP.Rhine.ResamplingBuffer.KeepLast as X import FRP.Rhine.ResamplingBuffer.LIFO as X import FRP.Rhine.ResamplingBuffer.Timeless as X +import FRP.Rhine.ResamplingBuffer.Util as X +import FRP.Rhine.SN as X +import FRP.Rhine.SN.Combinators as X +import FRP.Rhine.Schedule as X +import FRP.Rhine.Type as X diff --git a/src/FRP/Rhine/Clock.hs b/src/FRP/Rhine/Clock.hs --- a/src/FRP/Rhine/Clock.hs +++ b/src/FRP/Rhine/Clock.hs @@ -103,25 +103,25 @@ type Rescaling cl time = Time cl -> time {- | An effectful morphism of time domains is a Kleisli arrow. - It can use a side effect to rescale a point in one time domain - into another one. + It can use a side effect to rescale a point in one time domain + into another one. -} type RescalingM m cl time = Time cl -> m time {- | An effectful, stateful morphism of time domains is an 'Automaton' - that uses side effects to rescale a point in one time domain - into another one. + that uses side effects to rescale a point in one time domain + into another one. -} type RescalingS m cl time tag = Automaton m (Time cl, Tag cl) (time, tag) {- | Like 'RescalingS', but allows for an initialisation - of the rescaling morphism, together with the initial time. + of the rescaling morphism, together with the initial time. -} type RescalingSInit m cl time tag = Time cl -> m (RescalingS m cl time tag, time) {- | Convert an effectful morphism of time domains into a stateful one with initialisation. - Think of its type as @RescalingM m cl time -> RescalingSInit m cl time tag@, - although this type is ambiguous. + Think of its type as @RescalingM m cl time -> RescalingSInit m cl time tag@, + although this type is ambiguous. -} rescaleMToSInit :: (Monad m) => @@ -146,14 +146,14 @@ type Tag (RescaledClock cl time) = Tag cl initClock (RescaledClock cl f) = do (runningClock, initTime) <- initClock cl - return + pure ( 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. + we can transform one time domain into the other with an effectful morphism. -} data RescaledClockM m cl time = RescaledClockM { unscaledClockM :: cl @@ -171,7 +171,7 @@ initClock RescaledClockM {..} = do (runningClock, initTime) <- initClock unscaledClockM rescaledInitTime <- rescaleM initTime - return + pure ( runningClock >>> first (arrM rescaleM) , rescaledInitTime ) @@ -182,11 +182,11 @@ rescaledClockToM RescaledClock {..} = RescaledClockM { unscaledClockM = unscaledClock - , rescaleM = return . rescale + , rescaleM = pure . rescale } {- | Instead of a mere function as morphism of time domains, - we can transform one time domain into the other with an automaton. + we can transform one time domain into the other with an automaton. -} data RescaledClockS m cl time tag = RescaledClockS { unscaledClockS :: cl @@ -206,7 +206,7 @@ initClock RescaledClockS {..} = do (runningClock, initTime) <- initClock unscaledClockS (rescaling, rescaledInitTime) <- rescaleS initTime - return + pure ( runningClock >>> rescaling , rescaledInitTime ) @@ -244,7 +244,7 @@ type Tag (HoistClock m1 m2 cl) = Tag cl initClock HoistClock {..} = do (runningClock, initialTime) <- monadMorphism $ initClock unhoistedClock - return + pure ( hoistS monadMorphism runningClock , initialTime ) diff --git a/src/FRP/Rhine/Clock/FixedStep.hs b/src/FRP/Rhine/Clock/FixedStep.hs --- a/src/FRP/Rhine/Clock/FixedStep.hs +++ b/src/FRP/Rhine/Clock/FixedStep.hs @@ -13,23 +13,17 @@ -- base import Control.Arrow -import Data.Functor (($>)) -import Data.Maybe (fromMaybe) import GHC.TypeLits --- vector-sized +-- automaton +import Data.Automaton (accumulateWith, constM) +import Data.Automaton.Schedule.Trans (ScheduleT, wait) +import Data.Maybe (fromMaybe) import Data.Vector.Sized (Vector, fromList) --- monad-schedule -import Control.Monad.Schedule.Class -import Control.Monad.Schedule.Trans (ScheduleT, wait) - -- time-domain import Data.TimeDomain (Seconds (..)) --- automaton -import Data.Automaton (accumulateWith, arrM) - -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy @@ -38,9 +32,9 @@ import FRP.Rhine.ResamplingBuffer.Util {- | A pure (side effect free) clock with fixed step size, - i.e. ticking at multiples of 'n'. - The tick rate is in the type signature, - which prevents composition of signals at different rates. + i.e. ticking at multiples of 'n'. + The tick rate is in the type signature, + which prevents composition of signals at different rates. -} data FixedStep (n :: Nat) where FixedStep :: (KnownNat n) => FixedStep n -- TODO Does the constraint bring any benefit? @@ -49,15 +43,16 @@ stepsize :: FixedStep n -> Seconds Integer stepsize fixedStep@FixedStep = Seconds $ natVal fixedStep -instance (MonadSchedule m, Monad m) => Clock (ScheduleT (Seconds Integer) m) (FixedStep n) where +instance (Monad m) => Clock (ScheduleT (Seconds Integer) m) (FixedStep n) where type Time (FixedStep n) = Seconds Integer type Tag (FixedStep n) = () initClock cl = let step = stepsize cl - in return - ( arr (const step) + in pure + ( constM (wait (fromIntegral step)) + >>> arr (const step) >>> accumulateWith (+) 0 - >>> arrM (\time -> wait step $> (time, ())) + >>> arr (,()) , 0 ) {-# INLINE initClock #-} @@ -68,7 +63,7 @@ type Count = FixedStep 1 {- | Resample into a 'FixedStep' clock that ticks @n@ times slower, - by collecting all values into a vector. + by collecting all values into a vector. -} downsampleFixedStep :: (KnownNat n, Monad m) => diff --git a/src/FRP/Rhine/Clock/Periodic.hs b/src/FRP/Rhine/Clock/Periodic.hs --- a/src/FRP/Rhine/Clock/Periodic.hs +++ b/src/FRP/Rhine/Clock/Periodic.hs @@ -16,30 +16,33 @@ -- base import Control.Arrow -import Data.List.NonEmpty hiding (unfold) -import GHC.TypeLits (KnownNat, Nat, natVal) --- monad-schedule -import Control.Monad.Schedule.Trans +-- automaton +import Data.Automaton ( + Automaton (..), + accumulateWith, + arrM, + concatS, + ) +import Data.Automaton.Schedule.Trans (ScheduleT, wait) +import Data.List.NonEmpty hiding (unfold) -- time-domain import Data.TimeDomain (Seconds (..)) --- automaton -import Data.Automaton (Automaton (..), accumulateWith, concatS, withSideEffect) - -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy +import GHC.TypeLits (KnownNat, Nat, natVal) -- * The 'Periodic' clock {- | A clock whose tick lengths cycle through - a (nonempty) list of type-level natural numbers. - E.g. @Periodic '[1, 2]@ ticks at times 1, 3, 4, 5, 7, 8, etc. + a (nonempty) list of type-level natural numbers. + E.g. @Periodic '[1, 2]@ ticks at times 1, 3, 4, 5, 7, 8, etc. - The waiting side effect is formal, in 'ScheduleT'. - You can use e.g. 'runScheduleIO' to produce an actual delay. + The waiting side effect is formal, in 'ScheduleT'. + You can use e.g. 'runScheduleIO' to produce an actual delay. -} data Periodic (v :: [Nat]) where Periodic :: Periodic (n : ns) @@ -51,8 +54,8 @@ type Time (Periodic v) = Seconds Integer type Tag (Periodic v) = () initClock cl = - return - ( cycleS (theList cl) >>> withSideEffect wait >>> accumulateWith (+) 0 &&& arr (const ()) + pure + ( cycleS (theList cl) >>> accumulateWith (+) 0 &&& arrM (wait . fromIntegral) , 0 ) {-# INLINE initClock #-} diff --git a/src/FRP/Rhine/Clock/Realtime/Millisecond.hs b/src/FRP/Rhine/Clock/Realtime/Millisecond.hs --- a/src/FRP/Rhine/Clock/Realtime/Millisecond.hs +++ b/src/FRP/Rhine/Clock/Realtime/Millisecond.hs @@ -10,20 +10,22 @@ -- base import Control.Arrow (arr, first, second, (>>>)) -import Data.Functor ((<&>)) -import GHC.TypeLits -- time + +-- rhine + +import Data.Automaton (count) +import Data.Functor ((<&>)) import Data.Time.Clock -- rhine import Data.TimeDomain (Seconds (..)) import FRP.Rhine.Clock -import FRP.Rhine.Clock.FixedStep import FRP.Rhine.Clock.Proxy import FRP.Rhine.Clock.Realtime (WaitUTCClock, waitUTC) -import FRP.Rhine.Clock.Unschedule +import GHC.TypeLits {- | A clock ticking every 'n' milliseconds, in real time. @@ -37,9 +39,9 @@ where 'Nothing' represents successful realtime, and @'Just' lag@ a lag (in seconds). -} -newtype Millisecond (n :: Nat) = Millisecond (WaitUTCClock IO (RescaledClock (UnscheduleClock IO (FixedStep n)) (Seconds Double))) +newtype Millisecond (n :: Nat) = Millisecond (WaitUTCClock IO (RescaledClock (CountClock n) (Seconds Double))) -instance Clock IO (Millisecond n) where +instance (KnownNat n) => Clock IO (Millisecond n) where type Time (Millisecond n) = UTCTime type Tag (Millisecond n) = Maybe Double initClock (Millisecond cl) = initClock cl <&> first (>>> arr (second (fmap getSeconds . snd))) @@ -49,4 +51,11 @@ -- | Tries to achieve real time by using 'waitUTC', see its docs. waitClock :: (KnownNat n) => Millisecond n -waitClock = Millisecond $ waitUTC $ RescaledClock (unyieldClock FixedStep) ((/ 1000) . fromInteger . getSeconds) +waitClock = Millisecond $ waitUTC $ RescaledClock CountClock ((/ 1000) . fromInteger . getSeconds) + +data CountClock (n :: Nat) = CountClock + +instance (Monad m, KnownNat n) => Clock m (CountClock n) where + type Time (CountClock n) = Seconds Integer + type Tag (CountClock n) = () + initClock cl = pure (count >>> arr ((* natVal cl) >>> Seconds >>> (,())), 0) diff --git a/src/FRP/Rhine/Clock/Skip.hs b/src/FRP/Rhine/Clock/Skip.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Rhine/Clock/Skip.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE UndecidableInstances #-} + +module FRP.Rhine.Clock.Skip where + +import Data.Automaton (hoistS) +import Data.Automaton.Schedule.Trans (SkipT, runSkipT) +import Data.TimeDomain (TimeDomain) +import FRP.Rhine.Clock (Clock (..)) + +newtype SkipClock cl = SkipClock {getSkipClock :: cl} + +instance (TimeDomain (Time cl), Clock (SkipT m) cl, Monad m) => Clock m (SkipClock cl) where + type Time (SkipClock cl) = Time cl + type Tag (SkipClock cl) = Tag cl + + initClock SkipClock {getSkipClock} = do + (runningClock, initialTime) <- runSkipT $ initClock getSkipClock + pure + ( hoistS runSkipT runningClock + , initialTime + ) + {-# INLINE initClock #-} diff --git a/src/FRP/Rhine/Clock/Unschedule.hs b/src/FRP/Rhine/Clock/Unschedule.hs deleted file mode 100644 --- a/src/FRP/Rhine/Clock/Unschedule.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} - --- | A clock that removes the 'ScheduleT' transformer from the stack by interpreting its actions in a monad -module FRP.Rhine.Clock.Unschedule where - --- base -import Control.Arrow -import Control.Concurrent qualified as Concurrent (yield) -import Control.Monad.IO.Class - --- monad-schedule -import Control.Monad.Schedule.Trans - --- automaton -import Data.Automaton (hoistS) - --- time-domain -import Data.TimeDomain (Diff, TimeDomain) - --- rhine -import FRP.Rhine.Clock - -{- | If @cl@ is a 'Clock' in 'ScheduleT diff m', apply 'UnscheduleClock' - to get a clock in 'm'. --} -data UnscheduleClock m cl = UnscheduleClock - { scheduleClock :: cl - , scheduleWait :: Diff (Time cl) -> m () - } - -{- | Remove a 'ScheduleT' layer from the monad transformer stack of the clock. - -The 'yield' action is interpreted as thread yielding in 'IO'. --} -unyieldClock :: cl -> UnscheduleClock IO cl -unyieldClock cl = UnscheduleClock cl $ const $ liftIO Concurrent.yield - -instance (TimeDomain (Time cl), Clock (ScheduleT (Diff (Time cl)) m) cl, Monad m) => Clock m (UnscheduleClock m cl) where - type Tag (UnscheduleClock _ cl) = Tag cl - type Time (UnscheduleClock _ cl) = Time cl - initClock UnscheduleClock {scheduleClock, scheduleWait} = run $ first (hoistS run) <$> initClock scheduleClock - where - run :: ScheduleT (Diff (Time cl)) m a -> m a - run = runScheduleT scheduleWait - {-# INLINE initClock #-} diff --git a/src/FRP/Rhine/Schedule.hs b/src/FRP/Rhine/Schedule.hs --- a/src/FRP/Rhine/Schedule.hs +++ b/src/FRP/Rhine/Schedule.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {- | -The 'MonadSchedule' class from the @monad-schedule@ package is the compatibility mechanism between two different clocks. +The 'MonadSchedule' class is the compatibility mechanism between two different clocks. It implements a concurrency abstraction that allows the clocks to run at the same time, independently. Several such clocks running together form composite clocks, such as 'ParallelClock' and 'SequentialClock'. This module defines these composite clocks, @@ -18,39 +18,23 @@ -- base import Control.Arrow -import Data.List.NonEmpty as N --- monad-schedule -import Control.Monad.Schedule.Class - -- automaton import Data.Automaton hiding (toStreamT) -import Data.Stream.Optimized (OptimizedStreamT (..), toStreamT) +import Data.Automaton.Schedule +import Data.List.NonEmpty as N -- rhine import FRP.Rhine.Clock -import FRP.Rhine.Schedule.Internal -- * Scheduling -{- | Run several automata concurrently. - -Whenever one automaton outputs a value, -it is returned together with all other values that happen to be output at the same time. --} -scheduleList :: (Monad m, MonadSchedule m) => NonEmpty (Automaton m a b) -> Automaton m a (NonEmpty b) -scheduleList automatons0 = - Automaton $ - Stateful $ - scheduleStreams' $ - toStreamT . getAutomaton <$> automatons0 - {- | Run two automata concurrently. Whenever one automaton returns a value, it is returned. -} schedulePair :: (Monad m, MonadSchedule m) => Automaton m a b -> Automaton m a b -> Automaton m a b -schedulePair automatonL automatonR = concatS $ fmap toList $ scheduleList $ automatonL :| [automatonR] +schedulePair automatonL automatonR = schedule $ automatonL :| [automatonR] -- | Run two running clocks concurrently. runningSchedule :: @@ -68,8 +52,8 @@ runningSchedule _ _ rc1 rc2 = schedulePair (rc1 >>> arr (second Left)) (rc2 >>> arr (second Right)) {- | A schedule implements a combination of two clocks. - It outputs a time stamp and an 'Either' value, - which specifies which of the two subclocks has ticked. + It outputs a time stamp and an 'Either' value, + which specifies which of the two subclocks has ticked. -} initSchedule :: ( Time cl1 ~ Time cl2 @@ -94,7 +78,7 @@ -- ** Sequentially combined clocks {- | Two clocks can be combined with a schedule as a clock - for an asynchronous sequential composition of signal networks. + for an asynchronous sequential composition of signal networks. -} data SequentialClock cl1 cl2 = (Time cl1 ~ Time cl2) => @@ -119,7 +103,7 @@ -- ** Parallelly combined clocks {- | Two clocks can be combined with a schedule as a clock - for an asynchronous parallel composition of signal networks. + for an asynchronous parallel composition of signal networks. -} data ParallelClock cl1 cl2 = (Time cl1 ~ Time cl2) => @@ -156,7 +140,7 @@ Out cl = cl {- | A tree representing possible last times to which - the constituents of a clock may have ticked. + the constituents of a clock may have ticked. -} data LastTime cl where SequentialLastTime :: @@ -180,7 +164,7 @@ ParClockRefl :: ParClockInclusion cl cl {- | Generates a tag for the composite clock from a tag of a leaf clock, - given a parallel clock inclusion. + given a parallel clock inclusion. -} parClockTagInclusion :: ParClockInclusion clS cl -> Tag clS -> Tag cl parClockTagInclusion (ParClockInL parClockInL) tag = parClockTagInclusion parClockInL $ Left tag diff --git a/src/FRP/Rhine/Schedule/Internal.hs b/src/FRP/Rhine/Schedule/Internal.hs deleted file mode 100644 --- a/src/FRP/Rhine/Schedule/Internal.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} - -module FRP.Rhine.Schedule.Internal where - --- base -import Control.Arrow -import Data.Function ((&)) -import Data.Functor ((<&>)) -import Data.Functor.Compose (Compose (..)) -import Data.Kind (Type) -import Data.List.NonEmpty as N - --- foldable1-classes-compat -import Data.Foldable1 (Foldable1 (foldrMap1)) - --- sop-core -import Data.SOP (HCollapse (hcollapse), HSequence (htraverse'), I (..), K (K), NP (..), NS (..), SListI, apInjs_NP, hliftA, hzipWith, unI) - --- monad-schedule -import Control.Monad.Schedule.Class - --- automaton -import Data.Stream hiding (concatS) -import Data.Stream.Result - --- | One step of a stream, with the state type argument going last, so it is usable with sop-core. -newtype Step m b state = Step {getStep :: ResultStateT state m b} - --- | 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]). - (SListI states) => - Streams - { states :: NP I (state ': states) - , steps :: NP (Step m b) (state ': states) - } - --- | Run 'Streams' concurrently by scheduling them in 'MonadSchedule'. -scheduleStreams :: (MonadSchedule m, Functor m, Applicative m) => Streams m b -> StreamT m (NonEmpty b) -scheduleStreams Streams {states, steps} = - StreamT - { state = (apInjs_NPNonEmpty states, []) -- All the initial states and no currently running continuations - , step = - -- Some streams have not started yet, or just finished their step. Others are still running. - \(restingStates, runningStreams) -> - -- Start all currently not running streams by zipping each with its step - fmap (htraverse' getCompose . hzipWith (\Step {getStep} -> Compose . fmap RunningResult . getResultStateT getStep . unI) steps) restingStates - -- Append all already running states to the freshly started ones - & flip appendList runningStreams - -- Schedule all running streams concurrently - & schedule - -- Separate into finished streams and still running streams - & fmap - ( \(finished, running) -> - let finishedStates = finished <&> hliftA (getRunningResult >>> resultState >>> I) - outputs = - finished - <&> (hliftA (getRunningResult >>> output >>> K) >>> hcollapse) - in Result (finishedStates, running) outputs - ) - } - --- | Run a nonempty list of streams concurrently. -scheduleStreams' :: (MonadSchedule m, Applicative m) => NonEmpty (StreamT m b) -> StreamT m (NonEmpty b) -scheduleStreams' = scheduleStreams . foldrMap1 buildStreams consStreams - where - buildStreams :: StreamT m b -> Streams m b - buildStreams StreamT {state, step} = - Streams - { states = I state :* Nil - , steps = Step (ResultStateT step) :* Nil - } - - consStreams :: StreamT m b -> Streams m b -> Streams m b - consStreams StreamT {state, step} Streams {states, steps} = - Streams - { states = I state :* states - , steps = Step (ResultStateT step) :* steps - } diff --git a/test/Clock/FixedStep.hs b/test/Clock/FixedStep.hs --- a/test/Clock/FixedStep.hs +++ b/test/Clock/FixedStep.hs @@ -34,9 +34,25 @@ output = runScheduleRhinePure ((absoluteS @@ (FixedStep @3)) |@| (absoluteS @@ (FixedStep @5))) $ replicate 6 () in output @?= Just <$> [3, 5, 6, 9, 10, 12] - , testCase "Resamples correctly" $ + , testCase "Resamples correctly (downsampleFixedStep)" $ let output = fmap (fmap (first toList)) $ runScheduleRhinePure ((absoluteS @@ (FixedStep @3)) >-- downsampleFixedStep --> ((clId &&& absoluteS) @@ (FixedStep @12))) $ replicate 10 () + in + output + @?= [ Nothing + , Nothing + , Nothing + , Nothing + , Just ([12, 9, 6, 3], 12) + , Nothing + , Nothing + , Nothing + , Nothing + , Just ([24, 21, 18, 15], 24) + ] + , testCase "Resamples correctly (collect)" $ + let + output = runScheduleRhinePure ((absoluteS @@ (FixedStep @3)) >-- collect --> ((clId &&& absoluteS) @@ (FixedStep @12))) $ replicate 10 () in output @?= [ Nothing diff --git a/test/Schedule.hs b/test/Schedule.hs --- a/test/Schedule.hs +++ b/test/Schedule.hs @@ -2,52 +2,34 @@ module Schedule where --- base -import Control.Arrow ((>>>)) -import Data.Functor (($>)) -import Data.Functor.Identity - -- tasty import Test.Tasty -- tasty-hunit import Test.Tasty.HUnit --- monad-schedule -import Control.Monad.Schedule.Trans (Schedule, runScheduleT, wait) - -- time-domain import Data.TimeDomain (Seconds) -- automaton -import Data.Automaton (accumulateWith, constM, embed) +import Data.Automaton (embed) +import Data.Automaton.Schedule.Trans (Schedule, evalSchedule) -- rhine -import FRP.Rhine.Clock (Clock (initClock), RunningClockInit) -import FRP.Rhine.Clock.FixedStep (FixedStep (FixedStep)) -import FRP.Rhine.Schedule -import Util +import FRP.Rhine (FixedStep (..), ParallelClock (..), initClock, runningSchedule) +import FRP.Rhine.Clock (RunningClockInit) tests = testGroup "Schedule" [ testGroup - "scheduleList" - [ testCase "schedule waits chronologically" $ do - let output = runIdentity $ runScheduleT (const (pure ())) $ embed (scheduleList $ (\n -> constM (wait n $> n) >>> accumulateWith (+) 0) <$> [3 :: Seconds Integer, 5]) $ replicate 6 () - output @?= pure <$> [3, 5, 6, 9, 10, 12] - , testCase "schedule waits chronologically (mirrored)" $ do - let output = runSchedule $ embed (scheduleList $ (\n -> constM (wait n $> n) >>> accumulateWith (+) 0) <$> [5 :: Seconds Integer, 3]) $ replicate 6 () - output @?= pure <$> [3, 5, 6, 9, 10, 12] - ] - , testGroup - "runningSchedule" + "scheduling running clocks" [ testCase "chronological ticks" $ do let clA = FixedStep @5 clB = FixedStep @3 - (runningClockA, _) = runSchedule (initClock clA :: RunningClockInit (Schedule (Seconds Integer)) (Seconds Integer) ()) - (runningClockB, _) = runSchedule (initClock clB :: RunningClockInit (Schedule (Seconds Integer)) (Seconds Integer) ()) - output = runSchedule $ embed (runningSchedule clA clB runningClockA runningClockB) $ replicate 6 () + (runningClockA, _) = evalSchedule (initClock clA :: RunningClockInit (Schedule (Seconds Integer)) (Seconds Integer) ()) + (runningClockB, _) = evalSchedule (initClock clB :: RunningClockInit (Schedule (Seconds Integer)) (Seconds Integer) ()) + output = evalSchedule $ embed (runningSchedule clA clB runningClockA runningClockB) $ replicate 6 () output @?= [ (3, Right ()) , (5, Left ()) @@ -60,9 +42,8 @@ , testGroup "ParallelClock" [ testCase "chronological ticks" $ do - let - (runningClock, _time) = runSchedule (initClock $ ParallelClock (FixedStep @5) (FixedStep @3) :: RunningClockInit (Schedule (Seconds Integer)) (Seconds Integer) (Either () ())) - output = runSchedule $ embed runningClock $ replicate 6 () + let (runningClock, _time) = evalSchedule (initClock (ParallelClock (FixedStep @5) (FixedStep @3)) :: RunningClockInit (Schedule (Seconds Integer)) (Seconds Integer) (Either () ())) + output = evalSchedule $ embed runningClock $ replicate 6 () output @?= [ (3, Right ()) , (5, Left ()) diff --git a/test/Util.hs b/test/Util.hs --- a/test/Util.hs +++ b/test/Util.hs @@ -1,22 +1,15 @@ module Util where --- base -import Data.Functor.Identity (Identity (runIdentity)) - --- monad-schedule -import Control.Monad.Schedule.Trans (Schedule, runScheduleT) +-- automaton +import Data.Automaton.Schedule.Trans (Schedule, evalSchedule) -- rhine import FRP.Rhine -runScheduleRhinePure :: (Clock (Schedule (Diff (Time cl))) cl, GetClockProxy cl) => Rhine (Schedule (Diff (Time cl))) cl a b -> [a] -> [Maybe b] -runScheduleRhinePure rhine = runSchedule . runRhine rhine +runScheduleRhinePure :: (Clock (Schedule (Seconds Integer)) cl, GetClockProxy cl) => Rhine (Schedule (Seconds Integer)) cl a b -> [a] -> [Maybe b] +runScheduleRhinePure rhine = evalSchedule . runRhine rhine runRhine :: (Clock m cl, GetClockProxy cl, Monad m) => Rhine m cl a b -> [a] -> m [Maybe b] runRhine rhine input = do automaton <- eraseClock rhine embed automaton input - --- FIXME Move to monad-schedule -runSchedule :: Schedule diff a -> a -runSchedule = runIdentity . runScheduleT (const (pure ()))