WIP

automaton/src/Data/Automaton/Schedule.hs

@@ -8,8 +8,8 @@ module Data.Automaton.Schedule where
 
 -- base
 import Control.Arrow
-import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar, tryTakeMVar)
-import Control.Monad (forM_)
+import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar, tryTakeMVar, readMVar)
+import Control.Monad (forM_, void)
 import Data.List.NonEmpty as N
 import Control.Monad.Identity (Identity (..))
 import Data.Function ((&))
@@ -52,6 +52,7 @@ class MonadSchedule m where
 instance MonadSchedule IO where
   schedule automata = proc a -> do
     (output, input) <- initialised_ startStreams -< ()
+    arrM $ void . tryTakeMVar -< input
     arrM $ uncurry putMVar -< (input, a)
     arrM takeMVar -< output
     where
@@ -63,7 +64,7 @@ instance MonadSchedule IO where
       lastMVarValue var = feedback Nothing $ proc ((), aMaybe) -> do
         case aMaybe of
           Nothing -> do
-            a <- constM $ takeMVar var -< ()
+            a <- constM $ readMVar var -< ()
             returnA -< (a, Just a)
           Just a -> do
             aNewMaybe <- constM $ tryTakeMVar var -< ()
@@ -102,7 +103,7 @@ instance (Monoid w, Monad m, MonadSchedule m) => MonadSchedule (AccumT w m) wher
       >>> withAutomaton_ (CPS.runWriterT >>> runReaderT >>> AccumT)
 
 
--- FIXME MaybeT, andere WriterT
+-- FIXME MaybeT, other WriterT
 instance MonadSchedule Identity where
   schedule = fmap (getAutomaton >>> toStreamT)
      >>> foldrMap1 buildStreams consStreams
@@ -152,9 +153,13 @@ 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}
 
+-- * Symbolic yielding/suspension operation
+
 newtype YieldT m a = YieldT {getYieldT :: FreeT Identity m a}
   deriving newtype (Functor, Applicative, Monad, MonadTrans, MonadIO)
 
+type Yield = YieldT Identity
+
 yieldAutomaton :: (Functor m, Monad m) => Automaton (YieldT m) a b -> Automaton m a (Maybe b)
 yieldAutomaton = handleAutomaton $ \StreamT {state, step} -> StreamT
   {state = step state
@@ -163,7 +168,7 @@ yieldAutomaton = handleAutomaton $ \StreamT {state, step} -> StreamT
       return $ case oneTick of
         Pure (Result s' b) -> Result (step s') (Just b)
         Free (Identity cont) -> Result (lift $ YieldT cont) Nothing
-  }
+  }-- FIXME Could do without do. Or maybe just use applicative do?
 
 instance (Monad m, MonadSchedule m) => MonadSchedule (YieldT m) where
   schedule = fmap yieldAutomaton >>> schedule >>> fmap maybeToList >>> Automaton.concatS >>> liftS
@@ -173,3 +178,9 @@ yield = YieldT $ liftF $ pure ()
 
 runYieldT :: Monad m => YieldT m a -> m a
 runYieldT = iterT runIdentity . getYieldT
+
+runYieldTWith :: Monad m => m () -> YieldT m a -> m a
+runYieldTWith action = iterT (\ima -> action >> runIdentity ima) . getYieldT
+
+runYield :: Yield a -> a
+runYield = runIdentity . runYieldT

automaton/src/Data/Stream.hs

@@ -36,7 +36,6 @@ import Data.Align
 -- automaton
 import Data.Stream.Internal
 import Data.Stream.Result
-import Debug.Trace (trace)
 
 -- * Creating streams
 
@@ -254,9 +253,9 @@ concatS StreamT {state, step} =
     }
   where
     go (s, []) = do
-      Result s' as <- trace "step concat" $ step s
+      Result s' as <- step s
       go (s', as)
-    go (s, a : as) = trace "return concat" $ return $ Result (s, as) a
+    go (s, a : as) = return $ Result (s, as) a
 {-# INLINE concatS #-}
 
 -- ** Exception handling

flake.nix

@@ -13,10 +13,6 @@
 
   inputs = {
     nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable-small";
-    monad-schedule = {
-      url = "github:turion/monad-schedule";
-      inputs.nixpkgs.follows = "nixpkgs";
-    };
   };
 
   outputs = inputs:
@@ -64,9 +60,6 @@
                 }
                 { };
             })
-            (hfinal: hprev: lib.optionalAttrs prev.stdenv.isDarwin {
-              monad-schedule = dontCheck hprev.monad-schedule;
-            })
             (hfinal: hprev: lib.optionalAttrs (lib.versionOlder hprev.ghc.version "9.4") {
               time-domain = doJailbreak hprev.time-domain;
             })
@@ -144,7 +137,6 @@
 
       overlay = lib.composeManyExtensions
         [
-          inputs.monad-schedule.overlays.default
           localOverlay
         ];
 

rhine-examples/src/Periodic.hs

@@ -4,11 +4,12 @@
 -- transformers
 import Control.Monad.IO.Class
 
--- monad-schedule
-import Control.Monad.Schedule.Trans
+-- automaton
+import Data.Automaton.Schedule (YieldT, runYieldTWith)
 
 -- rhine
 import FRP.Rhine
+import Control.Concurrent (threadDelay)
 
 type MyClock = Periodic '[500, 1000]
 
@@ -17,8 +18,8 @@ everyNowAndThen =
   sinceInitS >>> proc time ->
     returnA -< unwords ["It's now", show time, "o'clock."]
 
-mainRhine :: (MonadIO m) => Rhine (ScheduleT Integer m) MyClock () ()
+mainRhine :: (MonadIO m) => Rhine (YieldT m) MyClock () ()
 mainRhine = everyNowAndThen >-> arrMCl (liftIO . putStrLn) @@ Periodic
 
 main :: IO ()
-main = runScheduleIO $ flow mainRhine
+main = runYieldTWith (threadDelay 1000) $ flow mainRhine

rhine-gloss/ChangeLog.md

@@ -1,5 +1,11 @@
 # Revision history for rhine-gloss
 
+## Upcoming
+
+* Remove dependency on `monad-schedule` because of performance problems.
+  See https://github.com/turion/rhine/issues/377.
+* Revert scheduling in the `IO` backend to `IO`.
+
 ## 1.4
 
 * Use `FreeAsyncT` in the gloss IO backend for fairer concurrency.

rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs

@@ -43,8 +43,6 @@ import FRP.Rhine
 -- rhine-gloss
 import FRP.Rhine.Gloss.Common
 
-import Debug.Trace (trace)
-
 -- * @gloss@ effects
 
 -- | A pure monad in which all effects caused by the @gloss@ backend take place.
@@ -127,7 +125,7 @@ flowGloss GlossSettings {..} rhine =
     worldAutomaton :: WorldAutomaton
     worldAutomaton = AutomatonWriter.runWriterS $ AutomatonReader.runReaderS $ hoistS (runYieldT . unGlossM) $ performOnFirstSample $ eraseClock rhine
     stepWith :: (Float, Maybe Event) -> (WorldAutomaton, Picture) -> (WorldAutomaton, Picture)
-    stepWith (diff, eventMaybe) (automaton, _) = let Result automaton' (picture, _) = trace "stepWith" $ runIdentity $ stepAutomaton automaton ((diff, eventMaybe), ()) in (automaton', picture)
+    stepWith (diff, eventMaybe) (automaton, _) = let Result automaton' (picture, _) = runIdentity $ stepAutomaton automaton ((diff, eventMaybe), ()) in (automaton', picture)
     getPic (_, pic) = pic
     handleEvent event = stepWith (0, Just event)
     simStep diff = stepWith (diff, Nothing)

rhine-terminal/rhine-terminal.cabal

@@ -29,11 +29,11 @@ library
   build-depends:
     base >=4.16 && <4.21,
     exceptions >=0.10.4,
-    monad-schedule >=0.1.2,
     rhine ^>=1.5,
     terminal >=0.2.0.0,
     time >=1.9.3,
-    transformers >=0.5
+    transformers >=0.5,
+    automaton ^>=1.5
 
   hs-source-dirs: src
   default-language: Haskell2010

rhine-terminal/src/FRP/Rhine/Terminal.hs

@@ -31,11 +31,9 @@ import System.Terminal.Internal (Terminal)
 -- transformers
 import Control.Monad.Trans.Reader
 
--- monad-schedule
-import Control.Monad.Schedule.Class
-
 -- rhine
 import FRP.Rhine
+import Data.Automaton.Schedule (MonadSchedule)
 
 -- | A clock that ticks whenever events or interrupts on the terminal arrive.
 data TerminalEventClock = TerminalEventClock

rhine/ChangeLog.md

@@ -1,5 +1,11 @@
 # Revision history for rhine
 
+## Upcoming
+
+* 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`.
+
 ## 1.5
 
 * Added `forever` utility for recursion in `ClSFExcept`

rhine/src/FRP/Rhine/Clock/FixedStep.hs

@@ -14,21 +14,22 @@ module FRP.Rhine.Clock.FixedStep where
 -- base
 import Control.Arrow
 import Data.Maybe (fromMaybe)
+import Control.Monad (replicateM_)
 import GHC.TypeLits
 
 -- vector-sized
 import Data.Vector.Sized (Vector, fromList)
 
 -- automaton
 import Data.Automaton (accumulateWith, constM)
+import Data.Automaton.Schedule (yield, YieldT)
 
 -- rhine
 import FRP.Rhine.Clock
 import FRP.Rhine.Clock.Proxy
 import FRP.Rhine.ResamplingBuffer
 import FRP.Rhine.ResamplingBuffer.Collect
 import FRP.Rhine.ResamplingBuffer.Util
-import Data.Automaton.Schedule (yield, YieldT)
 
 {- | A pure (side effect free) clock with fixed step size,
    i.e. ticking at multiples of 'n'.
@@ -48,7 +49,7 @@ instance (Monad m) => Clock (YieldT m) (FixedStep n) where
   initClock cl =
     let step = stepsize cl
      in return
-          ( constM yield >>> arr (const step)
+          ( constM (replicateM_ (fromIntegral step) yield) >>> arr (const step)
               >>> accumulateWith (+) 0
               >>> arr (,())
           , 0

rhine/src/FRP/Rhine/Clock/Periodic.hs

@@ -18,9 +18,11 @@ module FRP.Rhine.Clock.Periodic (Periodic (Periodic)) where
 import Control.Arrow
 import Data.List.NonEmpty hiding (unfold)
 import GHC.TypeLits (KnownNat, Nat, natVal)
+import Control.Monad (replicateM_)
 
 -- automaton
-import Data.Automaton (Automaton (..), accumulateWith, concatS, constM)
+import Data.Automaton
+    ( Automaton(..), accumulateWith, concatS, constM, arrM )
 import Data.Automaton.Schedule (YieldT (..), yield)
 
 -- rhine
@@ -49,7 +51,7 @@ instance
   type Tag (Periodic v) = ()
   initClock cl =
     return
-      ( cycleS (theList cl) >>> accumulateWith (+) 0 &&& constM yield
+      ( cycleS (theList cl) >>> accumulateWith (+) 0 &&& arrM (\i -> replicateM_ (fromIntegral i) yield)
       , 0
       )
 

rhine/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,

rhine/test/Schedule.hs

@@ -13,9 +13,6 @@ import Test.Tasty
 -- tasty-hunit
 import Test.Tasty.HUnit
 
--- monad-schedule
-import Control.Monad.Schedule.Trans (Schedule, runScheduleT, wait)
-
 -- automaton
 import Data.Automaton (accumulateWith, constM, embed)
 

rhine/test/Util.hs

@@ -1,22 +1,13 @@
 module Util where
 
--- base
-import Data.Functor.Identity (Identity (runIdentity))
-
--- monad-schedule
-import Control.Monad.Schedule.Trans (Schedule, runScheduleT)
-
 -- rhine
 import FRP.Rhine
+import Data.Automaton.Schedule (Yield, runYield)
 
-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 Yield cl, GetClockProxy cl) => Rhine Yield cl a b -> [a] -> [Maybe b]
+runScheduleRhinePure rhine = runYield . 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 ()))