diff --git a/.gitignore b/.gitignore index 9106ef49..234eaadd 100644 --- a/.gitignore +++ b/.gitignore @@ -18,3 +18,4 @@ cabal.sandbox.config .stack-work/ cabal.project.local result +.direnv/ diff --git a/automaton/automaton.cabal b/automaton/automaton.cabal index bdb4781f..68b5bcc5 100644 --- a/automaton/automaton.cabal +++ b/automaton/automaton.cabal @@ -38,6 +38,8 @@ common opts simple-affine-space ^>=0.2, these >=1.1 && <=1.3, transformers >=0.5, + sop-core ^>=0.5, + free >= 5.1, if flag(dev) ghc-options: -Werror @@ -65,6 +67,7 @@ library exposed-modules: Data.Automaton Data.Automaton.Recursive + Data.Automaton.Schedule Data.Automaton.Trans.Accum Data.Automaton.Trans.Except Data.Automaton.Trans.Maybe diff --git a/automaton/src/Data/Automaton.hs b/automaton/src/Data/Automaton.hs index 499d5396..8702185a 100644 --- a/automaton/src/Data/Automaton.hs +++ b/automaton/src/Data/Automaton.hs @@ -46,6 +46,7 @@ import Data.Semialign (Align (..), Semialign (..)) -- automaton import Data.Stream (StreamT (..), fixStream) +import Data.Stream qualified as StreamT import Data.Stream.Internal (JointState (..)) import Data.Stream.Optimized ( OptimizedStreamT (..), @@ -257,6 +258,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)) @@ -374,11 +381,16 @@ embed (Automaton (Stateless m)) = mapM $ runReaderT m -- * Modifying automata --- | Change the output type and effect of an automaton without changing its state type. +-- | Change the input and output type and effect of an automaton without changing its state type. withAutomaton :: (Functor m1, Functor m2) => (forall s. (a1 -> m1 (Result s b1)) -> (a2 -> m2 (Result s b2))) -> Automaton m1 a1 b1 -> Automaton m2 a2 b2 withAutomaton f = Automaton . StreamOptimized.mapOptimizedStreamT (ReaderT . f . runReaderT) . getAutomaton {-# INLINE withAutomaton #-} +-- | Change the output type and effect of an automaton without changing its state type. +withAutomaton_ :: (Functor m1, Functor m2) => (forall s. m1 (Result s b1) -> m2 (Result s b2)) -> Automaton m1 a b1 -> Automaton m2 a b2 +withAutomaton_ f = Automaton . StreamOptimized.mapOptimizedStreamT (mapReaderT f) . getAutomaton +{-# INLINE withAutomaton_ #-} + instance (Monad m) => Profunctor (Automaton m) where dimap f g Automaton {getAutomaton} = Automaton $ g <$> hoist (withReaderT f) getAutomaton lmap f Automaton {getAutomaton} = Automaton $ hoist (withReaderT f) getAutomaton @@ -519,11 +531,24 @@ 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 lastS a = arr Last >>> mappendS >>> arr (getLast >>> fromMaybe a) +{-# INLINE lastS #-} + +-- | Call the monadic action once on the first tick and provide its result indefinitely. +initialised :: (Monad m) => (a -> m b) -> Automaton m a b +initialised = Automaton . Stateful . StreamT.initialised . ReaderT +{-# INLINE initialised #-} + +-- | Like 'initialised_', but ignores the input. +initialised_ :: (Monad m) => m b -> Automaton m a b +initialised_ = initialised . const +{-# INLINE initialised_ #-} diff --git a/automaton/src/Data/Automaton/Schedule.hs b/automaton/src/Data/Automaton/Schedule.hs new file mode 100644 index 00000000..b3ddd660 --- /dev/null +++ b/automaton/src/Data/Automaton/Schedule.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- FIXME haddocks +module Data.Automaton.Schedule where + +-- base +import Control.Arrow +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 ((&)) +import Data.Functor ((<&>)) +import Data.Functor.Compose (Compose (..)) +import Data.Kind (Type) +import Control.Monad.IO.Class (MonadIO) +import Data.Maybe (maybeToList, fromMaybe) + + +import Data.Foldable1 (Foldable1(foldrMap1)) + +-- transformers +import Control.Monad.Trans.Accum (AccumT (..), runAccumT) +import Control.Monad.Trans.Except (ExceptT (..)) +import Control.Monad.Trans.Reader (ReaderT (..)) +import Control.Monad.Trans.Writer.CPS qualified as CPS +import Control.Monad.Trans.Writer.Strict qualified as Strict +import Control.Monad.Trans.Class (MonadTrans (..)) + +-- sop-core +import Data.SOP (I (..), NP (..), SListI, hzipWith, HSequence (htraverse'), hmap, K (..), HCollapse (hcollapse)) + +-- free +import Control.Monad.Trans.Free (FreeT (..), FreeF (..), liftF, iterT) + +-- automaton +import Data.Automaton (Automaton (..), arrM, constM, initialised_, reactimate, withAutomaton_, handleAutomaton, liftS, feedback) +import Data.Automaton.Trans.Except (exceptS) +import Data.Automaton.Trans.Reader (readerS, runReaderS) +import Data.Stream ( StreamT(..), concatS ) +import Data.Stream.Result +import Data.Stream.Optimized (toStreamT, OptimizedStreamT (Stateful)) +import qualified Data.Automaton as Automaton + +class MonadSchedule m where + -- | Run a nonempty list of automata concurrently. + schedule :: NonEmpty (Automaton m a b) -> Automaton m a b + +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 + startStreams = do + output <- newEmptyMVar + input <- newEmptyMVar + forM_ automata $ \automaton -> forkIO $ reactimate $ lastMVarValue input >>> automaton >>> arrM (putMVar output) + return (output, input) + lastMVarValue var = feedback Nothing $ proc ((), aMaybe) -> do + case aMaybe of + Nothing -> do + a <- constM $ readMVar var -< () + returnA -< (a, Just a) + Just a -> do + aNewMaybe <- constM $ tryTakeMVar var -< () + let aNew = fromMaybe a aNewMaybe + returnA -< (aNew, aNewMaybe) + +instance (Monad m, MonadSchedule m) => MonadSchedule (ReaderT r m) where + schedule = + fmap runReaderS + >>> schedule + >>> readerS + +instance (Monad m, MonadSchedule m) => MonadSchedule (ExceptT e m) where + schedule = + fmap exceptS + >>> schedule + >>> withAutomaton_ (fmap sequenceA >>> ExceptT) + +instance (Monoid w, Monad m, MonadSchedule m) => MonadSchedule (CPS.WriterT w m) where + schedule = + fmap (withAutomaton_ (CPS.runWriterT >>> fmap (\(Result s a, w) -> Result s (a, w)))) + >>> schedule + >>> withAutomaton_ (fmap (\(Result s (a, w)) -> (Result s a, w)) >>> CPS.writerT) + +instance (Monoid w, Monad m, MonadSchedule m) => MonadSchedule (Strict.WriterT w m) where + schedule = + fmap (withAutomaton_ (Strict.runWriterT >>> fmap (\(Result s a, w) -> Result s (a, w)))) + >>> schedule + >>> withAutomaton_ (fmap (\(Result s (a, w)) -> (Result s a, w)) >>> Strict.WriterT) + +-- FIXME this needs a unit test +instance (Monoid w, Monad m, MonadSchedule m) => MonadSchedule (AccumT w m) where + schedule = + fmap (withAutomaton_ (runAccumT >>> ReaderT >>> CPS.writerT)) + >>> schedule + >>> withAutomaton_ (CPS.runWriterT >>> runReaderT >>> AccumT) + + +-- FIXME MaybeT, other WriterT +instance MonadSchedule Identity where + schedule = fmap (getAutomaton >>> toStreamT) + >>> foldrMap1 buildStreams consStreams + >>> roundRobinStreams >>> fmap N.toList >>> concatS >>> Stateful >>> Automaton + 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 + } + +-- FIXME take care to reverse & test + +roundRobinStreams :: (Functor m, Applicative m) => Streams m b -> StreamT m (NonEmpty b) +roundRobinStreams Streams {states, steps} = + StreamT + { state = states + , step = \s -> + s + & hzipWith (\Step {getStep} (I s) -> getResultStateT getStep s <&> RunningResult & Compose) steps + & htraverse' getCompose + <&> (\results -> Result + (results & hmap (getRunningResult >>> resultState >>> I)) + (results & hmap (getRunningResult >>> output >>> K) & hnonemptycollapse)) + } + +hnonemptycollapse :: SListI as => NP (K b) (a ': as) -> NonEmpty b +hnonemptycollapse (K a :* as) = a :| hcollapse as + +-- | 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) + } + +-- | 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} + +-- * 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 + , step = \s -> ReaderT $ \a -> do + oneTick <- runFreeT $ getYieldT $ runReaderT s a + 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 + +yield :: Monad m => YieldT m () +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 diff --git a/automaton/src/Data/Stream.hs b/automaton/src/Data/Stream.hs index 822e8d8d..24df1d7b 100644 --- a/automaton/src/Data/Stream.hs +++ b/automaton/src/Data/Stream.hs @@ -103,6 +103,17 @@ constM :: (Functor m) => m a -> StreamT m a constM ma = StreamT () $ const $ Result () <$> ma {-# INLINE constM #-} +-- | Call the monadic action once on the first tick and provide its result indefinitely. +initialised :: (Monad m) => m a -> StreamT m a +initialised action = + let step mr@(Just r) = pure $! Result mr r + step Nothing = (step . Just =<< action) + in StreamT + { state = Nothing + , step + } +{-# INLINE initialised #-} + instance (Functor m) => Functor (StreamT m) where fmap f StreamT {state, step} = StreamT state $! fmap (fmap f) <$> step {-# INLINE fmap #-} @@ -232,6 +243,8 @@ withStreamT f StreamT {state, step} = StreamT state $ fmap f step This function lets a stream control the speed at which it produces data, since it can decide to produce any amount of output at every step. -} +-- FIXME this reverses? doc? +-- FIXME generalise to traversable? concatS :: (Monad m) => StreamT m [a] -> StreamT m a concatS StreamT {state, step} = StreamT diff --git a/automaton/src/Data/Stream/Result.hs b/automaton/src/Data/Stream/Result.hs index cb9461f6..17a7dabc 100644 --- a/automaton/src/Data/Stream/Result.hs +++ b/automaton/src/Data/Stream/Result.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE StrictData #-} module Data.Stream.Result where @@ -15,7 +17,7 @@ This type is used in streams and automata to encode the result of a state transi The new state should always be strict to avoid space leaks. -} data Result s a = Result {resultState :: s, output :: ~a} - deriving (Functor) + deriving (Functor, Foldable, Traversable) instance Bifunctor Result where second = fmap diff --git a/flake.lock b/flake.lock index 44e5fee5..5bc45dde 100644 --- a/flake.lock +++ b/flake.lock @@ -1,25 +1,5 @@ { "nodes": { - "monad-schedule": { - "inputs": { - "nixpkgs": [ - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1731107003, - "narHash": "sha256-au6hQM8V4lZtYiwYZl88pAr7xNtFit3pQR0AXvUTuyo=", - "owner": "turion", - "repo": "monad-schedule", - "rev": "f6651c56975bd9e126b9d1d5c8eed0a304d38a30", - "type": "github" - }, - "original": { - "owner": "turion", - "repo": "monad-schedule", - "type": "github" - } - }, "nixpkgs": { "locked": { "lastModified": 1731745710, @@ -38,7 +18,6 @@ }, "root": { "inputs": { - "monad-schedule": "monad-schedule", "nixpkgs": "nixpkgs" } } diff --git a/flake.nix b/flake.nix index 257e9771..af454b87 100644 --- a/flake.nix +++ b/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 ]; diff --git a/rhine-examples/rhine-examples.cabal b/rhine-examples/rhine-examples.cabal index 11adc71b..48efe1b9 100644 --- a/rhine-examples/rhine-examples.cabal +++ b/rhine-examples/rhine-examples.cabal @@ -1,3 +1,4 @@ +cabal-version: 2.2 name: rhine-examples version: 1.5 synopsis: Some simple example applications with rhine @@ -5,7 +6,7 @@ description: Diverse console example applications with rhine that show some of the standard components. -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Manuel Bärenz maintainer: programming@manuelbaerenz.de @@ -13,11 +14,9 @@ maintainer: programming@manuelbaerenz.de category: FRP build-type: Simple extra-doc-files: ChangeLog.md -cabal-version: 2.0 -executable HelloWorld +common opts hs-source-dirs: src - main-is: HelloWorld.hs ghc-options: -Wall -threaded @@ -29,155 +28,69 @@ executable HelloWorld rhine ^>=1.5 default-language: Haskell2010 - default-extensions: TypeOperators + default-extensions: + Arrows + DataKinds + OverloadedStrings + RankNTypes + TypeOperators if flag(dev) ghc-options: -Werror +executable HelloWorld + import: opts + main-is: HelloWorld.hs + executable Demonstration - hs-source-dirs: src + import: opts main-is: Demonstration.hs - ghc-options: - -Wall - -threaded - -rtsopts - -with-rtsopts=-N - - build-depends: - base >=4.16 && <4.21, - rhine ^>=1.5 - - default-language: Haskell2010 - default-extensions: TypeOperators - - if flag(dev) - ghc-options: -Werror executable ADSR - hs-source-dirs: src + import: opts main-is: ADSR.hs - ghc-options: - -Wall - -threaded - -rtsopts - -with-rtsopts=-N - - build-depends: - base >=4.16 && <4.21, - rhine ^>=1.5 - - default-language: Haskell2010 - default-extensions: TypeOperators - - if flag(dev) - ghc-options: -Werror executable Ball - hs-source-dirs: src + import: opts main-is: Ball.hs - ghc-options: - -Wall - -threaded - -rtsopts - -with-rtsopts=-N build-depends: - base >=4.16 && <4.21, - random >=1.1, - rhine ^>=1.5 - - default-language: Haskell2010 - default-extensions: - Arrows - DataKinds - RankNTypes - TypeFamilies - TypeOperators - - if flag(dev) - ghc-options: -Werror + random >=1.1 executable Periodic - hs-source-dirs: src + import: opts main-is: Periodic.hs - ghc-options: - -Wall - -threaded - -rtsopts - -with-rtsopts=-N build-depends: - base >=4.16 && <4.21, - monad-schedule >=0.1, - rhine ^>=1.5, - transformers >=0.5 - - default-language: Haskell2010 - default-extensions: TypeOperators - - if flag(dev) - ghc-options: -Werror + transformers >=0.5, + automaton executable EventClock - hs-source-dirs: src + import: opts main-is: EventClock.hs - ghc-options: - -Wall - -threaded - -rtsopts - -with-rtsopts=-N build-depends: - base >=4.16 && <4.21, - random >=1.1, - rhine ^>=1.5 - - default-language: Haskell2010 - default-extensions: TypeOperators - - if flag(dev) - ghc-options: -Werror + random >=1.1 executable Sawtooth - hs-source-dirs: src + import: opts main-is: Sawtooth.hs - ghc-options: - -Wall - -threaded - -rtsopts - -with-rtsopts=-N - - build-depends: - base >=4.16 && <4.21, - rhine ^>=1.5 - - default-language: Haskell2010 - default-extensions: TypeOperators - - if flag(dev) - ghc-options: -Werror executable RandomWalk - hs-source-dirs: src + import: opts main-is: RandomWalk.hs - ghc-options: - -Wall - -threaded - -rtsopts - -with-rtsopts=-N build-depends: - base >=4.16 && <4.21, random >=1.1, - rhine ^>=1.5, simple-affine-space - default-language: Haskell2010 - default-extensions: - TypeOperators +executable Accum + import: opts + main-is: Accum.hs + build-depends: + transformers, + text - if flag(dev) - ghc-options: -Werror flag dev description: Enable warnings as errors. Active on ci. diff --git a/rhine-examples/src/Accum.hs b/rhine-examples/src/Accum.hs new file mode 100644 index 00000000..0e977bf6 --- /dev/null +++ b/rhine-examples/src/Accum.hs @@ -0,0 +1,38 @@ +-- | 'AccumT' example + +-- base +import Control.Monad (void) +import Control.Monad.IO.Class + +-- transformers +import Control.Monad.Trans.Accum (AccumT, runAccumT, add, look) + +-- text +import Data.Text (Text, pack) + +-- rhine +import FRP.Rhine hiding (add) + +personalMessage :: ClSF (AccumT [Text] IO) (Lifting StdinClock) () () +personalMessage = tagS >>> arrMCl (pure >>> add) + +type Lifting = LiftClock IO (AccumT [Text]) +type EveryTwoSeconds = Lifting (Millisecond 2000) + +everyTwoSeconds :: EveryTwoSeconds +everyTwoSeconds = liftClock waitClock + +logSoFar :: ClSF (AccumT [Text] IO) EveryTwoSeconds () () +logSoFar = sinceStart >>> arrMCl printLog + where + printLog t = do + add ["Time since start: " <> pack (show t)] + l <- look + liftIO $ do + putStrLn "Log so far:" + print l + +main :: IO () +main = do + putStrLn "You can add a personal message to the log." + void $ flip runAccumT [] $ flow $ personalMessage @@ liftClock StdinClock |@| logSoFar @@ everyTwoSeconds diff --git a/rhine-examples/src/Periodic.hs b/rhine-examples/src/Periodic.hs index 1cd77630..f7099277 100644 --- a/rhine-examples/src/Periodic.hs +++ b/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 diff --git a/rhine-gloss/ChangeLog.md b/rhine-gloss/ChangeLog.md index a54d19ea..73d377ff 100644 --- a/rhine-gloss/ChangeLog.md +++ b/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. diff --git a/rhine-gloss/rhine-gloss.cabal b/rhine-gloss/rhine-gloss.cabal index 4347d04a..f2540eb8 100644 --- a/rhine-gloss/rhine-gloss.cabal +++ b/rhine-gloss/rhine-gloss.cabal @@ -41,7 +41,6 @@ library base >=4.16 && <4.21, gloss >=1.12, mmorph >=1.1, - monad-schedule >=0.1, rhine ^>=1.5, transformers >=0.5 diff --git a/rhine-gloss/src/FRP/Rhine/Gloss/IO.hs b/rhine-gloss/src/FRP/Rhine/Gloss/IO.hs index a59ee7cf..8f6fe491 100644 --- a/rhine-gloss/src/FRP/Rhine/Gloss/IO.hs +++ b/rhine-gloss/src/FRP/Rhine/Gloss/IO.hs @@ -47,9 +47,8 @@ import Control.Monad.Trans.Reader -- gloss import Graphics.Gloss.Interface.IO.Game --- monad-schedule -import Control.Monad.Schedule.Class -import Control.Monad.Schedule.FreeAsync +-- automaton +import Data.Automaton.Schedule -- rhine import FRP.Rhine @@ -68,30 +67,32 @@ data GlossEnv = GlossEnv , timeRef :: IORef Float } -{- | Effects in the gloss backend +{- | Effects in the gloss backend. -* Wraps the concurrent variables needed for communication with the @gloss@ backend. -* Adds the 'FreeAsyncT' concurrency layer for fairer scheduling +Wraps the concurrent variables needed for communication with the @gloss@ backend. -} newtype GlossConcT m a = GlossConcT - {unGlossConcT :: ReaderT GlossEnv (FreeAsyncT m) a} + {unGlossConcT :: ReaderT GlossEnv m a} deriving (Functor, Applicative, Monad, MonadIO) -- | When @gloss@ is the only effect you are using, use this monad to simplify your type signatures. type GlossConc = GlossConcT IO instance MonadTrans GlossConcT where - lift = GlossConcT . lift . lift + lift = GlossConcT . lift -- FIXME MFunctor & MMonad instances pending https://github.com/HeinrichApfelmus/operational/pull/28/ -- | Remove the 'GlossConcT' transformer by explicitly providing an environment. runGlossConcT :: (MonadIO m) => GlossConcT m a -> GlossEnv -> m a -runGlossConcT ma env = runFreeAsyncT $ runReaderT (unGlossConcT ma) env +runGlossConcT ma = runReaderT (unGlossConcT ma) -- | Disregards scheduling capabilities of @m@, as it uses 'FreeAsync'. -instance (MonadIO m) => MonadSchedule (GlossConcT m) where - schedule actions = GlossConcT $ fmap (second $ map GlossConcT) $ schedule $ unGlossConcT <$> actions +instance (MonadIO m, MonadSchedule m) => MonadSchedule (GlossConcT m) where + schedule = + fmap (hoistS unGlossConcT) + >>> schedule + >>> hoistS GlossConcT withPicRef :: (MonadIO m) => @@ -130,10 +131,11 @@ instance (MonadIO m) => Clock (GlossConcT m) GlossEventClockIO where where getEvent = do GlossEnv {eventVar, timeRef} <- GlossConcT ask - event <- GlossConcT $ lift $ asyncMVar eventVar liftIO $ do + event <- takeMVar eventVar time <- readIORef timeRef return (time, event) + {-# INLINE initClock #-} instance GetClockProxy GlossEventClockIO @@ -152,7 +154,8 @@ instance (MonadIO m) => Clock (GlossConcT m) GlossSimClockIO where where getTime = GlossConcT $ do GlossEnv {timeVar} <- ask - lift $ asyncMVar timeVar + liftIO $ takeMVar timeVar + {-# INLINE initClock #-} instance GetClockProxy GlossSimClockIO @@ -264,7 +267,7 @@ glossConcTClock :: (MonadIO m) => cl -> GlossConcTClock m cl glossConcTClock unhoistedClock = HoistClock { unhoistedClock - , monadMorphism = GlossConcT . lift . freeAsync + , monadMorphism = GlossConcT . liftIO } {- | Lift an 'IO' clock to 'GlossConc'. diff --git a/rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs b/rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs index 465ac3a7..59228764 100644 --- a/rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs +++ b/rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs @@ -30,14 +30,12 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Control.Monad.Trans.Writer.Strict --- monad-schedule -import Control.Monad.Schedule.Class -import Control.Monad.Schedule.Yield - -- automaton import Data.Automaton.Trans.Except (performOnFirstSample) import qualified Data.Automaton.Trans.Reader as AutomatonReader import qualified Data.Automaton.Trans.Writer as AutomatonWriter +import Data.Automaton.Schedule + ( MonadSchedule(..), YieldT, runYieldT, yield ) -- rhine import FRP.Rhine @@ -53,7 +51,7 @@ newtype GlossM a = GlossM {unGlossM :: YieldT (ReaderT (Float, Maybe Event) (Wri -- Would have liked to make this a derived instance, but for some reason deriving gets thrown off by the newtype instance MonadSchedule GlossM where - schedule actions = fmap (fmap (fmap GlossM)) $ GlossM $ schedule $ fmap unGlossM actions + schedule = fmap (hoistS unGlossM) >>> schedule >>> hoistS GlossM -- | Add a picture to the canvas. paint :: Picture -> GlossM () @@ -82,7 +80,8 @@ instance Semigroup GlossClock where 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) + initClock _ = return (constM (GlossM (yield >> lift ask)) >>> (sumS *** Category.id), 0) + {-# INLINE initClock #-} instance GetClockProxy GlossClock diff --git a/rhine-terminal/rhine-terminal.cabal b/rhine-terminal/rhine-terminal.cabal index 03b33b56..04e7f3f6 100644 --- a/rhine-terminal/rhine-terminal.cabal +++ b/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 diff --git a/rhine-terminal/src/FRP/Rhine/Terminal.hs b/rhine-terminal/src/FRP/Rhine/Terminal.hs index 475a5422..08f7978a 100644 --- a/rhine-terminal/src/FRP/Rhine/Terminal.hs +++ b/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 @@ -53,6 +51,7 @@ instance (MonadInput m, MonadIO m) => Clock m TerminalEventClock where return (time, event) , initialTime ) + {-# INLINE initClock #-} instance GetClockProxy TerminalEventClock diff --git a/rhine/ChangeLog.md b/rhine/ChangeLog.md index e14d7e5e..d8b351c3 100644 --- a/rhine/ChangeLog.md +++ b/rhine/ChangeLog.md @@ -1,5 +1,13 @@ # 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`. +* 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` diff --git a/rhine/rhine.cabal b/rhine/rhine.cabal index a9dc9a42..ac622c38 100644 --- a/rhine/rhine.cabal +++ b/rhine/rhine.cabal @@ -50,7 +50,6 @@ common opts build-depends: automaton ^>=1.5, base >=4.16 && <4.21, - monad-schedule ^>=0.2, mtl >=2.2 && <2.4, selective ^>=0.7, text >=1.2 && <2.2, @@ -117,7 +116,7 @@ library FRP.Rhine.Clock.Realtime.Stdin FRP.Rhine.Clock.Select FRP.Rhine.Clock.Trivial - FRP.Rhine.Clock.Unschedule + FRP.Rhine.Clock.Unyield FRP.Rhine.Clock.Util FRP.Rhine.Reactimation FRP.Rhine.Reactimation.ClockErasure @@ -133,13 +132,13 @@ library FRP.Rhine.ResamplingBuffer.Util FRP.Rhine.SN FRP.Rhine.SN.Combinators + FRP.Rhine.SN.Type FRP.Rhine.Schedule FRP.Rhine.Type 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: @@ -154,7 +153,6 @@ library profunctors ^>=5.6, random >=1.1, simple-affine-space ^>=0.2, - sop-core ^>=0.5, text >=1.2 && <2.2, time >=1.8, time-domain ^>=0.1.0.2, diff --git a/rhine/src/FRP/Rhine.hs b/rhine/src/FRP/Rhine.hs index bfac455a..94ead890 100644 --- a/rhine/src/FRP/Rhine.hs +++ b/rhine/src/FRP/Rhine.hs @@ -45,7 +45,6 @@ import FRP.Rhine.Clock.Realtime.Never as X 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.ResamplingBuffer.ClSF as X import FRP.Rhine.ResamplingBuffer.Collect as X diff --git a/rhine/src/FRP/Rhine/Clock.hs b/rhine/src/FRP/Rhine/Clock.hs index f9f526b8..52dd5aed 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,9 +245,10 @@ 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 +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 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..da8790c4 100644 --- a/rhine/src/FRP/Rhine/Clock/FixedStep.hs +++ b/rhine/src/FRP/Rhine/Clock/FixedStep.hs @@ -13,19 +13,16 @@ module FRP.Rhine.Clock.FixedStep where -- base import Control.Arrow -import Data.Functor (($>)) import Data.Maybe (fromMaybe) +import Control.Monad (replicateM_) import GHC.TypeLits -- vector-sized import Data.Vector.Sized (Vector, fromList) --- monad-schedule -import Control.Monad.Schedule.Class -import Control.Monad.Schedule.Trans (ScheduleT, wait) - -- automaton -import Data.Automaton (accumulateWith, arrM) +import Data.Automaton (accumulateWith, constM) +import Data.Automaton.Schedule (yield, YieldT) -- rhine import FRP.Rhine.Clock @@ -46,17 +43,18 @@ data FixedStep (n :: Nat) where stepsize :: FixedStep n -> Integer stepsize fixedStep@FixedStep = natVal fixedStep -instance (MonadSchedule m, Monad m) => Clock (ScheduleT Integer m) (FixedStep n) where +instance (Monad m) => Clock (YieldT m) (FixedStep n) where type Time (FixedStep n) = Integer type Tag (FixedStep n) = () initClock cl = let step = stepsize cl in return - ( arr (const step) + ( constM (replicateM_ (fromIntegral step) yield) >>> arr (const step) >>> accumulateWith (+) 0 - >>> arrM (\time -> wait step $> (time, ())) + >>> arr (,()) , 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..5603279c 100644 --- a/rhine/src/FRP/Rhine/Clock/Periodic.hs +++ b/rhine/src/FRP/Rhine/Clock/Periodic.hs @@ -18,12 +18,12 @@ module FRP.Rhine.Clock.Periodic (Periodic (Periodic)) where import Control.Arrow import Data.List.NonEmpty hiding (unfold) import GHC.TypeLits (KnownNat, Nat, natVal) - --- monad-schedule -import Control.Monad.Schedule.Trans +import Control.Monad (replicateM_) -- automaton -import Data.Automaton (Automaton (..), accumulateWith, concatS, withSideEffect) +import Data.Automaton + ( Automaton(..), accumulateWith, concatS, arrM ) +import Data.Automaton.Schedule (YieldT (..), yield) -- rhine import FRP.Rhine.Clock @@ -41,17 +41,20 @@ import FRP.Rhine.Clock.Proxy data Periodic (v :: [Nat]) where Periodic :: Periodic (n : ns) +-- FIXME need to extend YieldT in order to make this work again correctly (using the step sizes) + instance (Monad m, NonemptyNatList v) => - Clock (ScheduleT Integer m) (Periodic v) + Clock (YieldT m) (Periodic v) where type Time (Periodic v) = Integer type Tag (Periodic v) = () initClock cl = return - ( cycleS (theList cl) >>> withSideEffect wait >>> accumulateWith (+) 0 &&& arr (const ()) + ( cycleS (theList cl) >>> accumulateWith (+) 0 &&& arrM (\i -> replicateM_ (fromIntegral i) yield) , 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..0276a8d3 100644 --- a/rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs +++ b/rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs @@ -18,10 +18,9 @@ import Data.Time.Clock -- rhine 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 Data.Automaton (count) {- | A clock ticking every 'n' milliseconds, in real time. @@ -35,15 +34,24 @@ The tag of this clock is 'Maybe Double', where 'Nothing' represents successful realtime, and @'Just' lag@ a lag (in seconds). -} -newtype Millisecond (n :: Nat) = Millisecond (WaitUTCClock IO (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)) +newtype Millisecond (n :: Nat) = Millisecond (WaitUTCClock IO (RescaledClock (CountClock n) Double)) -instance Clock IO (Millisecond n) where +-- FIXME Annoying we're using UnyieldClock only to satisfy this instance. Maybe drop it and add here as well? +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 snd)) + {-# INLINE initClock #-} instance GetClockProxy (Millisecond n) -- | Tries to achieve real time by using 'waitUTC', see its docs. waitClock :: (KnownNat n) => Millisecond n -waitClock = Millisecond $ waitUTC $ RescaledClock (unyieldClock FixedStep) ((/ 1000) . fromInteger) +waitClock = Millisecond $ waitUTC $ RescaledClock CountClock ((/ 1000) . fromInteger) + +data CountClock (n :: Nat) = CountClock + +instance (Monad m, KnownNat n) => Clock m (CountClock n) where + type Time (CountClock n) = Integer + type Tag (CountClock n) = () + initClock cl = return (count >>> arr ((* natVal cl) >>> (, ())), 0) 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 deleted file mode 100644 index 06193188..00000000 --- a/rhine/src/FRP/Rhine/Clock/Unschedule.hs +++ /dev/null @@ -1,45 +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 diff --git a/rhine/src/FRP/Rhine/Clock/Unyield.hs b/rhine/src/FRP/Rhine/Clock/Unyield.hs new file mode 100644 index 00000000..10e7667e --- /dev/null +++ b/rhine/src/FRP/Rhine/Clock/Unyield.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE UndecidableInstances #-} +module FRP.Rhine.Clock.Unyield where +import FRP.Rhine.Clock (Clock (..)) +import Data.Automaton.Schedule (YieldT, runYieldT) +import Data.Automaton (hoistS) +import Data.TimeDomain (TimeDomain) + +newtype UnyieldClock cl = UnyieldClock {getUnyieldClock :: cl} + +instance (TimeDomain (Time cl), Clock (YieldT m) cl, Monad m) => Clock m (UnyieldClock cl) where + type Time (UnyieldClock cl) = Time cl + type Tag (UnyieldClock cl) = Tag cl + + initClock UnyieldClock {getUnyieldClock} = do + (runningClock, initialTime) <- runYieldT $ initClock getUnyieldClock + return (hoistS runYieldT runningClock + , initialTime) + {-# INLINE initClock #-} 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 #-} diff --git a/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs b/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs index 344e197e..0d1ad888 100644 --- a/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs +++ b/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs @@ -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 @@ 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 (..)) @@ -23,7 +21,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.SN.Type (SN (..)) {- | Run a clocked signal function as an automaton, accepting the timestamps and tags as explicit inputs. @@ -39,99 +37,18 @@ eraseClockClSF proxy initialTime clsf = proc (time, tag, a) -> do 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. diff --git a/rhine/src/FRP/Rhine/Reactimation/Combinators.hs b/rhine/src/FRP/Rhine/Reactimation/Combinators.hs index c0acc54f..0b8572f5 100644 --- a/rhine/src/FRP/Rhine/Reactimation/Combinators.hs +++ b/rhine/src/FRP/Rhine/Reactimation/Combinators.hs @@ -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.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 c78e9bd7..f439ecde 100644 --- a/rhine/src/FRP/Rhine/SN/Combinators.hs +++ b/rhine/src/FRP/Rhine/SN/Combinators.hs @@ -6,11 +6,13 @@ Combinators for composing signal networks sequentially and parallely. -} 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 @@ 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 +31,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 +61,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 +82,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/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/Schedule.hs b/rhine/src/FRP/Rhine/Schedule.hs index d2dbbbc4..0cfb6592 100644 --- a/rhine/src/FRP/Rhine/Schedule.hs +++ b/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, @@ -20,37 +20,21 @@ module FRP.Rhine.Schedule where import Control.Arrow import Data.List.NonEmpty as N --- monad-schedule -import Control.Monad.Schedule.Class - -- automaton import Data.Automaton -import Data.Stream.Optimized (OptimizedStreamT (..), toStreamT) +import Data.Automaton.Schedule -- 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 :: @@ -113,6 +97,7 @@ instance type Tag (SequentialClock cl1 cl2) = Either (Tag cl1) (Tag cl2) initClock SequentialClock {..} = initSchedule sequentialCl1 sequentialCl2 + {-# INLINE initClock #-} -- ** Parallelly combined clocks @@ -136,6 +121,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/src/FRP/Rhine/Schedule/Internal.hs b/rhine/src/FRP/Rhine/Schedule/Internal.hs index 263fb446..1c02fc79 100644 --- a/rhine/src/FRP/Rhine/Schedule/Internal.hs +++ b/rhine/src/FRP/Rhine/Schedule/Internal.hs @@ -1,9 +1,12 @@ {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} module FRP.Rhine.Schedule.Internal where -- base import Control.Arrow +import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar) +import Control.Monad (forM_) import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Functor.Compose (Compose (..)) @@ -19,8 +22,18 @@ import Data.SOP (HCollapse (hcollapse), HSequence (htraverse'), I (..), K (K), N -- monad-schedule import Control.Monad.Schedule.Class +-- transformers +import Control.Monad.Trans.Accum (AccumT) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT (..)) +import Control.Monad.Trans.Reader (ReaderT (..), ask) +import Control.Monad.Trans.Writer.CPS (WriterT, runWriterT, writerT) + -- automaton +import Control.Monad.Morph (MFunctor (hoist)) +import Data.Automaton (Automaton (..)) import Data.Stream hiding (concatS) +import Data.Stream.Optimized (OptimizedStreamT (..), toStreamT) import Data.Stream.Result -- | One step of a stream, with the state type argument going last, so it is usable with sop-core. @@ -29,6 +42,8 @@ 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 apInjs_NPNonEmpty ignore "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) @@ -58,7 +73,7 @@ scheduleStreams Streams {states, steps} = -- 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) @@ -83,3 +98,42 @@ scheduleStreams' = scheduleStreams . foldrMap1 buildStreams consStreams { states = I state :* states , steps = Step (ResultStateT step) :* steps } + +schedIO' :: NonEmpty (StreamT IO a) -> StreamT IO a +schedIO' streams = initialising startStreams `comp` constM (ask >>= (lift . takeMVar)) + where + startStreams = do + var <- newEmptyMVar + forM_ streams $ forkIO . reactimate . (`comp` constM (ask >>= (lift . putMVar var))) + return var + +schedExcept' :: (Monad m) => (forall x. NonEmpty (StreamT m x) -> StreamT m x) -> NonEmpty (StreamT (ExceptT e m) a) -> StreamT (ExceptT e m) a +schedExcept' sched streams = + streams + <&> exceptS + & sched + & withStreamT (fmap sequenceA >>> ExceptT) + +schedWriter :: (Monad m, Monoid w) => (forall x. NonEmpty (StreamT m x) -> StreamT m x) -> NonEmpty (StreamT (WriterT w m) a) -> StreamT (WriterT w m) a +schedWriter sched = + fmap (withStreamT (runWriterT >>> fmap (\(Result s a, w) -> Result s (a, w)))) + >>> sched + >>> withStreamT (fmap (\(Result s (a, w)) -> (Result s a, w)) >>> writerT) + +schedAccum :: (Monad m, Monoid w) => (forall x. NonEmpty (StreamT m x) -> StreamT m x) -> NonEmpty (StreamT (AccumT w m) a) -> StreamT (AccumT w m) a +schedAccum sched = _ + +schedReader :: (Monad m) => (forall x. NonEmpty (StreamT m x) -> StreamT m x) -> NonEmpty (StreamT (ReaderT r m) a) -> StreamT (ReaderT r m) a +schedReader sched = fmap (withStreamT _) >>> _ + +initialising :: (Applicative m, Monad m) => m r -> StreamT m r +initialising action = + let step mr@(Just r) = pure $! Result mr r + step Nothing = (step . Just =<< action) + in StreamT + { state = Nothing + , step + } + +comp :: (Monad m) => StreamT m r -> StreamT (ReaderT r m) a -> StreamT m a +comp smr srma = toStreamT $ hoist (`runReaderT` ()) $ getAutomaton $ Automaton (Stateful $ hoist lift smr) >>> Automaton (Stateful srma) diff --git a/rhine/src/FRP/Rhine/Type.hs b/rhine/src/FRP/Rhine/Type.hs index 291a02c4..03a2e6e8 100644 --- a/rhine/src/FRP/Rhine/Type.hs +++ b/rhine/src/FRP/Rhine/Type.hs @@ -71,13 +71,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 #-} 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 diff --git a/rhine/test/Schedule.hs b/rhine/test/Schedule.hs index bd13f00e..80156cdd 100644 --- a/rhine/test/Schedule.hs +++ b/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) diff --git a/rhine/test/Util.hs b/rhine/test/Util.hs index 6fece5f4..3e7c8f33 100644 --- a/rhine/test/Util.hs +++ b/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 ()))