From 36c2c1fd3ad894ab849605a52badc0bf5c190da5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Mon, 5 Feb 2024 17:53:26 +0100 Subject: [PATCH 01/12] Clean up benchmarks --- rhine/bench/WordCount.hs | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/rhine/bench/WordCount.hs b/rhine/bench/WordCount.hs index 6a90fb161..0af29bc6c 100644 --- a/rhine/bench/WordCount.hs +++ b/rhine/bench/WordCount.hs @@ -71,18 +71,19 @@ withInput action = do -- | Idiomatic Rhine implementation with a single clock rhineWordCount :: IO Int rhineWordCount = do - Left (Right count) <- withInput $ runExceptT $ flow $ wc @@ delayIOError (ExceptClock StdinClock) Left - return count + Left (Right nWords) <- withInput $ runExceptT $ flow $ wc @@ delayIOError (ExceptClock StdinClock) Left + return nWords where wc :: ClSF (ExceptT (Either IOError Int) IO) (DelayIOError (ExceptClock StdinClock IOError) (Either IOError Int)) () () wc = proc _ -> do lineOrStop <- tagS -< () - words <- mappendS -< either (const 0) (Sum . length . words) lineOrStop - throwOn' -< (either isEOFError (const False) lineOrStop, Right $ getSum words) + nWords <- mappendS -< either (const 0) (Sum . length . words) lineOrStop + throwOn' -< (either isEOFError (const False) lineOrStop, Right $ getSum nWords) {- | Idiomatic dunai implementation. -Compared to Rhine, this doesn't have the overhead of clocks and exception handling. +Compared to Rhine, this doesn't have the overhead of clocks, +but it's implemented with continuations and not explicit state machines. -} dunaiWordCount :: IO Int dunaiWordCount = do @@ -95,16 +96,15 @@ dunaiWordCount = do case lineOrEOF of Right _ -> returnA -< () Left e -> - if isEOFError e - then Dunai.throwS -< Right $ getSum nWords - else Dunai.throwS -< Left e + Dunai.throwS -< if isEOFError e then Right $ getSum nWords else Left e -- ** Reference implementations in Haskell {- | The fastest line-based word count implementation that I could think of. -This is what 'rhineWordCount' would reduce to roughly, if all possible optimizations kick in, -except for the way the IORef is handled. +Except for the way the IORef is handled, +this is what 'rhineWordCount' would reduce to roughly if all possible optimizations kick in, +and automata don't add any overhead. -} textWordCount :: IO Int textWordCount = do @@ -129,11 +129,11 @@ textWordCountNoIORef :: IO Int textWordCountNoIORef = do withInput $ go 0 where - step n = do + processLine n = do line <- getLine return $ Right $ n + length (words line) go n = do - n' <- catch (step n) $ + n' <- catch (processLine n) $ \(e :: IOError) -> if isEOFError e then return $ Left n @@ -144,5 +144,5 @@ textWordCountNoIORef = do textLazy :: IO Int textLazy = do inputFileName <- testFile - handle <- openFile inputFileName ReadMode - length . Lazy.words <$> hGetContents handle + h <- openFile inputFileName ReadMode + length . Lazy.words <$> hGetContents h From f358ec8298402d7fe380b585512bae9ac16370eb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Sun, 4 Feb 2024 22:01:00 +0100 Subject: [PATCH 02/12] Add Except test --- rhine/rhine.cabal | 1 + rhine/test/Except.hs | 42 ++++++++++++++++++++++++++++++++++++++++++ rhine/test/Main.hs | 2 ++ 3 files changed, 45 insertions(+) create mode 100644 rhine/test/Except.hs diff --git a/rhine/rhine.cabal b/rhine/rhine.cabal index fc9eb5b24..1b75a139b 100644 --- a/rhine/rhine.cabal +++ b/rhine/rhine.cabal @@ -162,6 +162,7 @@ test-suite test Clock.Except Clock.FixedStep Clock.Millisecond + Except Paths_rhine Schedule Util diff --git a/rhine/test/Except.hs b/rhine/test/Except.hs new file mode 100644 index 000000000..114f72401 --- /dev/null +++ b/rhine/test/Except.hs @@ -0,0 +1,42 @@ +module Except where + +-- tasty +import Test.Tasty + +-- tasty-hunit +import Test.Tasty.HUnit + +-- rhine +import FRP.Rhine +import Util (runScheduleRhinePure) + +tests = + testGroup + "Except" + [ testCase "Can raise and catch an exception" $ do + let clsf = safely $ do + try $ sinceInitS >>> throwOnCond (== 3) () + safe $ arr (const (-1)) + runScheduleRhinePure (clsf @@ FixedStep @1) (replicate 5 ()) @?= [Just 1, Just 2, Just (-1), Just (-1), Just (-1)] + , testCase "Can raise and catch very many exceptions without steps in between" $ do + let clsf = safely $ go 100000 + go n = do + _ <- try $ throwOnCond (< n) () + go $ n - 1 + inputs = [0] + runScheduleRhinePure (clsf @@ FixedStep @1) inputs @?= [Just 0] + , testCase "Can raise, catch, and keep very many exceptions without steps in between" $ do + let clsf = safely $ go 1000 [] + go n ns = do + _ <- try $ throwOnCond (< n) () >>> arr (const ns) + go (n - 1) (n : ns) + inputs = [0] + runScheduleRhinePure (clsf @@ FixedStep @1) inputs @?= [Just [1 .. 1000]] + , testCase "Can raise, catch, and keep very many exceptions without steps in between, using Monad" $ do + let clsf = safely $ go 1000 [] + go n ns = do + n' <- try $ throwOnCond (< n) n >>> arr (const ns) + go (n' - 1) (n' : ns) + inputs = [0] + runScheduleRhinePure (clsf @@ FixedStep @1) inputs @?= [Just [1 .. 1000]] + ] diff --git a/rhine/test/Main.hs b/rhine/test/Main.hs index 163607fd6..ebafabf00 100644 --- a/rhine/test/Main.hs +++ b/rhine/test/Main.hs @@ -5,6 +5,7 @@ import Test.Tasty -- rhine import Clock +import Except import Schedule main = @@ -12,5 +13,6 @@ main = testGroup "Main" [ Clock.tests + , Except.tests , Schedule.tests ] From b20a663a0c13bea080fe32b1fb1d4bf98ba5d03a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Fri, 5 Jan 2024 17:59:50 +0100 Subject: [PATCH 03/12] Replace dunai MSFs by Automata --- CHEATSHEET.md | 4 +- README.md | 7 +- automaton/CHANGELOG.md | 5 + automaton/LICENSE | 20 + automaton/README.md | 70 +++ automaton/automaton.cabal | 99 ++++ automaton/src/Data/Automaton.hs | 511 ++++++++++++++++++ automaton/src/Data/Automaton/Final.hs | 36 ++ automaton/src/Data/Automaton/Trans/Except.hs | 321 +++++++++++ .../Data/Automaton/Trans/Except/Internal.hs | 11 + automaton/src/Data/Automaton/Trans/Maybe.hs | 120 ++++ automaton/src/Data/Automaton/Trans/RWS.hs | 40 ++ automaton/src/Data/Automaton/Trans/Random.hs | 94 ++++ automaton/src/Data/Automaton/Trans/Reader.hs | 43 ++ automaton/src/Data/Automaton/Trans/State.hs | 70 +++ automaton/src/Data/Automaton/Trans/Writer.hs | 42 ++ automaton/src/Data/Stream.hs | 417 ++++++++++++++ automaton/src/Data/Stream/Except.hs | 56 ++ automaton/src/Data/Stream/Final.hs | 63 +++ automaton/src/Data/Stream/Final/Except.hs | 18 + automaton/src/Data/Stream/Internal.hs | 22 + automaton/src/Data/Stream/Optimized.hs | 220 ++++++++ automaton/src/Data/Stream/Result.hs | 44 ++ automaton/test/Automaton.hs | 91 ++++ automaton/test/Automaton/Except.hs | 16 + automaton/test/Main.hs | 16 + automaton/test/Stream.hs | 31 ++ flake.nix | 2 +- rhine-bayes/app/Main.hs | 44 +- rhine-bayes/rhine-bayes.cabal | 7 +- rhine-bayes/src/Data/Automaton/Bayes.hs | 67 +++ .../src/Data/MonadicStreamFunction/Bayes.hs | 53 -- rhine-bayes/src/FRP/Rhine/Bayes.hs | 14 +- rhine-gloss/Main.hs | 1 + rhine-gloss/rhine-gloss.cabal | 3 +- rhine-gloss/src/FRP/Rhine/Gloss.hs | 1 - rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs | 24 +- rhine-terminal/rhine-terminal.cabal | 1 - rhine/ChangeLog.md | 9 + rhine/bench/WordCount.hs | 3 +- rhine/rhine.cabal | 9 +- rhine/src/FRP/Rhine.hs | 7 +- rhine/src/FRP/Rhine/ClSF.hs | 2 +- rhine/src/FRP/Rhine/ClSF/Core.hs | 14 +- rhine/src/FRP/Rhine/ClSF/Except.hs | 31 +- rhine/src/FRP/Rhine/ClSF/Random.hs | 14 +- rhine/src/FRP/Rhine/ClSF/Reader.hs | 12 +- rhine/src/FRP/Rhine/ClSF/Upsample.hs | 14 +- rhine/src/FRP/Rhine/ClSF/Util.hs | 10 +- rhine/src/FRP/Rhine/Clock.hs | 17 +- rhine/src/FRP/Rhine/Clock/Except.hs | 18 +- rhine/src/FRP/Rhine/Clock/FixedStep.hs | 4 + rhine/src/FRP/Rhine/Clock/Periodic.hs | 21 +- rhine/src/FRP/Rhine/Clock/Realtime/Audio.hs | 12 +- rhine/src/FRP/Rhine/Clock/Realtime/Busy.hs | 4 + rhine/src/FRP/Rhine/Clock/Realtime/Event.hs | 2 +- .../FRP/Rhine/Clock/Realtime/Millisecond.hs | 8 +- rhine/src/FRP/Rhine/Clock/Realtime/Never.hs | 7 +- rhine/src/FRP/Rhine/Clock/Realtime/Stdin.hs | 3 + rhine/src/FRP/Rhine/Clock/Select.hs | 17 +- rhine/src/FRP/Rhine/Clock/Unschedule.hs | 6 +- rhine/src/FRP/Rhine/Clock/Util.hs | 10 +- rhine/src/FRP/Rhine/Reactimation.hs | 9 +- .../FRP/Rhine/Reactimation/ClockErasure.hs | 15 +- .../src/FRP/Rhine/Reactimation/Combinators.hs | 1 + rhine/src/FRP/Rhine/ResamplingBuffer.hs | 3 + rhine/src/FRP/Rhine/ResamplingBuffer/ClSF.hs | 13 +- .../Rhine/ResamplingBuffer/Interpolation.hs | 4 +- rhine/src/FRP/Rhine/ResamplingBuffer/Util.hs | 8 +- rhine/src/FRP/Rhine/Schedule.hs | 71 ++- rhine/src/FRP/Rhine/Type.hs | 8 +- rhine/test/Schedule.hs | 5 +- rhine/test/Util.hs | 9 +- stack.9.0.2.yaml | 1 + stack.9.0.2.yaml.lock | 7 + versions.md | 95 ++++ 76 files changed, 2933 insertions(+), 274 deletions(-) create mode 100644 automaton/CHANGELOG.md create mode 100644 automaton/LICENSE create mode 100644 automaton/README.md create mode 100644 automaton/automaton.cabal create mode 100644 automaton/src/Data/Automaton.hs create mode 100644 automaton/src/Data/Automaton/Final.hs create mode 100644 automaton/src/Data/Automaton/Trans/Except.hs create mode 100644 automaton/src/Data/Automaton/Trans/Except/Internal.hs create mode 100644 automaton/src/Data/Automaton/Trans/Maybe.hs create mode 100644 automaton/src/Data/Automaton/Trans/RWS.hs create mode 100644 automaton/src/Data/Automaton/Trans/Random.hs create mode 100644 automaton/src/Data/Automaton/Trans/Reader.hs create mode 100644 automaton/src/Data/Automaton/Trans/State.hs create mode 100644 automaton/src/Data/Automaton/Trans/Writer.hs create mode 100644 automaton/src/Data/Stream.hs create mode 100644 automaton/src/Data/Stream/Except.hs create mode 100644 automaton/src/Data/Stream/Final.hs create mode 100644 automaton/src/Data/Stream/Final/Except.hs create mode 100644 automaton/src/Data/Stream/Internal.hs create mode 100644 automaton/src/Data/Stream/Optimized.hs create mode 100644 automaton/src/Data/Stream/Result.hs create mode 100644 automaton/test/Automaton.hs create mode 100644 automaton/test/Automaton/Except.hs create mode 100644 automaton/test/Main.hs create mode 100644 automaton/test/Stream.hs create mode 100644 rhine-bayes/src/Data/Automaton/Bayes.hs delete mode 100644 rhine-bayes/src/Data/MonadicStreamFunction/Bayes.hs create mode 100644 versions.md diff --git a/CHEATSHEET.md b/CHEATSHEET.md index dfcee4b15..8ffb748e4 100644 --- a/CHEATSHEET.md +++ b/CHEATSHEET.md @@ -109,8 +109,8 @@ rhL -- A rhine that inputs some data `a` and outputs some data `b`, on some c ### Clocked signal functions (`ClSF`s) -Stream functions in [`dunai`](http://hackage.haskell.org/package/dunai) are usually valid clocked signal functions. -Here are some that are not in `dunai`. +Automata in [`automaton`](http://hackage.haskell.org/package/automaton) are usually valid clocked signal functions. +Here are some of the most used: | Name | Type (abbreviated) | Meaning | |--------------|------------------------------------------------------|---------------------------------------------------| diff --git a/README.md b/README.md index 5bb979d66..04c810f54 100644 --- a/README.md +++ b/README.md @@ -8,12 +8,11 @@ Rhine is a library for synchronous and asynchronous Functional Reactive Programm It separates the aspects of clocking, scheduling and resampling from each other, and ensures clock-safety on the type level. -## Versions 1.* vs. 0.* +## Recent breakage? Confused because some examples from the article don't work anymore? -As a big simplification and breaking change, -explicit schedules were removed in version 1.0. -For an overview of the required changes, see [this page](/version1.md). +Rhine went through a few bigger API simplifications and changes. +If this broke your code, have a look at [the versions readme](./versions.md) to fix it. ## Concept diff --git a/automaton/CHANGELOG.md b/automaton/CHANGELOG.md new file mode 100644 index 000000000..97a7c8ec7 --- /dev/null +++ b/automaton/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for automaton + +## 0.1.0.0 + +* Initial version ;) diff --git a/automaton/LICENSE b/automaton/LICENSE new file mode 100644 index 000000000..8b76fa3be --- /dev/null +++ b/automaton/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2024 Manuel Bärenz + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/automaton/README.md b/automaton/README.md new file mode 100644 index 000000000..8532f50f2 --- /dev/null +++ b/automaton/README.md @@ -0,0 +1,70 @@ +# `automaton`: Effectful streams and automata in initial encoding + +This library defines effectful streams and automata, in initial encoding. +They are useful to define effectful automata, or state machines, transducers, monadic stream functions and similar streaming abstractions. +In comparison to most other libraries, they are implemented here with explicit state types, +and thus are amenable to GHC optimizations, often resulting in dramatically better performance. + +## What? + +The core concept is an effectful stream in initial encoding: +```haskell +data StreamT m a = forall s. + StreamT + { state :: s + , step :: s -> m (s, a) + } +``` +This is an stream because you can repeatedly call `step` on the `state` and produce output values `a`, +while mutating the internal state. +It is effectful because each step performs a side effect in `m`, typically a monad. + +The definitions you will most often find in the wild is the "final encoding": +```haskell +data StreamT m a = StreamT (m (StreamT m a, a)) +``` +Semantically, there is no big difference between them, and in nearly all cases you can map the initial encoding onto the final one and vice versa. +(For the single edge case, see [the section in `Data.Automaton` about recursive definitions](hackage.haskell.org/package/automaton/docs/Data.Automaton.html).) +But when composing streams, +the initial encoding will often be more performant that than the final encoding because GHC can optimise the joint state and step functions of the streams. + +### How are these automata? + +Effectful streams are very versatile, because you can change the effect type `m` to get a number of different concepts. +When `m` contains a `Reader` effect, you get automata! +From the effectful stream alone, a side effect, a state transition and an output value is produced at every step. +If this effect includes reading an input value, you have all ingredients for an automaton (also known as a Mealy state machine, or a transducer). + +Automata can be composed in many useful ways, and are very expressive. +A lot of reactive programs can be written with them, +by composing a big program out of many automaton components. + +## Why? + +Mostly, performance. +When composing a big automaton out of small ones, the final encoding is not very performant, as mentioned above: +Each step of each component contains a closure, which is basically opaque for the compiler. +In the initial encoding, the step functions of two composed automata are themselves composed, and the compiler can optimize them just like any regular function. +This often results in massive speedups. + +### But really, why? + +To serve as the basic building block in [`rhine`](https://hackage.haskell.org/package/rhine), +a library for Functional Reactive Programming. + +## Doesn't this exist already? + +Not quite. +There are many streaming libraries ([`streamt`](https://hackage.haskell.org/package/streamt), [`streaming`](https://hackage.haskell.org/package/streaming)), +and state machine libraries ([`machines`](https://hackage.haskell.org/package/machines)) that implement effectful streams. +Prominently, [`dunai`](https://hackage.haskell.org/package/dunai) implements monadic stream functions +(which are essentially effectful state machines) +and has inspired the design and API of this package to a great extent. +(Feel free to extend this list by other notable libraries.) +But all of these are implemented in the final encoding. + +I am aware of only two fleshed-out implementations of effectful automata in the initial encoding, +both of which have been a big inspiration for this package: + +* [`essence-of-live-coding`](https://hackage.haskell.org/package/essence-of-live-coding) restricts the state type to be serializable, gaining live coding capabilities, but sacrificing on expressivity. +* https://github.com/lexi-lambda/incremental/blob/master/src/Incremental/Fast.hs is unfortunately not published on Hackage, and doesn't seem maintained. diff --git a/automaton/automaton.cabal b/automaton/automaton.cabal new file mode 100644 index 000000000..b56288541 --- /dev/null +++ b/automaton/automaton.cabal @@ -0,0 +1,99 @@ +cabal-version: 3.0 +name: automaton +version: 0.1.0.0 +synopsis: Effectful streams and automata in initial encoding +description: + Effectful streams have an internal state and a step function. + Varying the effect type, this gives many different useful concepts: + For example with a reader effect, it results in automata/transducers/state machines. + +license: MIT +license-file: LICENSE +author: Manuel Bärenz +maintainer: programming@manuelbaerenz.de +category: Streaming +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md + +common opts + build-depends: + MonadRandom >=0.5, + base >=4.14 && <4.18, + mmorph ^>=1.2, + mtl >=2.2 && <2.4, + profunctors ^>=5.6, + selective ^>=0.7, + semialign ^>=1.3, + simple-affine-space ^>=0.2, + these ^>=1.2, + transformers >=0.5, + + if flag(dev) + ghc-options: -Werror + ghc-options: + -W + + default-extensions: + Arrows + DataKinds + FlexibleContexts + FlexibleInstances + ImportQualifiedPost + MultiParamTypeClasses + NamedFieldPuns + NoStarIsType + TupleSections + TypeApplications + TypeFamilies + TypeOperators + + default-language: Haskell2010 + +library + import: opts + exposed-modules: + Data.Automaton + Data.Automaton.Final + Data.Automaton.Trans.Except + Data.Automaton.Trans.Maybe + Data.Automaton.Trans.RWS + Data.Automaton.Trans.Random + Data.Automaton.Trans.Reader + Data.Automaton.Trans.State + Data.Automaton.Trans.Writer + Data.Stream + Data.Stream.Except + Data.Stream.Final + Data.Stream.Internal + Data.Stream.Optimized + Data.Stream.Result + + other-modules: + Data.Automaton.Trans.Except.Internal + Data.Stream.Final.Except + + hs-source-dirs: src + +test-suite automaton-test + import: opts + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Automaton + Automaton.Except + Stream + + build-depends: + QuickCheck ^>=2.14, + automaton, + tasty ^>=1.4, + tasty-hunit ^>=0.10, + tasty-quickcheck ^>=0.10, + +flag dev + description: Enable warnings as errors. Active on ci. + default: False + manual: True diff --git a/automaton/src/Data/Automaton.hs b/automaton/src/Data/Automaton.hs new file mode 100644 index 000000000..7a9125e70 --- /dev/null +++ b/automaton/src/Data/Automaton.hs @@ -0,0 +1,511 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Automaton where + +-- base +import Control.Applicative (Alternative (..)) +import Control.Arrow +import Control.Category +import Control.Monad ((<=<)) +import Control.Monad.Fix (MonadFix (mfix)) +import Data.Coerce (coerce) +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.Functor.Compose (Compose (..)) +import Data.Monoid (Sum (..)) +import Prelude hiding (id, (.)) + +-- mmorph +import Control.Monad.Morph (MFunctor (..)) + +-- transformers +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader + +-- profunctors +import Data.Profunctor (Choice (..), Profunctor (..), Strong) +import Data.Profunctor.Strong (Strong (..)) +import Data.Profunctor.Traversing + +-- selective +import Control.Selective (Selective) + +-- simple-affine-space +import Data.VectorSpace (VectorSpace (..)) + +-- align +import Data.Semialign (Align (..), Semialign (..)) + +-- automaton +import Data.Stream (StreamT (..), fixStream) +import Data.Stream.Internal (JointState (..)) +import Data.Stream.Optimized ( + OptimizedStreamT (..), + concatS, + stepOptimizedStream, + ) +import Data.Stream.Optimized qualified as StreamOptimized +import Data.Stream.Result + +-- * Constructing automata + +{- | An effectful automaton in initial encoding. + +* @m@: The monad in which the automaton performs side effects. +* @a@: The type of inputs the automaton constantly consumes. +* @b@: The type of outputs the automaton constantly produces. + +An effectful automaton with input @a@ is the same as an effectful stream +with the additional effect of reading an input value @a@ on every step. +This is why automata are defined here as streams. + +The API of automata follows that of streams ('StreamT' and 'OptimizedStreamT') closely. +The prominent addition in automata is now that they are instances of the 'Category', 'Arrow', 'Profunctor', +and related type classes. +This allows for more ways of creating or composing them. + +For example, you can sequentially and parallely compose two automata: +@ +automaton1 :: Automaton m a b +automaton2 :: Automaton m b c + +sequentially :: Automaton m a c +sequentially = automaton1 >>> automaton2 + +parallely :: Automaton m (a, b) (b, c) +parallely = automaton1 *** automaton2 +@ +In sequential composition, the output of the first automaton is passed as input to the second one. +In parallel composition, both automata receive input simulataneously and process it independently. + +Through the 'Arrow' type class, you can use 'arr' to create an automaton from a pure function, +and more generally use the arrow syntax extension to define automata. +-} +newtype Automaton m a b = Automaton {getAutomaton :: OptimizedStreamT (ReaderT a m) b} + deriving newtype (Functor, Applicative, Alternative, Selective, Num, Fractional, Floating) + +-- | Create an 'Automaton' from a state and a pure step function. +unfold :: + (Applicative m) => + -- | The initial state + s -> + -- | The step function + (a -> s -> Result s b) -> + Automaton m a b +unfold state step = unfoldM state $ fmap pure <$> step + +-- | Create an 'Automaton' from a state and an effectful step function. +unfoldM :: + -- | The initial state + s -> + -- | The step function + (a -> s -> m (Result s b)) -> + Automaton m a b +unfoldM state step = Automaton $! Stateful $! StreamT {state, step = \s -> ReaderT $ \a -> step a s} + +instance (Eq s, Floating s, VectorSpace v s, Applicative m) => VectorSpace (Automaton m a v) (Automaton m a s) where + zeroVector = Automaton zeroVector + Automaton s *^ Automaton v = coerce $ s *^ v + Automaton v1 ^+^ Automaton v2 = coerce $ v1 ^+^ v2 + dot (Automaton s) (Automaton v) = coerce $ dot s v + normalize (Automaton v) = coerce v + +instance (Semialign m) => Semialign (Automaton m a) where + align automaton1 automaton2 = + Automaton $ + StreamOptimized.hoist' (ReaderT . getCompose) $ + align + (StreamOptimized.hoist' (Compose . runReaderT) $ getAutomaton automaton1) + (StreamOptimized.hoist' (Compose . runReaderT) $ getAutomaton automaton2) + +instance (Align m) => Align (Automaton m a) where + nil = constM nil + +instance (Monad m) => Category (Automaton m) where + id = Automaton $ Stateless ask + {-# INLINE id #-} + + Automaton (Stateful (StreamT stateF0 stepF)) . Automaton (Stateful (StreamT stateG0 stepG)) = + Automaton $! + Stateful $! + StreamT + { state = JointState stateF0 stateG0 + , step = \(JointState stateF stateG) -> do + Result stateG' b <- stepG stateG + Result stateF' c <- lift $! runReaderT (stepF stateF) b + return $! Result (JointState stateF' stateG') c + } + Automaton (Stateful (StreamT state0 step)) . Automaton (Stateless m) = + Automaton $! + Stateful $! + StreamT + { state = state0 + , step = \state -> do + b <- m + lift $! runReaderT (step state) b + } + Automaton (Stateless m) . Automaton (Stateful (StreamT state0 step)) = + Automaton $! + Stateful $! + StreamT + { state = state0 + , step = \state -> do + Result state' b <- step state + c <- lift $! runReaderT m b + return $! Result state' c + } + Automaton (Stateless f) . Automaton (Stateless g) = Automaton $ Stateless $ ReaderT $ runReaderT f <=< runReaderT g + {-# INLINE (.) #-} + +instance (Monad m) => Arrow (Automaton m) where + arr f = Automaton $! Stateless $! asks f + {-# INLINE arr #-} + + first (Automaton (Stateful StreamT {state, step})) = + Automaton $! + Stateful $! + StreamT + { state + , step = \s -> + ReaderT + ( \(b, d) -> + fmap (,d) + <$> runReaderT (step s) b + ) + } + first (Automaton (Stateless m)) = Automaton $ Stateless $ ReaderT $ \(b, d) -> (,d) <$> runReaderT m b + {-# INLINE first #-} + +instance (Monad m) => ArrowChoice (Automaton m) where + Automaton (Stateful (StreamT stateL0 stepL)) +++ Automaton (Stateful (StreamT stateR0 stepR)) = + Automaton $! + Stateful $! + StreamT + { state = JointState stateL0 stateR0 + , step = \(JointState stateL stateR) -> + ReaderT $! + either + (runReaderT (mapResultState (`JointState` stateR) . fmap Left <$> stepL stateL)) + (runReaderT (mapResultState (JointState stateL) . fmap Right <$> stepR stateR)) + } + Automaton (Stateless m) +++ Automaton (Stateful (StreamT state0 step)) = + Automaton $! + Stateful $! + StreamT + { state = state0 + , step = \state -> + ReaderT $! + either + (runReaderT . fmap (Result state . Left) $ m) + (runReaderT . fmap (fmap Right) $ step state) + } + Automaton (Stateful (StreamT state0 step)) +++ Automaton (Stateless m) = + Automaton $! + Stateful $! + StreamT + { state = state0 + , step = \state -> + ReaderT $! + either + (runReaderT . fmap (fmap Left) $ step state) + (runReaderT . fmap (Result state . Right) $ m) + } + Automaton (Stateless mL) +++ Automaton (Stateless mR) = + Automaton $ + Stateless $ + ReaderT $ + either + (runReaderT . fmap Left $ mL) + (runReaderT . fmap Right $ mR) + {-# INLINE (+++) #-} + + left (Automaton (Stateful (StreamT {state, step}))) = + Automaton $! + Stateful $! + StreamT + { state + , step = \s -> ReaderT $ either (fmap (fmap Left) . runReaderT (step s)) (pure . Result s . Right) + } + left (Automaton (Stateless ma)) = Automaton $! Stateless $! ReaderT $! either (fmap Left . runReaderT ma) (pure . Right) + {-# INLINE left #-} + + right (Automaton (Stateful (StreamT {state, step}))) = + Automaton $! + Stateful $! + StreamT + { state + , step = \s -> ReaderT $ either (pure . Result s . Left) (fmap (fmap Right) . runReaderT (step s)) + } + right (Automaton (Stateless ma)) = Automaton $! Stateless $! ReaderT $! either (pure . Left) (fmap Right . runReaderT ma) + {-# INLINE right #-} + +-- | 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)) + loop (Automaton (Stateful (StreamT {state, step}))) = + Automaton $! + Stateful $! + StreamT + { state + , step = \s -> ReaderT $ \b -> fmap fst <$> mfix ((. (snd . output)) $ ($ b) $ curry $ runReaderT $ step s) + } + {-# INLINE loop #-} + +instance (Monad m, Alternative m) => ArrowZero (Automaton m) where + zeroArrow = empty + +instance (Monad m, Alternative m) => ArrowPlus (Automaton m) where + (<+>) = (<|>) + +-- | Consume an input and produce output effectfully, without keeping internal state +arrM :: (Functor m) => (a -> m b) -> Automaton m a b +arrM f = Automaton $! StreamOptimized.constM $! ReaderT f +{-# INLINE arrM #-} + +-- | Produce output effectfully, without keeping internal state +constM :: (Functor m) => m b -> Automaton m a b +constM = arrM . const +{-# INLINE constM #-} + +-- | Apply an arbitrary monad morphism to an automaton. +hoistS :: (Monad m) => (forall x. m x -> n x) -> Automaton m a b -> Automaton n a b +hoistS morph (Automaton automaton) = Automaton $ hoist (mapReaderT morph) automaton +{-# INLINE hoistS #-} + +-- | Lift the monad of an automaton to a transformer. +liftS :: (MonadTrans t, Monad m, Functor (t m)) => Automaton m a b -> Automaton (t m) a b +liftS = hoistS lift +{-# INLINE liftS #-} + +{- | Extend the internal state and feed back part of the output to the next input. + +This is one of the fundamental ways to incorporate recursive dataflow in automata. +Given an automaton which consumes an additional input and produces an additional output, +the state of the automaton is extended by a further value. +This value is used as the additional input, +and the resulting additional output is stored in the internal state for the next step. +-} +feedback :: + (Functor m) => + -- | The additional internal state + c -> + -- | The original automaton + Automaton m (a, c) (b, c) -> + Automaton m a b +feedback c (Automaton (Stateful StreamT {state, step})) = + Automaton $! + Stateful $! + StreamT + { state = JointState state c + , step = \(JointState s c) -> ReaderT $ \a -> (\(Result s (b, c)) -> Result (JointState s c) b) <$> runReaderT (step s) (a, c) + } +feedback state (Automaton (Stateless m)) = + Automaton $! + Stateful $! + StreamT + { state + , step = \c -> ReaderT $ \a -> (\(b, c) -> Result c b) <$> runReaderT m (a, c) + } +{-# INLINE feedback #-} + +-- * Running automata + +{- | Run one step of an automaton. + +This consumes an input value, performs a side effect, and returns an updated automaton together with an output value. +-} +stepAutomaton :: (Functor m) => Automaton m a b -> a -> m (Result (Automaton m a b) b) +stepAutomaton (Automaton automatonT) a = + runReaderT (stepOptimizedStream automatonT) a + <&> mapResultState Automaton +{-# INLINE stepAutomaton #-} + +{- | Run an automaton with trivial input and output indefinitely. + +If the input and output of an automaton does not contain information, +all of its meaning is in its effects. +This function runs the automaton indefinitely. +Since it will never return with a value, this function also has no output (its output is void). +The only way it can return is if @m@ includes some effect of termination, +e.g. 'Maybe' or 'Either' could terminate with a 'Nothing' or 'Left' value, +or 'IO' can raise an exception. +-} +reactimate :: (Monad m) => Automaton m () () -> m void +reactimate (Automaton automaton) = StreamOptimized.reactimate $ hoist (`runReaderT` ()) automaton +{-# INLINE reactimate #-} + +{- | Run an automaton with given input, for a given number of steps. + +Especially for tests and batch processing, +it is useful to step an automaton with given input. +-} +embed :: + (Monad m) => + -- | The automaton to run + Automaton m a b -> + -- | The input values + [a] -> + m [b] +embed (Automaton (Stateful StreamT {state, step})) = go state + where + go _s [] = return [] + go s (a : as) = do + Result s' b <- runReaderT (step s) a + (b :) <$> go s' as +embed (Automaton (Stateless m)) = mapM $ runReaderT m + +-- * Modifying automata + +-- | Change the 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 #-} + +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 + rmap = fmap + +instance (Monad m) => Choice (Automaton m) where + right' = right + left' = left + +instance (Monad m) => Strong (Automaton m) where + second' = second + first' = first + +-- | Step an automaton several steps at once, depending on how long the input is. +instance (Monad m) => Traversing (Automaton m) where + wander f Automaton {getAutomaton = Stateful StreamT {state, step}} = + Automaton + { getAutomaton = + Stateful + StreamT + { state + , step = + step + & fmap runReaderT + & flip + & fmap ResultStateT + & f + & fmap getResultStateT + & flip + & fmap ReaderT + } + } + wander f (Automaton (Stateless m)) = Automaton $ Stateless $ ReaderT $ f $ runReaderT m + {-# INLINE wander #-} + +-- | Only step the automaton if the input is 'Just'. +mapMaybeS :: (Monad m) => Automaton m a b -> Automaton m (Maybe a) (Maybe b) +mapMaybeS = traverse' + +-- | Use an 'Automaton' with a variable amount of input. +traverseS :: (Monad m, Traversable f) => Automaton m a b -> Automaton m (f a) (f b) +traverseS = traverse' + +-- | Like 'traverseS', discarding the output. +traverseS_ :: (Monad m, Traversable f) => Automaton m a b -> Automaton m (f a) () +traverseS_ automaton = traverse' automaton >>> arr (const ()) + +-- FIXME separate issue to generalise to something from recursion schemes? + +{- | Launch arbitrarily many copies of the automaton in parallel. + +* The copies of the automaton are launched on demand as the input lists grow. +* The n-th copy will always receive the n-th input. +* If the input list has length n, the n+1-th automaton copy will not be stepped. + +Caution: Uses memory of the order of the largest list that was ever input during runtime. +-} +parallely :: (Applicative m) => Automaton m a b -> Automaton m [a] [b] +parallely Automaton {getAutomaton = Stateful stream} = Automaton $ Stateful $ parallely' stream + where + parallely' :: (Applicative m) => StreamT (ReaderT a m) b -> StreamT (ReaderT [a] m) [b] + parallely' StreamT {state, step} = fixStream (JointState state) $ \fixstep jointState@(JointState s fixstate) -> ReaderT $ \case + [] -> pure $! Result jointState [] + (a : as) -> apResult . fmap (:) <$> runReaderT (step s) a <*> runReaderT (fixstep fixstate) as +parallely Automaton {getAutomaton = Stateless f} = Automaton $ Stateless $ ReaderT $ traverse $ runReaderT f + +-- | Given a transformation of streams, apply it to an automaton, without changing the input. +handleAutomaton_ :: (Monad m) => (forall m. (Monad m) => StreamT m a -> StreamT m b) -> Automaton m i a -> Automaton m i b +handleAutomaton_ f = Automaton . StreamOptimized.withOptimized f . getAutomaton + +-- | Given a transformation of streams, apply it to an automaton. The input can be accessed through the 'ReaderT' effect. +handleAutomaton :: (Monad m) => (StreamT (ReaderT a m) b -> StreamT (ReaderT c n) d) -> Automaton m a b -> Automaton n c d +handleAutomaton f = Automaton . StreamOptimized.handleOptimized f . getAutomaton + +-- | Buffer the output of an automaton. See 'Data.Stream.concatS'. +concatS :: (Monad m) => Automaton m () [b] -> Automaton m () b +concatS (Automaton automaton) = Automaton $ Data.Stream.Optimized.concatS automaton + +-- * Examples + +-- | Pass through a value unchanged, and perform a side effect depending on it +withSideEffect :: + (Monad m) => + -- | For every value passing through the automaton, this function is called and the resulting side effect performed. + (a -> m b) -> + Automaton m a a +withSideEffect f = (id &&& arrM f) >>> arr fst + +-- | Accumulate the input, output the accumulator. +accumulateWith :: + (Monad m) => + -- | The accumulation function + (a -> b -> b) -> + -- | The initial accumulator + b -> + Automaton m a b +accumulateWith f state = unfold state $ \a b -> let b' = f a b in Result b' b' + +-- | Like 'accumulateWith', with 'mappend' as the accumulation function. +mappendFrom :: (Monoid w, Monad m) => w -> Automaton m w w +mappendFrom = accumulateWith mappend + +-- | Delay the input by one step. +delay :: + (Applicative m) => + -- | The value to output on the first step + a -> + Automaton m a a +delay a0 = unfold a0 $ \aIn aState -> Result aIn aState + +{- | Delay an automaton by one step by prepending one value to the output. + +On the first step, the given initial output is returned. +On all subsequent steps, the automaton is stepped with the previous input. +-} +prepend :: (Monad m) => b -> Automaton m a b -> Automaton m a b +prepend b0 automaton = proc a -> do + eab <- delay (Left b0) -< Right a + case eab of + Left b -> returnA -< b + Right a -> automaton -< a + +-- | Like 'mappendFrom', initialised at 'mempty'. +mappendS :: (Monoid w, Monad m) => Automaton m w w +mappendS = mappendFrom mempty + +-- | Sum up all inputs so far, with an explicit initial value. +sumFrom :: (VectorSpace v s, Monad m) => v -> Automaton m v v +sumFrom = accumulateWith (^+^) + +-- | Like 'sumFrom', initialised at 0. +sumS :: (Monad m, VectorSpace v s) => Automaton m v v +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 + +-- | 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')) diff --git a/automaton/src/Data/Automaton/Final.hs b/automaton/src/Data/Automaton/Final.hs new file mode 100644 index 000000000..69fb866c4 --- /dev/null +++ b/automaton/src/Data/Automaton/Final.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.Automaton.Final where + +-- base +import Control.Applicative (Alternative) +import Control.Arrow +import Control.Category +import Prelude hiding (id, (.)) + +-- transformers +import Control.Monad.Trans.Reader + +-- automaton +import Data.Automaton +import Data.Stream.Final qualified as StreamFinal +import Data.Stream.Optimized qualified as StreamOptimized + +-- | Automata in final encoding. +newtype Final m a b = Final {getFinal :: StreamFinal.Final (ReaderT a m) b} + deriving newtype (Functor, Applicative, Alternative) + +instance (Monad m) => Category (Final m) where + id = toFinal id + f1 . f2 = toFinal $ fromFinal f1 . fromFinal f2 + +instance (Monad m) => Arrow (Final m) where + arr = toFinal . arr + first = toFinal . first . fromFinal + +toFinal :: (Functor m) => Automaton m a b -> Final m a b +toFinal (Automaton automaton) = Final $ StreamOptimized.toFinal automaton + +fromFinal :: Final m a b -> Automaton m a b +fromFinal Final {getFinal} = Automaton $ StreamOptimized.fromFinal getFinal diff --git a/automaton/src/Data/Automaton/Trans/Except.hs b/automaton/src/Data/Automaton/Trans/Except.hs new file mode 100644 index 000000000..5bc2e692c --- /dev/null +++ b/automaton/src/Data/Automaton/Trans/Except.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StrictData #-} + +{- | An 'Automaton' in the 'ExceptT' monad can throw an exception to terminate. + +This module defines several ways to throw exceptions, +and implements control flow by handling them. + +The API is heavily inspired by @dunai@. +-} +module Data.Automaton.Trans.Except ( + module Data.Automaton.Trans.Except, + module Control.Monad.Trans.Except, +) +where + +-- base +import Control.Arrow (arr, returnA, (<<<), (>>>)) +import Control.Category qualified as Category +import Data.Void (Void, absurd) + +-- transformers +import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE) +import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) +import Control.Monad.Trans.Reader + +-- selective +import Control.Selective (Selective) + +-- mmorph +import Control.Monad.Morph + +-- automaton +import Data.Automaton ( + Automaton (..), + arrM, + constM, + count, + feedback, + hoistS, + liftS, + mapMaybeS, + reactimate, + ) +import Data.Automaton.Trans.Except.Internal +import Data.Stream.Except hiding (safely) +import Data.Stream.Except qualified as StreamExcept +import Data.Stream.Optimized (mapOptimizedStreamT) +import Data.Stream.Optimized qualified as StreamOptimized + +-- * Throwing exceptions + +-- | Throw the exception 'e' whenever the function evaluates to 'True'. +throwOnCond :: (Monad m) => (a -> Bool) -> e -> Automaton (ExceptT e m) a a +throwOnCond cond e = proc a -> + if cond a + then throwS -< e + else returnA -< a + +{- | Throws the exception when the input is 'True'. Variant of 'throwOnCond' +for Kleisli arrows. +-} +throwOnCondM :: (Monad m) => (a -> m Bool) -> e -> Automaton (ExceptT e m) a a +throwOnCondM cond e = proc a -> do + b <- arrM (lift . cond) -< a + if b + then throwS -< e + else returnA -< a + +-- | Throw the exception when the input is 'True'. +throwOn :: (Monad m) => e -> Automaton (ExceptT e m) Bool () +throwOn e = proc b -> throwOn' -< (b, e) + +-- | Variant of 'throwOn', where the exception may change every tick. +throwOn' :: (Monad m) => Automaton (ExceptT e m) (Bool, e) () +throwOn' = proc (b, e) -> + if b + then throwS -< e + else returnA -< () + +{- | When the input is @Just e@, throw the exception @e@. + +This does not output any data since it terminates on the first nontrivial input. +-} +throwMaybe :: (Monad m) => Automaton (ExceptT e m) (Maybe e) (Maybe void) +throwMaybe = mapMaybeS throwS + +{- | Immediately throw the incoming exception. + +This is useful to combine with 'ArrowChoice', +e.g. with @if@ and @case@ expressions in Arrow syntax. +-} +throwS :: (Monad m) => Automaton (ExceptT e m) e a +throwS = arrM throwE + +-- | Immediately throw the given exception. +throw :: (Monad m) => e -> Automaton (ExceptT e m) a b +throw = constM . throwE + +-- | Do not throw an exception. +pass :: (Monad m) => Automaton (ExceptT e m) a a +pass = Category.id + +{- | Converts an 'Automaton' in 'MaybeT' to an 'Automaton' in 'ExceptT'. + +Whenever 'Nothing' is thrown, throw @()@ instead. +-} +maybeToExceptS :: + (Functor m, Monad m) => + Automaton (MaybeT m) a b -> + Automaton (ExceptT () m) a b +maybeToExceptS = hoistS (ExceptT . (maybe (Left ()) Right <$>) . runMaybeT) + +-- * Catching exceptions + +{- | Catch an exception in an 'Automaton'. + +As soon as an exception occurs, switch to a new 'Automaton', +the exception handler, based on the exception value. + +For exception catching where the handler can throw further exceptions, see 'AutomatonExcept' further below. +-} +catchS :: (Monad m) => Automaton (ExceptT e m) a b -> (e -> Automaton m a b) -> Automaton m a b +catchS automaton f = safely $ do + e <- try automaton + safe $ f e + +-- | Similar to Yampa's delayed switching. Loses a @b@ in case of an exception. +untilE :: + (Monad m) => + Automaton m a b -> + Automaton m b (Maybe e) -> + Automaton (ExceptT e m) a b +untilE automaton automatone = proc a -> do + b <- liftS automaton -< a + me <- liftS automatone -< b + inExceptT -< ExceptT $ return $ maybe (Right b) Left me + +{- | Escape an 'ExceptT' layer by outputting the exception whenever it occurs. + +If an exception occurs, the current state is is tested again on the next input. +-} +exceptS :: (Functor m, Monad m) => Automaton (ExceptT e m) a b -> Automaton m a (Either e b) +exceptS = Automaton . StreamOptimized.exceptS . mapOptimizedStreamT commuteReader . getAutomaton + +{- | Embed an 'ExceptT' value inside the 'Automaton'. + +Whenever the input value is an ordinary value, it is passed on. If it is an exception, it is raised. +-} +inExceptT :: (Monad m) => Automaton (ExceptT e m) (ExceptT e m a) a +inExceptT = arrM id + +{- | In case an exception occurs in the first argument, replace the exception +by the second component of the tuple. +-} +tagged :: (Monad m) => Automaton (ExceptT e1 m) a b -> Automaton (ExceptT e2 m) (a, e2) b +tagged automaton = runAutomatonExcept $ try (automaton <<< arr fst) *> (snd <$> currentInput) + +-- * Monad interface for Exception Automatons + +{- | An 'Automaton' that can terminate with an exception. + +* @m@: The monad that the 'Automaton' may take side effects in. +* @a@: The type of input values the stream constantly consumes. +* @b@: The type of output values the stream constantly produces. +* @e@: The type of exceptions with which the stream can terminate. + +This type is useful because it is a monad in the /exception type/ @e@. + + * 'return' corresponds to throwing an exception immediately. + * '>>=' is exception handling: The first value throws an exception, while + the Kleisli arrow handles the exception and produces a new signal + function, which can throw exceptions in a different type. + +Consider this example: +@ +automaton :: AutomatonExcept m a b e1 +f :: e1 -> AutomatonExcept m a b e2 + +example :: AutomatonExcept m a b e2 +example = automaton >>= f +@ + +Here, @automaton@ produces output values of type @b@ until an exception @e1@ occurs. +The function @f@ is called on the exception value and produces a continuation automaton +which is then executed (until it possibly throws an exception @e2@ itself). + +The generality of the monad interface comes at a cost, though. +In order to achieve higher performance, you should use the 'Monad' interface sparingly. +Whenever you can express the same control flow using 'Functor', 'Applicative', 'Selective', +or just the '(>>)' operator, you should do this. +The encoding of the internal state type will be much more efficiently optimized. + +The reason for this is that in an expression @ma >>= f@, +the type of @f@ is @e1 -> AutomatonExcept m a b e2@, +which implies that the state of the 'AutomatonExcept' produced isn't known at compile time, +and thus GHC cannot optimize the automaton. +But often the full expressiveness of '>>=' isn't necessary, and in these cases, +a much faster automaton is produced by using 'Functor', 'Applicative' and 'Selective'. + +Note: By "exceptions", we mean an 'ExceptT' transformer layer, not 'IO' exceptions. +-} +newtype AutomatonExcept m a b e = AutomatonExcept {getAutomatonExcept :: StreamExcept (ReaderT a m) b e} + deriving newtype (Functor, Applicative, Selective, Monad) + +runAutomatonExcept :: (Monad m) => AutomatonExcept m a b e -> Automaton (ExceptT e m) a b +runAutomatonExcept = Automaton . hoist commuteReaderBack . runStreamExcept . getAutomatonExcept + +{- | Execute an 'Automaton' in 'ExceptT' until it raises an exception. + +Typically used to enter the monad context of 'AutomatonExcept'. +-} +try :: (Monad m) => Automaton (ExceptT e m) a b -> AutomatonExcept m a b e +try = AutomatonExcept . InitialExcept . hoist commuteReader . getAutomaton + +{- | Immediately throw the current input as an exception. + +Useful inside 'AutomatonExcept' if you don't want to advance a further step in execution, +but first see what the current input is before continuing. +-} +currentInput :: (Monad m) => AutomatonExcept m e b e +currentInput = try throwS + +{- | If no exception can occur, the 'Automaton' can be executed without the 'ExceptT' +layer. + +Used to exit the 'AutomatonExcept' context, often in combination with 'safe': + +@ +automaton = safely $ do + e <- try someAutomaton + once $ \input -> putStrLn $ "Whoops, something happened when receiving input " ++ show input ++ ": " ++ show e ++ ", but I'll continue now." + safe fallbackAutomaton +-} +safely :: (Monad m) => AutomatonExcept m a b Void -> Automaton m a b +safely = Automaton . StreamExcept.safely . getAutomatonExcept + +{- | An 'Automaton' without an 'ExceptT' layer never throws an exception, and can +thus have an arbitrary exception type. + +In particular, the exception type can be 'Void', so it can be used as the last statement in an 'AutomatonExcept' @do@-block. +See 'safely' for an example. +-} +safe :: (Monad m) => Automaton m a b -> AutomatonExcept m a b e +safe = try . liftS + +{- | Inside the 'AutomatonExcept' monad, execute an action of the wrapped monad. +This passes the last input value to the action, but doesn't advance a tick. +-} +once :: (Monad m) => (a -> m e) -> AutomatonExcept m a b e +once f = AutomatonExcept $ InitialExcept $ StreamOptimized.constM $ ExceptT $ ReaderT $ fmap Left <$> f + +-- | Variant of 'once' without input. +once_ :: (Monad m) => m e -> AutomatonExcept m a b e +once_ = once . const + +-- | Advances a single tick with the given Kleisli arrow, and then throws an exception. +step :: (Monad m) => (a -> m (b, e)) -> AutomatonExcept m a b e +step f = try $ proc a -> do + n <- count -< () + (b, e) <- arrM (lift . f) -< a + _ <- throwOn' -< (n > (1 :: Int), e) + returnA -< b + +-- | Advances a single tick outputting the value, and then throws '()'. +step_ :: (Monad m) => b -> AutomatonExcept m a b () +step_ b = step $ const $ return (b, ()) + +{- | Converts a list to an 'AutomatonExcept', which outputs an element of the list at +each step, throwing '()' when the list ends. +-} +listToAutomatonExcept :: (Monad m) => [b] -> AutomatonExcept m a b () +listToAutomatonExcept = mapM_ step_ + +-- * Utilities definable in terms of 'AutomatonExcept' + +{- | Extract an 'Automaton' from a monadic action. + +Runs a monadic action that produces an 'Automaton' on the first step, +and then runs result for all further inputs (including the first one). +-} +performOnFirstSample :: (Monad m) => m (Automaton m a b) -> Automaton m a b +performOnFirstSample mAutomaton = safely $ do + automaton <- once_ mAutomaton + safe automaton + +-- | 'reactimate's an 'AutomatonExcept' until it throws an exception. +reactimateExcept :: (Monad m) => AutomatonExcept m () () e -> m e +reactimateExcept ae = fmap (either id absurd) $ runExceptT $ reactimate $ runAutomatonExcept ae + +-- | 'reactimate's an 'Automaton' until it returns 'True'. +reactimateB :: (Monad m) => Automaton m () Bool -> m () +reactimateB ae = reactimateExcept $ try $ liftS ae >>> throwOn () + +{- | Run the first 'Automaton' until the second value in the output tuple is @Just c@, +then start the second automaton, discarding the current output @b@. + +This is analogous to Yampa's +[@switch@](https://hackage.haskell.org/package/Yampa/docs/FRP-Yampa-Switches.html#v:switch), +with 'Maybe' instead of @Event@. +-} +switch :: (Monad m) => Automaton m a (b, Maybe c) -> (c -> Automaton m a b) -> Automaton m a b +switch automaton = catchS $ proc a -> do + (b, me) <- liftS automaton -< a + throwMaybe -< me + returnA -< b + +{- | Run the first 'Automaton' until the second value in the output tuple is @Just c@, +then start the second automaton one step later (after the current @b@ has been output). + +Analog to Yampa's +[@dswitch@](https://hackage.haskell.org/package/Yampa/docs/FRP-Yampa-Switches.html#v:dSwitch), +with 'Maybe' instead of @Event@. +-} +dSwitch :: (Monad m) => Automaton m a (b, Maybe c) -> (c -> Automaton m a b) -> Automaton m a b +dSwitch sf = catchS $ feedback Nothing $ proc (a, me) -> do + throwMaybe -< me + liftS sf -< a diff --git a/automaton/src/Data/Automaton/Trans/Except/Internal.hs b/automaton/src/Data/Automaton/Trans/Except/Internal.hs new file mode 100644 index 000000000..778a20ca0 --- /dev/null +++ b/automaton/src/Data/Automaton/Trans/Except/Internal.hs @@ -0,0 +1,11 @@ +module Data.Automaton.Trans.Except.Internal where + +-- transformers +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) +import Control.Monad.Trans.Reader + +commuteReader :: ReaderT r (ExceptT e m) a -> ExceptT e (ReaderT r m) a +commuteReader = ExceptT . ReaderT . fmap runExceptT . runReaderT + +commuteReaderBack :: ExceptT e (ReaderT r m) a -> ReaderT r (ExceptT e m) a +commuteReaderBack = ReaderT . fmap ExceptT . runReaderT . runExceptT diff --git a/automaton/src/Data/Automaton/Trans/Maybe.hs b/automaton/src/Data/Automaton/Trans/Maybe.hs new file mode 100644 index 000000000..2251a7800 --- /dev/null +++ b/automaton/src/Data/Automaton/Trans/Maybe.hs @@ -0,0 +1,120 @@ +-- | An 'Automaton' with 'Maybe' or 'MaybeT' in its monad stack can terminate execution at any step. +module Data.Automaton.Trans.Maybe ( + module Data.Automaton.Trans.Maybe, + module Control.Monad.Trans.Maybe, + maybeToExceptS, +) +where + +-- base +import Control.Arrow (arr, returnA, (>>>)) + +-- transformers +import Control.Monad.Trans.Maybe hiding ( + liftCallCC, + liftCatch, + liftListen, + liftPass, + ) + +-- automaton +import Data.Automaton (Automaton, arrM, constM, hoistS, liftS) +import Data.Automaton.Trans.Except ( + ExceptT, + exceptS, + listToAutomatonExcept, + maybeToExceptS, + reactimateExcept, + runAutomatonExcept, + runExceptT, + safe, + safely, + try, + ) + +-- * Throwing 'Nothing' as an exception ("exiting") + +-- | Throw the exception immediately. +exit :: (Monad m) => Automaton (MaybeT m) a b +exit = constM $ MaybeT $ return Nothing + +-- | Throw the exception when the condition becomes true on the input. +exitWhen :: (Monad m) => (a -> Bool) -> Automaton (MaybeT m) a a +exitWhen condition = proc a -> do + _ <- exitIf -< condition a + returnA -< a + +-- | Exit when the incoming value is 'True'. +exitIf :: (Monad m) => Automaton (MaybeT m) Bool () +exitIf = proc condition -> + if condition + then exit -< () + else returnA -< () + +-- | @Just a@ is passed along, 'Nothing' causes the whole 'Automaton' to exit. +maybeExit :: (Monad m) => Automaton (MaybeT m) (Maybe a) a +maybeExit = inMaybeT + +-- | Embed a 'Maybe' value in the 'MaybeT' layer. Identical to 'maybeExit'. +inMaybeT :: (Monad m) => Automaton (MaybeT m) (Maybe a) a +inMaybeT = arrM $ MaybeT . return + +-- * Catching Maybe exceptions + +-- | Run the first automaton until the second one produces 'True' from the output of the first. +untilMaybe :: (Monad m) => Automaton m a b -> Automaton m b Bool -> Automaton (MaybeT m) a b +untilMaybe automaton cond = proc a -> do + b <- liftS automaton -< a + c <- liftS cond -< b + inMaybeT -< if c then Nothing else Just b + +{- | When an exception occurs in the first 'automaton', the second 'automaton' is executed +from there. +-} +catchMaybe :: + (Functor m, Monad m) => + Automaton (MaybeT m) a b -> + Automaton m a b -> + Automaton m a b +catchMaybe automaton1 automaton2 = safely $ try (maybeToExceptS automaton1) >> safe automaton2 + +-- * Converting to and from 'MaybeT' + +-- | Convert exceptions into `Nothing`, discarding the exception value. +exceptToMaybeS :: + (Functor m, Monad m) => + Automaton (ExceptT e m) a b -> + Automaton (MaybeT m) a b +exceptToMaybeS = + hoistS $ MaybeT . fmap (either (const Nothing) Just) . runExceptT + +{- | Converts a list to an 'Automaton' in 'MaybeT', which outputs an element of the +list at each step, throwing 'Nothing' when the list ends. +-} +listToMaybeS :: (Functor m, Monad m) => [b] -> Automaton (MaybeT m) a b +listToMaybeS = exceptToMaybeS . runAutomatonExcept . listToAutomatonExcept + +-- * Running 'MaybeT' + +{- | Remove the 'MaybeT' layer by outputting 'Nothing' when the exception occurs. + +The current state is then tested again on the next input. +-} +runMaybeS :: (Functor m, Monad m) => Automaton (MaybeT m) a b -> Automaton m a (Maybe b) +runMaybeS automaton = exceptS (maybeToExceptS automaton) >>> arr eitherToMaybe + where + eitherToMaybe (Left ()) = Nothing + eitherToMaybe (Right b) = Just b + +-- | 'reactimate's an 'Automaton' in the 'MaybeT' monad until it throws 'Nothing'. +reactimateMaybe :: + (Functor m, Monad m) => + Automaton (MaybeT m) () () -> + m () +reactimateMaybe automaton = reactimateExcept $ try $ maybeToExceptS automaton + +{- | Run an 'Automaton' fed from a list, discarding results. Useful when one needs to +combine effects and streams (i.e., for testing purposes). +-} +embed_ :: (Functor m, Monad m) => Automaton m a () -> [a] -> m () +embed_ automaton as = reactimateMaybe $ listToMaybeS as >>> liftS automaton diff --git a/automaton/src/Data/Automaton/Trans/RWS.hs b/automaton/src/Data/Automaton/Trans/RWS.hs new file mode 100644 index 000000000..4a74dbb6f --- /dev/null +++ b/automaton/src/Data/Automaton/Trans/RWS.hs @@ -0,0 +1,40 @@ +{- | This module combines the wrapping and running functions for the 'Reader', +'Writer' and 'State' monad layers in a single layer. + +It is based on the _strict_ 'RWS' monad 'Control.Monad.Trans.RWS.Strict', +so when combining it with other modules such as @mtl@'s, the strict version +has to be included, i.e. 'Control.Monad.RWS.Strict' instead of +'Control.Monad.RWS' or 'Control.Monad.RWS.Lazy'. +-} +module Data.Automaton.Trans.RWS ( + module Data.Automaton.Trans.RWS, + module Control.Monad.Trans.RWS.Strict, +) +where + +-- transformers +import Control.Monad.Trans.RWS.Strict hiding (liftCallCC, liftCatch) + +-- automaton +import Data.Automaton (Automaton, withAutomaton) +import Data.Stream.Result (Result (..)) + +-- * 'RWS' (Reader-Writer-State) monad + +-- | Wrap an 'Automaton' with explicit state variables in 'RWST' monad transformer. +rwsS :: + (Functor m, Monad m, Monoid w) => + Automaton m (r, s, a) (w, s, b) -> + Automaton (RWST r w s m) a b +rwsS = withAutomaton $ \f a -> RWST $ \r s -> + (\(Result c (w, s', b)) -> (Result c b, s', w)) + <$> f (r, s, a) + +-- | Run the 'RWST' layer by making the state variables explicit. +runRWSS :: + (Functor m, Monad m, Monoid w) => + Automaton (RWST r w s m) a b -> + Automaton m (r, s, a) (w, s, b) +runRWSS = withAutomaton $ \f (r, s, a) -> + (\(Result c b, s', w) -> Result c (w, s', b)) + <$> runRWST (f a) r s diff --git a/automaton/src/Data/Automaton/Trans/Random.hs b/automaton/src/Data/Automaton/Trans/Random.hs new file mode 100644 index 000000000..39d7e83cb --- /dev/null +++ b/automaton/src/Data/Automaton/Trans/Random.hs @@ -0,0 +1,94 @@ +{- | An 'Automaton's in a monad supporting random number generation (i.e. +having the 'RandT' layer in its stack) can be run. + +Running means supplying an initial random number generator, +where the update of the generator at every random number generation is already taken care of. + +Under the hood, 'RandT' is basically just 'StateT', with the current random +number generator as mutable state. +-} +module Data.Automaton.Trans.Random ( + runRandS, + evalRandS, + getRandomS, + getRandomsS, + getRandomRS, + getRandomRS_, + getRandomsRS, + getRandomsRS_, +) +where + +-- base +import Control.Arrow (arr, (>>>)) + +-- MonadRandom +import Control.Monad.Random ( + MonadRandom, + RandT, + Random, + RandomGen, + getRandom, + getRandomR, + getRandomRs, + getRandoms, + runRandT, + ) + +-- automaton +import Data.Automaton (Automaton, arrM, constM, hoistS) +import Data.Automaton.Trans.State (StateT (..), runStateS_) + +-- Creating random values + +-- | Create a stream of random values. +getRandomS :: (MonadRandom m, Random b) => Automaton m a b +getRandomS = constM getRandom + +-- | Create a stream of lists of random values. +getRandomsS :: (MonadRandom m, Random b) => Automaton m a [b] +getRandomsS = constM getRandoms + +-- | Create a stream of random values in a given fixed range. +getRandomRS :: (MonadRandom m, Random b) => (b, b) -> Automaton m a b +getRandomRS range = constM $ getRandomR range + +{- | Create a stream of random values in a given range, where the range is +specified on every tick. +-} +getRandomRS_ :: (MonadRandom m, Random b) => Automaton m (b, b) b +getRandomRS_ = arrM getRandomR + +-- | Create a stream of lists of random values in a given fixed range. +getRandomsRS :: (MonadRandom m, Random b) => (b, b) -> Automaton m a [b] +getRandomsRS range = constM $ getRandomRs range + +{- | Create a stream of lists of random values in a given range, where the +range is specified on every tick. +-} +getRandomsRS_ :: (MonadRandom m, Random b) => Automaton m (b, b) [b] +getRandomsRS_ = arrM getRandomRs + +-- * Running automata with random effects + +{- | Run an 'Automaton' in the 'RandT' random number monad transformer by supplying +an initial random generator. Updates and outputs the generator every step. +-} +runRandS :: + (RandomGen g, Functor m, Monad m) => + Automaton (RandT g m) a b -> + -- | The initial random number generator. + g -> + Automaton m a (g, b) +runRandS = runStateS_ . hoistS (StateT . runRandT) + +{- | Evaluate an 'Automaton' in the 'RandT' transformer, i.e. extract possibly random +values by supplying an initial random generator. Updates the generator every +step but discards the generator. +-} +evalRandS :: + (RandomGen g, Functor m, Monad m) => + Automaton (RandT g m) a b -> + g -> + Automaton m a b +evalRandS automaton g = runRandS automaton g >>> arr snd diff --git a/automaton/src/Data/Automaton/Trans/Reader.hs b/automaton/src/Data/Automaton/Trans/Reader.hs new file mode 100644 index 000000000..37c4fa91f --- /dev/null +++ b/automaton/src/Data/Automaton/Trans/Reader.hs @@ -0,0 +1,43 @@ +{- | An 'Automaton' with a 'ReaderT' layer has an extra input. + +This module converts between explicit automata inputs and implicit 'ReaderT' inputs. +-} +module Data.Automaton.Trans.Reader ( + module Control.Monad.Trans.Reader, + readerS, + runReaderS, + runReaderS_, +) +where + +-- base +import Control.Arrow (arr, (>>>)) + +-- transformers +import Control.Monad.Trans.Reader + +-- automaton +import Data.Automaton (Automaton, withAutomaton) + +-- * Reader 'Automaton' running and wrapping + +{- | Convert an explicit 'Automaton' input into an environment in the 'ReaderT' monad transformer. + +This is the opposite of 'runReaderS'. +-} +readerS :: (Monad m) => Automaton m (r, a) b -> Automaton (ReaderT r m) a b +readerS = withAutomaton $ \f a -> ReaderT $ \r -> f (r, a) +{-# INLINE readerS #-} + +{- | Convert an implicit 'ReaderT' environment into an explicit 'Automaton' input. + +This is the opposite of 'readerS'. +-} +runReaderS :: (Monad m) => Automaton (ReaderT r m) a b -> Automaton m (r, a) b +runReaderS = withAutomaton $ \f (r, a) -> runReaderT (f a) r +{-# INLINE runReaderS #-} + +-- | Eliminate a 'ReaderT' layer by providing its environment statically. +runReaderS_ :: (Monad m) => Automaton (ReaderT s m) a b -> s -> Automaton m a b +runReaderS_ automaton s = arr (s,) >>> runReaderS automaton +{-# INLINE runReaderS_ #-} diff --git a/automaton/src/Data/Automaton/Trans/State.hs b/automaton/src/Data/Automaton/Trans/State.hs new file mode 100644 index 000000000..483093650 --- /dev/null +++ b/automaton/src/Data/Automaton/Trans/State.hs @@ -0,0 +1,70 @@ +{- | Handle a global 'StateT' layer in an 'Automaton'. + +A global state can be hidden by an automaton by making it an internal state. + +This module is based on the _strict_ state monad 'Control.Monad.Trans.State.Strict', +so when combining it with other modules such as @mtl@'s, +the strict version has to be included, i.e. 'Control.Monad.State.Strict' +instead of 'Control.Monad.State' or 'Control.Monad.State.Lazy'. +-} +module Data.Automaton.Trans.State ( + module Control.Monad.Trans.State.Strict, + stateS, + runStateS, + runStateS_, + runStateS__, +) +where + +-- base +import Control.Arrow (arr, (>>>)) + +-- transformers +import Control.Monad.Trans.State.Strict +import Data.Tuple (swap) + +-- Internal imports + +import Data.Automaton (Automaton, feedback, withAutomaton) +import Data.Stream.Result (Result (..)) + +-- * 'State' 'Automaton' running and wrapping + +{- | Convert from explicit states to the 'StateT' monad transformer. + +The original automaton is interpreted to take a state as input and return the updated state as output. + +This is the opposite of 'runStateS'. +-} +stateS :: (Functor m, Monad m) => Automaton m (s, a) (s, b) -> Automaton (StateT s m) a b +stateS = withAutomaton $ \f a -> StateT $ \s -> + (\(Result s' (s, b)) -> (Result s' b, s)) + <$> f (s, a) + +{- | Make the state transition in 'StateT' explicit as 'Automaton' inputs and outputs. + +This is the opposite of 'stateS'. +-} +runStateS :: (Functor m, Monad m) => Automaton (StateT s m) a b -> Automaton m (s, a) (s, b) +runStateS = withAutomaton $ \f (s, a) -> + (\(Result s' b, s) -> Result s' (s, b)) + <$> runStateT (f a) s + +{- | Convert global state to internal state of an 'Automaton'. + +The current state is output on every step. +-} +runStateS_ :: + (Functor m, Monad m) => + -- | An automaton with a global state effect + Automaton (StateT s m) a b -> + -- | The initial global state + s -> + Automaton m a (s, b) +runStateS_ automaton s = + feedback s $ + arr swap >>> runStateS automaton >>> arr (\(s', b) -> ((s', b), s')) + +-- | Like 'runStateS_', but don't output the current state. +runStateS__ :: (Functor m, Monad m) => Automaton (StateT s m) a b -> s -> Automaton m a b +runStateS__ automaton s = runStateS_ automaton s >>> arr snd diff --git a/automaton/src/Data/Automaton/Trans/Writer.hs b/automaton/src/Data/Automaton/Trans/Writer.hs new file mode 100644 index 000000000..e3aed3575 --- /dev/null +++ b/automaton/src/Data/Automaton/Trans/Writer.hs @@ -0,0 +1,42 @@ +{- | An 'Automaton' with a 'WriterT' layer outputs an extra monoid value on every step. + +It is based on the _strict_ writer monad 'Control.Monad.Trans.Writer.Strict', +so when combining it with other modules such as @mtl@'s, +the strict version has to be included, i.e. 'Control.Monad.Writer.Strict' +instead of 'Control.Monad.Writer' or 'Control.Monad.Writer.Lazy'. +-} +module Data.Automaton.Trans.Writer ( + module Control.Monad.Trans.Writer.Strict, + writerS, + runWriterS, +) +where + +-- transformers +import Control.Monad.Trans.Writer.Strict hiding (liftCallCC, liftCatch, pass) + +-- automaton +import Data.Automaton (Automaton, withAutomaton) +import Data.Stream.Result (Result (Result)) + +{- | Convert an extra log output into a 'WriterT' effect. + +This is the opposite of 'runWriterS'. +-} +writerS :: + (Functor m, Monad m, Monoid w) => + Automaton m a (w, b) -> + Automaton (WriterT w m) a b +writerS = withAutomaton $ \f a -> WriterT $ (\(Result s (w, b)) -> (Result s b, w)) <$> f a + +{- | Convert a 'WriterT' effect into an extra log output. + +This is the opposite of 'writerS'. +-} +runWriterS :: + (Functor m, Monad m) => + Automaton (WriterT w m) a b -> + Automaton m a (w, b) +runWriterS = withAutomaton $ \f a -> + (\(Result s b, w) -> Result s (w, b)) + <$> runWriterT (f a) diff --git a/automaton/src/Data/Stream.hs b/automaton/src/Data/Stream.hs new file mode 100644 index 000000000..c85cfc2b8 --- /dev/null +++ b/automaton/src/Data/Stream.hs @@ -0,0 +1,417 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Stream where + +-- base +import Control.Applicative (Alternative (..), liftA2) +import Control.Monad ((<$!>)) +import Data.Bifunctor (bimap) +import Data.Monoid (Ap (..)) + +-- transformers +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE, withExceptT) + +-- mmorph +import Control.Monad.Morph (MFunctor (hoist)) + +-- simple-affine-space +import Data.VectorSpace (VectorSpace (..)) + +-- selective +import Control.Selective + +-- these +import Data.These (These (..)) + +-- semialign +import Data.Align + +-- automaton +import Data.Stream.Internal +import Data.Stream.Result + +-- * Creating streams + +{- | Effectful streams in initial encoding. + +A stream consists of an internal state @s@, and a step function. +This step can make use of an effect in @m@ (which is often a monad), +alter the state, and return a result value. +Its semantics is continuously outputting values of type @b@, +while performing side effects in @m@. + +An initial encoding was chosen instead of the final encoding known from e.g. @list-transformer@, @dunai@, @machines@, @streaming@, ..., +because the initial encoding is much more amenable to compiler optimizations +than the final encoding, which is: + +@ + data StreamFinalT m b = StreamFinalT (m (b, StreamFinalT m b)) +@ + +When two streams are composed, GHC can often optimize the combined step function, +resulting in a faster streams than what the final encoding can ever achieve, +because the final encoding has to step through every continuation. +Put differently, the compiler can perform static analysis on the state types of initially encoded state machines, +while the final encoding knows its state only at runtime. + +This performance gain comes at a peculiar cost: +Recursive definitions /of/ streams are not possible, e.g. an equation like: +@ + fixA stream = stream <*> fixA stream +@ +This is impossible since the stream under definition itself appears in the definition body, +and thus the internal /state type/ would be recursively defined, which GHC doesn't allow: +Type level recursion is not supported in existential types. +An stream defined thusly will typically hang and/or leak memory, trying to build up an infinite type at runtime. + +It is nevertheless possible to define streams recursively, but one needs to first identify the recursive definition of its /state type/. +Then for the greatest generality, 'fixStream' and 'fixStream'' can be used, and some special cases are covered by functions +such as 'fixA', 'parallely', 'many' and 'some'. +-} +data StreamT m a = forall s. + StreamT + { state :: s + -- ^ The internal state of the stream + , step :: s -> m (Result s a) + -- ^ Stepping a stream by one tick means: + -- 1. performing a side effect in @m@ + -- 2. updating the internal state @s@ + -- 3. outputting a value of type @a@ + } + +-- | Initialise with an internal state, update the state and produce output without side effects. +unfold :: (Applicative m) => s -> (s -> Result s a) -> StreamT m a +unfold state step = + StreamT + { state + , step = pure . step + } + +-- | Like 'unfold', but output the current state. +unfold_ :: (Applicative m) => s -> (s -> s) -> StreamT m s +unfold_ state step = unfold state $ \s -> let s' = step s in Result s' s' + +-- | Constantly perform the same effect, without remembering a state. +constM :: (Functor m) => m a -> StreamT m a +constM ma = StreamT () $ const $ Result () <$> ma +{-# INLINE constM #-} + +instance (Functor m) => Functor (StreamT m) where + fmap f StreamT {state, step} = StreamT state $! fmap (fmap f) <$> step + {-# INLINE fmap #-} + +-- | 'pure' forever returns the same value, '(<*>)' steps two streams synchronously. +instance (Applicative m) => Applicative (StreamT m) where + pure = constM . pure + {-# INLINE pure #-} + + StreamT stateF0 stepF <*> StreamT stateA0 stepA = + StreamT (JointState stateF0 stateA0) (\(JointState stateF stateA) -> apResult <$> stepF stateF <*> stepA stateA) + {-# INLINE (<*>) #-} + +deriving via Ap (StreamT m) a instance (Applicative m, Num a) => Num (StreamT m a) + +instance (Applicative m, Fractional a) => Fractional (StreamT m a) where + fromRational = pure . fromRational + recip = fmap recip + +instance (Applicative m, Floating a) => Floating (StreamT m a) where + pi = pure pi + exp = fmap exp + log = fmap log + sin = fmap sin + cos = fmap cos + asin = fmap asin + acos = fmap acos + atan = fmap atan + sinh = fmap sinh + cosh = fmap cosh + asinh = fmap asinh + acosh = fmap acosh + atanh = fmap atanh + +instance (VectorSpace v s, Eq s, Floating s, Applicative m) => VectorSpace (StreamT m v) (StreamT m s) where + zeroVector = pure zeroVector + (*^) = liftA2 (*^) + (^+^) = liftA2 (^+^) + dot = liftA2 dot + normalize = fmap normalize + +{- | 'empty' just performs 'empty' in the underlying monad @m@. + @s1 '<|>' s2@ starts in an undecided state, + and explores the possibilities of continuing in @s1@ or @s2@ + on the first tick, using the underlying @m@. +-} +instance (Alternative m) => Alternative (StreamT m) where + empty = constM empty + {-# INLINE empty #-} + + StreamT stateL0 stepL <|> StreamT stateR0 stepR = + StreamT + { state = Undecided + , step = \case + Undecided -> (mapResultState DecideL <$> stepL stateL0) <|> (mapResultState DecideR <$> stepR stateR0) + DecideL stateL -> mapResultState DecideL <$> stepL stateL + DecideR stateR -> mapResultState DecideR <$> stepR stateR + } + {-# INLINE (<|>) #-} + + many StreamT {state, step} = fixStream' + (const NotStarted) + $ \fixstate fixstep -> \case + NotStarted -> ((\(Result s' a) (Result ss' as) -> Result (Ongoing ss' s') $ a : as) <$> step state <*> fixstep fixstate) <|> pure (Result Finished []) + Finished -> pure $! Result Finished [] + Ongoing ss s -> (\(Result s' a) (Result ss' as) -> Result (Ongoing ss' s') $ a : as) <$> step s <*> fixstep ss + {-# INLINE many #-} + + some stream = (:) <$> stream <*> many stream + {-# INLINE some #-} + +instance MFunctor StreamT where + hoist = hoist' + {-# INLINE hoist #-} + +{- | Hoist a stream along a monad morphism, by applying said morphism to the step function. + +This is like @mmorph@'s 'hoist', but it doesn't require a 'Monad' constraint on @m2@. +-} +hoist' :: (forall x. m1 x -> m2 x) -> StreamT m1 a -> StreamT m2 a +hoist' f StreamT {state, step} = StreamT {state, step = f <$> step} +{-# INLINE hoist' #-} + +-- * Running streams + +-- | Perform one step of a stream, resulting in an updated stream and an output value. +stepStream :: (Functor m) => StreamT m a -> m (Result (StreamT m a) a) +stepStream StreamT {state, step} = mapResultState (`StreamT` step) <$> step state +{-# INLINE stepStream #-} + +{- | Run a stream with trivial output. + +If the output of a stream does not contain information, +all of its meaning is in its effects. +This function runs the stream indefinitely. +Since it will never return with a value, this function also has no output (its output is void). +The only way it can return is if @m@ includes some effect of termination, +e.g. 'Maybe' or 'Either' could terminate with a 'Nothing' or 'Left' value, +or 'IO' can raise an exception. +-} +reactimate :: (Monad m) => StreamT m () -> m void +reactimate StreamT {state, step} = go state + where + go s = do + Result s' () <- step s + go s' +{-# INLINE reactimate #-} + +-- | Run a stream, collecting the outputs in a lazy, infinite list. +streamToList :: (Monad m) => StreamT m a -> m [a] +streamToList StreamT {state, step} = go state + where + go s = do + Result s' a <- step s + (a :) <$> go s' +{-# INLINE streamToList #-} + +-- * Modifying streams + +-- | Change the output type and effect of a stream without changing its state type. +withStreamT :: (Functor m, Functor n) => (forall s. m (Result s a) -> n (Result s b)) -> StreamT m a -> StreamT n b +withStreamT f StreamT {state, step} = StreamT state $ fmap f step +{-# INLINE withStreamT #-} + +{- | Buffer the output of a stream, returning one value at a time. + +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. +-} +concatS :: (Monad m) => StreamT m [a] -> StreamT m a +concatS StreamT {state, step} = + StreamT + { state = (state, []) + , step = go + } + where + go (s, []) = do + Result s' as <- step s + go (s', as) + go (s, a : as) = return $ Result (s, as) a +{-# INLINE concatS #-} + +-- ** Exception handling + +{- | Streams with exceptions are 'Applicative' in the exception type. + +Run the first stream until it throws a function as an exception, + then run the second one. If the second one ever throws an exception, + apply the function thrown by the first one to it. +-} +applyExcept :: (Monad m) => StreamT (ExceptT (e1 -> e2) m) a -> StreamT (ExceptT e1 m) a -> StreamT (ExceptT e2 m) a +applyExcept (StreamT state1 step1) (StreamT state2 step2) = + StreamT + { state = Left state1 + , step + } + where + step (Left s1) = do + resultOrException <- lift $ runExceptT $ step1 s1 + case resultOrException of + Right result -> return $! mapResultState Left result + Left f -> step (Right (state2, f)) + step (Right (s2, f)) = mapResultState (Right . (,f)) <$!> withExceptT f (step2 s2) +{-# INLINE applyExcept #-} + +-- | Whenever an exception occurs, output it and retry on the next step. +exceptS :: (Applicative m) => StreamT (ExceptT e m) b -> StreamT m (Either e b) +exceptS StreamT {state, step} = + StreamT + { step = \state -> fmap (either (Result state . Left) (fmap Right)) $ runExceptT $ step state + , state + } +{-# INLINE exceptS #-} + +{- | Run the first stream until it throws an exception. + If the exception is 'Right', throw it immediately. + If it is 'Left', run the second stream until it throws a function, which is then applied to the first exception. +-} +selectExcept :: (Monad m) => StreamT (ExceptT (Either e1 e2) m) a -> StreamT (ExceptT (e1 -> e2) m) a -> StreamT (ExceptT e2 m) a +selectExcept (StreamT stateE0 stepE) (StreamT stateF0 stepF) = + StreamT + { state = Left stateE0 + , step + } + where + step (Left stateE) = do + resultOrException <- lift $ runExceptT $ stepE stateE + case resultOrException of + Right result -> return $ mapResultState Left result + Left (Left e1) -> step (Right (e1, stateF0)) + Left (Right e2) -> throwE e2 + step (Right (e1, stateF)) = withExceptT ($ e1) $ mapResultState (Right . (e1,)) <$> stepF stateF + +instance (Selective m) => Selective (StreamT m) where + select (StreamT stateE0 stepE) (StreamT stateF0 stepF) = + StreamT + { state = JointState stateE0 stateF0 + , step = \(JointState stateE stateF) -> + (fmap (mapResultState (`JointState` stateF)) . eitherResult <$> stepE stateE) + <*? ((\(Result stateF' f) (Result stateE' a) -> Result (JointState stateE' stateF') (f a)) <$> stepF stateF) + } + where + eitherResult :: Result s (Either a b) -> Either (Result s a) (Result s b) + eitherResult (Result s eab) = bimap (Result s) (Result s) eab + +instance (Semialign m) => Semialign (StreamT m) where + align (StreamT s10 step1) (StreamT s20 step2) = + StreamT + { state = These s10 s20 + , step = \case + This s1 -> mapResultState This . fmap This <$> step1 s1 + That s2 -> mapResultState That . fmap That <$> step2 s2 + These s1 s2 -> commuteTheseResult <$> align (step1 s1) (step2 s2) + } + where + commuteTheseResult :: These (Result s1 a1) (Result s2 a2) -> Result (These s1 s2) (These a1 a2) + commuteTheseResult (This (Result s1 a1)) = Result (This s1) (This a1) + commuteTheseResult (That (Result s2 a2)) = Result (That s2) (That a2) + commuteTheseResult (These (Result s1 a1) (Result s2 a2)) = Result (These s1 s2) (These a1 a2) + {-# INLINE align #-} + +instance (Align m) => Align (StreamT m) where + nil = constM nil + {-# INLINE nil #-} + +-- ** Fix points, or recursive definitions + +{- | Recursively define a stream from a recursive definition of the state, and of the step function. + +If you want to define a stream recursively, this is not possible directly. +For example, consider this definition: +@ +loops :: Monad m => StreamT m [Int] +loops = (:) <$> unfold_ 0 (+ 1) <*> loops +@ +The defined value @loops@ contains itself in its definition. +This means that the internal state type of @loops@ must itself be recursively defined. +But GHC cannot do this automatically, because type level and value level are separate. +Instead, we need to spell out the type level recursion explicitly with a type constructor, +over which we will take the fixpoint. + +In this example, we can figure out from the definitions that: +1. @'unfold_' 0 (+ 1)@ has @0 :: Int@ as state +2. '(:)' does not change the state +3. '<*>' takes the product of both states + +So the internal state @s@ of @loops@ must satisfy the equation @s = (Int, s)@. +If the recursion is written as above, it tries to compute the infinite tuple @(Int, (Int, (Int, ...)))@, which hangs. +Instead, we need to define a type operator over which we take the fixpoint: + +@ +-- You need to write this: +data Loops x = Loops Int x + +-- The library supplies: +data Fix f = Fix f (Fix f) +type LoopsState = Fix Loops +@ + +We can then use 'fixStream' to define the recursive definition of @loops@. +For this, we have to to tediously inline the definitions of 'unfold_', '(:)', and '<*>', +until we arrive at an explicit recursive definition of the state and the step function of @loops@, separately. +These are the two arguments of 'fixStream'. + +@ +loops :: Monad m => StreamT m [Int] +loops = fixStream (Loops 0) $ \fixStep (Loops n fixState) -> do + Result s' a <- fixStep fixState + return $ Result (Loops (n + 1) s') a +@ +-} +fixStream :: + (Functor m) => + -- | The recursive definition of the state of the stream. + (forall s. s -> t s) -> + -- | The recursive definition of the step function of the stream. + ( forall s. + (s -> m (Result s a)) -> + (t s -> m (Result (t s) a)) + ) -> + StreamT m a +fixStream transformState transformStep = + StreamT + { state = fixState transformState + , step + } + where + step Fix {getFix} = mapResultState Fix <$> transformStep step getFix + +-- | A generalisation of 'fixStream' where the step definition is allowed to depend on the state. +fixStream' :: + (Functor m) => + (forall s. s -> t s) -> + -- | The recursive definition of the state of the stream. + (forall s. s -> (s -> m (Result s a)) -> (t s -> m (Result (t s) a))) -> + -- | The recursive definition of the step function of the stream. + StreamT m a +fixStream' transformState transformStep = + StreamT + { state = fixState transformState + , step + } + where + step fix@(Fix {getFix}) = mapResultState Fix <$> transformStep fix step getFix + +{- | The solution to the equation @'fixA stream = stream <*> 'fixA' stream@. + +Such a fix point operator needs to be used instead of the above direct definition because recursive definitions of streams +loop at runtime due to the initial encoding of the state. +-} +fixA :: (Applicative m) => StreamT m (a -> a) -> StreamT m a +fixA StreamT {state, step} = fixStream (JointState state) $ + \stepA (JointState s ss) -> apResult <$> step s <*> stepA ss diff --git a/automaton/src/Data/Stream/Except.hs b/automaton/src/Data/Stream/Except.hs new file mode 100644 index 000000000..4af7d34a7 --- /dev/null +++ b/automaton/src/Data/Stream/Except.hs @@ -0,0 +1,56 @@ +module Data.Stream.Except where + +-- base +import Control.Monad (ap) +import Data.Void + +-- transformers +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except + +-- mmorph +import Control.Monad.Morph (MFunctor, hoist) + +-- selective +import Control.Selective + +-- automaton +import Data.Stream.Final (Final (..)) +import Data.Stream.Final.Except +import Data.Stream.Optimized (OptimizedStreamT, applyExcept, constM, selectExcept) +import Data.Stream.Optimized qualified as StreamOptimized + +data StreamExcept m a e + = -- | When using '>>=', this encoding needs to be used. + FinalExcept (Final (ExceptT e m) a) + | -- | This is usually the faster encoding, as it can be optimized by GHC. + InitialExcept (OptimizedStreamT (ExceptT e m) a) + +toFinal :: (Functor m) => StreamExcept m a e -> Final (ExceptT e m) a +toFinal (FinalExcept final) = final +toFinal (InitialExcept initial) = StreamOptimized.toFinal initial + +runStreamExcept :: StreamExcept m a e -> OptimizedStreamT (ExceptT e m) a +runStreamExcept (FinalExcept final) = StreamOptimized.fromFinal final +runStreamExcept (InitialExcept initial) = initial + +instance (Monad m) => Functor (StreamExcept m a) where + fmap f (FinalExcept fe) = FinalExcept $ hoist (withExceptT f) fe + fmap f (InitialExcept ae) = InitialExcept $ hoist (withExceptT f) ae + +instance (Monad m) => Applicative (StreamExcept m a) where + pure = InitialExcept . constM . throwE + InitialExcept f <*> InitialExcept a = InitialExcept $ applyExcept f a + f <*> a = ap f a + +instance (Monad m) => Selective (StreamExcept m a) where + select (InitialExcept e) (InitialExcept f) = InitialExcept $ selectExcept e f + select e f = selectM e f + +-- | 'return'/'pure' throw exceptions, '(>>=)' uses the last thrown exception as input for an exception handler. +instance (Monad m) => Monad (StreamExcept m a) where + (>>) = (*>) + ae >>= f = FinalExcept $ handleExceptT (toFinal ae) (toFinal . f) + +safely :: (Monad m) => StreamExcept m a Void -> OptimizedStreamT m a +safely = hoist (fmap (either absurd id) . runExceptT) . runStreamExcept diff --git a/automaton/src/Data/Stream/Final.hs b/automaton/src/Data/Stream/Final.hs new file mode 100644 index 000000000..ab6a0820e --- /dev/null +++ b/automaton/src/Data/Stream/Final.hs @@ -0,0 +1,63 @@ +module Data.Stream.Final where + +-- base +import Control.Applicative (Alternative (..)) + +-- mmorph +import Control.Monad.Morph (MFunctor (..)) + +-- automaton +import Data.Stream (StreamT (..), stepStream) +import Data.Stream.Result + +{- | A stream transformer in final encoding. + +One step of the stream transformer performs a monadic action and results in an output and a new stream. +-} +newtype Final m a = Final {getFinal :: m (Result (Final m a) a)} + +{- | Translate an initially encoded stream into a finally encoded one. + +This is usually a performance penalty. +-} +toFinal :: (Functor m) => StreamT m a -> Final m a +toFinal automaton = Final $ mapResultState toFinal <$> stepStream automaton +{-# INLINE toFinal #-} + +{- | Translate a finally encoded stream into an initially encoded one. + +The internal state is the stream itself. +-} +fromFinal :: Final m a -> StreamT m a +fromFinal final = + StreamT + { state = final + , step = getFinal + } +{-# INLINE fromFinal #-} + +instance MFunctor Final where + hoist morph = go + where + go Final {getFinal} = Final $ morph $ mapResultState go <$> getFinal + +instance (Functor m) => Functor (Final m) where + fmap f Final {getFinal} = Final $ fmap f . mapResultState (fmap f) <$> getFinal + +instance (Applicative m) => Applicative (Final m) where + pure a = go + where + go = Final $! pure $! Result go a + + Final mf <*> Final ma = Final $! (\(Result cf f) (Result ca a) -> Result (cf <*> ca) $! f a) <$> mf <*> ma + +-- | Constantly perform the same effect, without remembering a state. +constM :: (Functor m) => m a -> Final m a +constM ma = go + where + go = Final $ Result go <$> ma + +instance (Alternative m) => Alternative (Final m) where + empty = constM empty + + Final ma1 <|> Final ma2 = Final $ ma1 <|> ma2 diff --git a/automaton/src/Data/Stream/Final/Except.hs b/automaton/src/Data/Stream/Final/Except.hs new file mode 100644 index 000000000..0a638a073 --- /dev/null +++ b/automaton/src/Data/Stream/Final/Except.hs @@ -0,0 +1,18 @@ +module Data.Stream.Final.Except where + +-- transformers +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except (ExceptT, runExceptT) + +-- automaton +import Data.Stream.Final (Final (..)) +import Data.Stream.Result (mapResultState) + +handleExceptT :: (Monad m) => Final (ExceptT e1 m) b -> (e1 -> Final (ExceptT e2 m) b) -> Final (ExceptT e2 m) b +handleExceptT final handler = go final + where + go final = Final $ do + resultOrException <- lift $ runExceptT $ getFinal final + case resultOrException of + Right result -> return $! mapResultState go result + Left e -> getFinal $ handler e diff --git a/automaton/src/Data/Stream/Internal.hs b/automaton/src/Data/Stream/Internal.hs new file mode 100644 index 000000000..6885da2e1 --- /dev/null +++ b/automaton/src/Data/Stream/Internal.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StrictData #-} + +module Data.Stream.Internal where + +-- | A strict tuple type +data JointState a b = JointState a b + +-- | Internal state of the result of 'Alternative' constructions +data Alternatively stateL stateR = Undecided | DecideL stateL | DecideR stateR + +-- | Internal state of 'many' and 'some' +data Many state x = NotStarted | Ongoing x state | Finished + +-- newtype makes GHC loop on using fixStream +{- HLINT ignore Fix "Use newtype instead of data" -} +data Fix t = Fix {getFix :: ~(t (Fix t))} + +fixState :: (forall s. s -> t s) -> Fix t +fixState transformState = go + where + go = Fix $ transformState go diff --git a/automaton/src/Data/Stream/Optimized.hs b/automaton/src/Data/Stream/Optimized.hs new file mode 100644 index 000000000..ef30ff2c5 --- /dev/null +++ b/automaton/src/Data/Stream/Optimized.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | An optimization layer on 'Data.Stream'. + +Since both variants are semantically the same, not the full API of 'Data.Stream' is replicated here. +-} +module Data.Stream.Optimized where + +-- base +import Control.Applicative (Alternative (..), liftA2) +import Data.Monoid (Ap (..)) + +-- transformers +import Control.Monad.Trans.Except (ExceptT) + +-- selective +import Control.Selective (Selective (select)) + +-- simple-affine-space +import Data.VectorSpace + +-- mmorph +import Control.Monad.Morph + +-- automaton + +import Data.Align (Align, Semialign) +import Data.Semialign (Align (..), Semialign (..)) +import Data.Stream hiding (hoist') +import Data.Stream qualified as StreamT +import Data.Stream.Final (Final (..)) +import Data.Stream.Final qualified as Final (fromFinal, toFinal) +import Data.Stream.Result + +{- | An optimized version of 'StreamT' which has an extra constructor for stateless streams. + +In most cases, using 'OptimizedStreamT' is preferable over 'StreamT', +because building up bigger programs with 'StreamT' will build up big accumulations of trivial states. +The API of 'OptimizedStreamT' only keeps the nontrivial parts of the state. + +Semantically, both types are the same. +-} +data OptimizedStreamT m a + = -- | Embed a 'StreamT'. Take care only to use this constructor on streams with nontrivial state. + Stateful (StreamT m a) + | -- | A stateless stream is simply an action in a monad which is performed repetitively. + Stateless (m a) + deriving (Functor) + +{- | Remove the optimization layer. + +For stateful streams, this is just the identity. +A stateless stream is encoded as a stream with state '()'. +-} +toStreamT :: (Functor m) => OptimizedStreamT m b -> StreamT m b +toStreamT (Stateful stream) = stream +toStreamT (Stateless m) = StreamT {state = (), step = const $ Result () <$> m} +{-# INLINE toStreamT #-} + +-- | Only builds up tuples of states if both streams are stateful. +instance (Applicative m) => Applicative (OptimizedStreamT m) where + pure = Stateless . pure + {-# INLINE pure #-} + + Stateful stream1 <*> Stateful stream2 = Stateful $ stream1 <*> stream2 + Stateless m <*> Stateful (StreamT state0 step) = Stateful $ StreamT state0 $ \state -> fmap . ($) <$> m <*> step state + Stateful (StreamT state0 step) <*> Stateless m = Stateful $ StreamT state0 $ \state -> flip (fmap . flip ($)) <$> step state <*> m + Stateless mf <*> Stateless ma = Stateless $ mf <*> ma + {-# INLINE (<*>) #-} + +deriving via Ap (OptimizedStreamT m) a instance (Applicative m, Num a) => Num (OptimizedStreamT m a) + +instance (Applicative m, Fractional a) => Fractional (OptimizedStreamT m a) where + fromRational = pure . fromRational + recip = fmap recip + +instance (Applicative m, Floating a) => Floating (OptimizedStreamT m a) where + pi = pure pi + exp = fmap exp + log = fmap log + sin = fmap sin + cos = fmap cos + asin = fmap asin + acos = fmap acos + atan = fmap atan + sinh = fmap sinh + cosh = fmap cosh + asinh = fmap asinh + acosh = fmap acosh + atanh = fmap atanh + +instance (VectorSpace v s, Eq s, Floating s, Applicative m) => VectorSpace (OptimizedStreamT m v) (OptimizedStreamT m s) where + zeroVector = pure zeroVector + (*^) = liftA2 (*^) + (^+^) = liftA2 (^+^) + dot = liftA2 dot + normalize = fmap normalize + +instance (Alternative m) => Alternative (OptimizedStreamT m) where + empty = Stateless empty + {-# INLINE empty #-} + + -- The semantics prescribe that we save the state which stream was selected. + stream1 <|> stream2 = Stateful $ toStreamT stream1 <|> toStreamT stream2 + {-# INLINE (<|>) #-} + + many stream = Stateful $ many $ toStreamT stream + {-# INLINE many #-} + + some stream = Stateful $ some $ toStreamT stream + {-# INLINE some #-} + +instance (Selective m) => Selective (OptimizedStreamT m) where + select (Stateless mab) (Stateless f) = Stateless $ select mab f + select stream1 stream2 = Stateful $ select (toStreamT stream1) (toStreamT stream2) + +instance (Semialign m) => Semialign (OptimizedStreamT m) where + align (Stateless ma) (Stateless mb) = Stateless $ align ma mb + align stream1 stream2 = Stateful $ align (toStreamT stream1) (toStreamT stream2) + +instance (Align m) => Align (OptimizedStreamT m) where + nil = Stateless nil + +instance MFunctor OptimizedStreamT where + hoist = hoist' + {-# INLINE hoist #-} + +-- | Like 'hoist', but without the @'Monad' m2@ constraint. +hoist' :: (forall x. m1 x -> m2 x) -> OptimizedStreamT m1 a -> OptimizedStreamT m2 a +hoist' f (Stateful stream) = Stateful $ StreamT.hoist' f stream +hoist' f (Stateless m) = Stateless $ f m +{-# INLINE hoist' #-} + +-- | Change the output type and effect of a stream without changing its state type. +mapOptimizedStreamT :: (Functor m, Functor n) => (forall s. m (Result s a) -> n (Result s b)) -> OptimizedStreamT m a -> OptimizedStreamT n b +mapOptimizedStreamT f (Stateful stream) = Stateful $ withStreamT f stream +mapOptimizedStreamT f (Stateless m) = Stateless $ fmap output $ f $ fmap (Result ()) m +{-# INLINE mapOptimizedStreamT #-} + +{- | Map a monad-independent morphism of streams to optimized streams. + +In contrast to 'handleOptimized', the stream morphism must be independent of the monad. +-} +withOptimized :: (Monad n) => (forall m. (Monad m) => StreamT m a -> StreamT m b) -> OptimizedStreamT n a -> OptimizedStreamT n b +withOptimized f stream = Stateful $ f $ toStreamT stream + +{- | Map a morphism of streams to optimized streams. + +In contrast to 'withOptimized', the monad type is allowed to change. +-} +handleOptimized :: (Functor m) => (StreamT m a -> StreamT n b) -> OptimizedStreamT m a -> OptimizedStreamT n b +handleOptimized f stream = Stateful $ f $ toStreamT stream + +{- | Run a stream with trivial output. + +See 'Data.Stream.reactimate'. +-} +reactimate :: (Monad m) => OptimizedStreamT m () -> m void +reactimate (Stateful stream) = StreamT.reactimate stream +reactimate (Stateless f) = go + where + go = f *> go +{-# INLINE reactimate #-} + +{- | A stateless stream. + +This function is typically preferable over 'Data.Stream.constM', +since the optimized version doesn't create a state type. +-} +constM :: m a -> OptimizedStreamT m a +constM = Stateless +{-# INLINE constM #-} + +-- | Perform one step of a stream, resulting in an updated stream and an output value. +stepOptimizedStream :: (Functor m) => OptimizedStreamT m a -> m (Result (OptimizedStreamT m a) a) +stepOptimizedStream (Stateful stream) = mapResultState Stateful <$> stepStream stream +stepOptimizedStream oa@(Stateless m) = Result oa <$> m +{-# INLINE stepOptimizedStream #-} + +{- | Translate to the final encoding of streams. + +This will typically be a performance penalty. +-} +toFinal :: (Functor m) => OptimizedStreamT m a -> Final m a +toFinal (Stateful stream) = Final.toFinal stream +toFinal (Stateless f) = go + where + go = Final $ Result go <$> f +{-# INLINE toFinal #-} + +{- | Translate a stream from final encoding to stateful, initial encoding. + The internal state is the stream itself. +-} +fromFinal :: Final m a -> OptimizedStreamT m a +fromFinal = Stateful . Final.fromFinal +{-# INLINE fromFinal #-} + +-- | See 'Data.Stream.concatS'. +concatS :: (Monad m) => OptimizedStreamT m [a] -> OptimizedStreamT m a +concatS stream = Stateful $ StreamT.concatS $ toStreamT stream +{-# INLINE concatS #-} + +-- | See 'Data.Stream.exceptS'. +exceptS :: (Monad m) => OptimizedStreamT (ExceptT e m) b -> OptimizedStreamT m (Either e b) +exceptS stream = Stateful $ StreamT.exceptS $ toStreamT stream +{-# INLINE exceptS #-} + +-- | See 'Data.Stream.applyExcept'. +applyExcept :: (Monad m) => OptimizedStreamT (ExceptT (e1 -> e2) m) a -> OptimizedStreamT (ExceptT e1 m) a -> OptimizedStreamT (ExceptT e2 m) a +applyExcept streamF streamA = Stateful $ StreamT.applyExcept (toStreamT streamF) (toStreamT streamA) +{-# INLINE applyExcept #-} + +-- | See 'Data.Stream.selectExcept'. +selectExcept :: (Monad m) => OptimizedStreamT (ExceptT (Either e1 e2) m) a -> OptimizedStreamT (ExceptT (e1 -> e2) m) a -> OptimizedStreamT (ExceptT e2 m) a +selectExcept streamE streamF = Stateful $ StreamT.selectExcept (toStreamT streamE) (toStreamT streamF) +{-# INLINE selectExcept #-} diff --git a/automaton/src/Data/Stream/Result.hs b/automaton/src/Data/Stream/Result.hs new file mode 100644 index 000000000..cb9461f64 --- /dev/null +++ b/automaton/src/Data/Stream/Result.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE StrictData #-} + +module Data.Stream.Result where + +-- base +import Data.Bifunctor (Bifunctor (..)) + +-- automaton +import Data.Stream.Internal + +{- | A tuple that is strict in its first argument. + +This type is used in streams and automata to encode the result of a state transition. +The new state should always be strict to avoid space leaks. +-} +data Result s a = Result {resultState :: s, output :: ~a} + deriving (Functor) + +instance Bifunctor Result where + second = fmap + first = mapResultState + +-- | Apply a function to the state of a 'Result'. +mapResultState :: (s1 -> s2) -> Result s1 a -> Result s2 a +mapResultState f Result {resultState, output} = Result {resultState = f resultState, output} +{-# INLINE mapResultState #-} + +-- | Analogous to 'Applicative''s '(<*>)'. +apResult :: Result s1 (a -> b) -> Result s2 a -> Result (JointState s1 s2) b +apResult (Result resultStateA outputF) (Result resultStateB outputA) = Result (JointState resultStateA resultStateB) $ outputF outputA +{-# INLINE apResult #-} + +-- | A state transformer with 'Result' instead of a standard tuple as its result. +newtype ResultStateT s m a = ResultStateT {getResultStateT :: s -> m (Result s a)} + deriving (Functor) + +instance (Monad m) => Applicative (ResultStateT s m) where + pure output = ResultStateT (\resultState -> pure Result {resultState, output}) + + ResultStateT mf <*> ResultStateT ma = ResultStateT $ \s -> do + Result s' f <- mf s + Result s'' a <- ma s' + pure (Result s'' (f a)) diff --git a/automaton/test/Automaton.hs b/automaton/test/Automaton.hs new file mode 100644 index 000000000..6086fa2ec --- /dev/null +++ b/automaton/test/Automaton.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Automaton where + +-- base +import Control.Applicative (Alternative (..)) +import Control.Arrow +import Data.Functor.Identity (runIdentity) +import Data.List (uncons) +import Data.Maybe (maybeToList) + +-- transformers +import Control.Monad.State.Strict + +-- selective +import Control.Selective ((<*?)) + +-- tasty +import Test.Tasty (testGroup) + +-- tasty-quickcheck +import Test.Tasty.QuickCheck + +-- tasty-hunit +import Test.Tasty.HUnit (testCase, (@?=)) + +-- automaton +import Automaton.Except +import Data.Automaton +import Data.Automaton.Final +import Data.Automaton.Trans.Maybe + +tests = + testGroup + "Automaton" + [ testGroup + "Alternative" + [ testGroup + "<|>" + [ testProperty "has same semantics as final" $ + \(input :: [(Maybe Int, Maybe Int)]) -> + embed ((arr fst >>> inMaybe) <|> (arr snd >>> inMaybe)) input + === embed (fromFinal $ (arr fst >>> toFinal inMaybe) <|> (arr snd >>> toFinal inMaybe)) input + ] + , testGroup + "some" + [ testCase "Maybe" $ embed (some $ arrM id) [Nothing] @?= (Nothing :: Maybe [[()]]) + , testCase "Parser" $ runParser (embed (some $ constM aChar) [(), ()]) "hi" @?= [(["h", "i"], "")] + ] + , testGroup + "many" + [ testCase "Maybe" $ embed (many $ arrM id) [Nothing] @?= (Just [[]] :: Maybe [[()]]) + , testCase "Parser" $ runParser (many (char 'h')) "hi" @?= [("h", "i"), ("", "hi")] + ] + ] + , testGroup + "parallely" + [ testCase "Outputs separate sums" $ runIdentity (embed (parallely sumN) [[], [], [1, 2], [10, 20], [100], [], [1000, 200]]) @?= [[], [], [1, 2], [11, 22], [111], [], [1111, 222]] + ] + , testGroup + "Selective" + [ testCase "selects second Automaton conditionally" $ + runIdentity (embed (right sumN <*? arr (const (* 2))) [Right 1, Right 2, Left 10, Right 3, Left 20]) @?= [1, 3, 20, 6, 40] + ] + , testCase "count" $ runIdentity (embed count [(), (), ()]) @?= [1, 2, 3] + , testCase "delay" $ runIdentity (embed (count >>> delay 0) [(), (), ()]) @?= [0, 1, 2] + , testCase "sumS" $ runIdentity (embed (arr (const (1 :: Float)) >>> sumS) [(), (), ()]) @?= [1, 2, 3] + , testCase "sumN" $ runIdentity (embed (arr (const (1 :: Integer)) >>> sumN) [(), (), ()]) @?= [1, 2, 3] + , Automaton.Except.tests + ] + +inMaybe :: Automaton Maybe (Maybe a) a +inMaybe = hoistS (runIdentity . runMaybeT) inMaybeT + +-- * Parser helper type to test many & some + +newtype Parser a = Parser {getParser :: StateT String [] a} + deriving (Functor, Applicative, Monad, Alternative) + +runParser :: Parser a -> String -> [(a, String)] +runParser = runStateT . getParser + +aChar :: Parser Char +aChar = Parser $ StateT $ maybeToList . uncons + +char :: Char -> Parser Char +char c = do + c' <- aChar + guard $ c == c' + return c diff --git a/automaton/test/Automaton/Except.hs b/automaton/test/Automaton/Except.hs new file mode 100644 index 000000000..ab2574311 --- /dev/null +++ b/automaton/test/Automaton/Except.hs @@ -0,0 +1,16 @@ +module Automaton.Except where + +-- base +import Control.Monad.Identity (Identity (runIdentity)) + +-- tasty +import Test.Tasty (testGroup) + +-- tasty-hunit +import Test.Tasty.HUnit (testCase, (@?=)) + +-- rhine +import Data.Automaton (embed) +import Data.Automaton.Trans.Except (safe, safely, step) + +tests = testGroup "Except" [testCase "step" $ runIdentity (embed (safely $ step (\a -> return (a, ())) >> safe 0) [1, 1, 1]) @?= [1, 0, 0]] diff --git a/automaton/test/Main.hs b/automaton/test/Main.hs new file mode 100644 index 000000000..a5d7b4e7a --- /dev/null +++ b/automaton/test/Main.hs @@ -0,0 +1,16 @@ +module Main where + +-- tasty +import Test.Tasty + +-- automaton +import Automaton +import Stream + +main = + defaultMain $ + testGroup + "Main" + [ Automaton.tests + , Stream.tests + ] diff --git a/automaton/test/Stream.hs b/automaton/test/Stream.hs new file mode 100644 index 000000000..4e4ce2655 --- /dev/null +++ b/automaton/test/Stream.hs @@ -0,0 +1,31 @@ +module Stream where + +-- base +import Control.Monad.Identity (Identity (..)) + +-- selective +import Control.Selective + +-- tasty +import Test.Tasty (testGroup) + +-- tasty-hunit +import Test.Tasty.HUnit (testCase, (@?=)) + +-- automaton +import Automaton +import Data.Stream (streamToList, unfold) +import Data.Stream.Result + +tests = + testGroup + "Stream" + [ Automaton.tests + , testGroup + "Selective" + [ testCase "Selects second stream based on first stream" $ + let automaton1 = unfold 0 (\n -> Result (n + 1) (if even n then Right n else Left n)) + automaton2 = pure (* 10) + in take 10 (runIdentity (streamToList (automaton1 <*? automaton2))) @?= [0, 10, 2, 30, 4, 50, 6, 70, 8, 90] + ] + ] diff --git a/flake.nix b/flake.nix index 440ab3060..c686d9281 100644 --- a/flake.nix +++ b/flake.nix @@ -45,6 +45,6 @@ outputs = { self, nixpkgs, flake-utils, haskell-flake-utils, flake-compat, ... } }; name = "rhine"; - packageNames = [ "rhine-gloss" "rhine-terminal" "rhine-examples" "rhine-bayes" ]; + packageNames = [ "automaton" "rhine-gloss" "rhine-terminal" "rhine-examples" "rhine-bayes" ]; }; } diff --git a/rhine-bayes/app/Main.hs b/rhine-bayes/app/Main.hs index cba3f783d..f315bf848 100644 --- a/rhine-bayes/app/Main.hs +++ b/rhine-bayes/app/Main.hs @@ -39,8 +39,8 @@ import Control.Monad.Bayes.Class hiding (posterior, prior) import Control.Monad.Bayes.Population hiding (hoist) import Control.Monad.Bayes.Sampler.Strict --- dunai -import Control.Monad.Trans.MSF.Except +-- automaton +import Data.Automaton.Trans.Except -- rhine import FRP.Rhine @@ -239,21 +239,11 @@ drawParticleTemperature = proc (temperature, probability) -> do arrMCl paintIO -< toThermometer $ translate 0 (double2Float temperature * thermometerScale) $ color (withAlpha (double2Float $ exp $ 0.2 * ln probability) white) $ rectangleSolid thermometerWidth 2 drawParticles :: BehaviourF App td [(Pos, Log Double)] () -drawParticles = proc particlesPosition -> do - case particlesPosition of - [] -> returnA -< () - p : ps -> do - drawParticle -< p - drawParticles -< ps +drawParticles = traverseS_ drawParticle -- FIXME abstract using a library drawParticlesTemperature :: BehaviourF App td [(Temperature, Log Double)] () -drawParticlesTemperature = proc particlesPosition -> do - case particlesPosition of - [] -> returnA -< () - p : ps -> do - drawParticleTemperature -< p - drawParticlesTemperature -< ps +drawParticlesTemperature = traverseS_ drawParticleTemperature glossSettings :: GlossSettings glossSettings = @@ -398,19 +388,19 @@ userTemperature = tagS >>> arr (selector >>> fmap Product) >>> mappendS >>> arr -} inference :: Rhine (GlossConcT IO) (LiftClock IO GlossConcT Busy) (Temperature, (Sensor, Pos)) Result inference = hoistClSF sampleIOGloss inferenceBehaviour @@ liftClock Busy - where - inferenceBehaviour :: (MonadDistribution m, Diff td ~ Double, MonadIO m) => BehaviourF m td (Temperature, (Sensor, Pos)) Result - inferenceBehaviour = proc (temperature, (measured, latent)) -> do - positionsAndTemperatures <- runPopulationCl nParticles resampleSystematic posteriorTemperatureProcess -< measured - returnA - -< - Result - { temperature - , measured - , latent - , particlesPosition = first snd <$> positionsAndTemperatures - , particlesTemperature = first fst <$> positionsAndTemperatures - } + +inferenceBehaviour :: (MonadDistribution m, Diff td ~ Double, MonadIO m) => BehaviourF m td (Temperature, (Sensor, Pos)) Result +inferenceBehaviour = proc (temperature, (measured, latent)) -> do + positionsAndTemperatures <- runPopulationCl nParticles resampleSystematic posteriorTemperatureProcess -< measured + returnA + -< + Result + { temperature + , measured + , latent + , particlesPosition = first snd <$> positionsAndTemperatures + , particlesTemperature = first fst <$> positionsAndTemperatures + } -- | Visualize the current 'Result' at a rate controlled by the @gloss@ backend, usually 30 FPS. visualisationRhine :: Rhine (GlossConcT IO) (GlossClockUTC GlossSimClockIO) Result () diff --git a/rhine-bayes/rhine-bayes.cabal b/rhine-bayes/rhine-bayes.cabal index a00b12d9e..afb5f9147 100644 --- a/rhine-bayes/rhine-bayes.cabal +++ b/rhine-bayes/rhine-bayes.cabal @@ -30,11 +30,12 @@ source-repository this library exposed-modules: FRP.Rhine.Bayes - other-modules: Data.MonadicStreamFunction.Bayes + other-modules: Data.Automaton.Bayes build-depends: + automaton, base >=4.11 && <4.18, - dunai ^>=0.12.2, log-domain >=0.12, + mmorph ^>=1.2, monad-bayes ^>=1.2, rhine ==1.2, transformers >=0.5 @@ -64,8 +65,8 @@ executable rhine-bayes-gloss main-is: Main.hs hs-source-dirs: app build-depends: + automaton, base >=4.11 && <4.18, - dunai, log-domain, mmorph, monad-bayes, diff --git a/rhine-bayes/src/Data/Automaton/Bayes.hs b/rhine-bayes/src/Data/Automaton/Bayes.hs new file mode 100644 index 000000000..07e51b687 --- /dev/null +++ b/rhine-bayes/src/Data/Automaton/Bayes.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Data.Automaton.Bayes where + +-- base +import Control.Arrow + +-- transformers +import Control.Monad.Trans.Reader (ReaderT (..)) + +-- log-domain +import Numeric.Log hiding (sum) + +-- monad-bayes +import Control.Monad.Bayes.Population (PopulationT (..), fromWeightedList, runPopulationT) + +-- mmorph +import Control.Monad.Morph (hoist) + +-- automaton +import Data.Automaton (Automaton (..), handleAutomaton) +import Data.Stream (StreamT (..)) +import Data.Stream.Result (Result (..)) + +-- | Run the Sequential Monte Carlo algorithm continuously on an 'Automaton' +runPopulationS :: + forall m a b. + (Monad m) => + -- | Number of particles + Int -> + -- | Resampler + (forall x. PopulationT m x -> PopulationT m x) -> + Automaton (PopulationT m) a b -> + -- FIXME Why not Automaton m a (PopulationT b) + Automaton m a [(b, Log Double)] +runPopulationS nParticles resampler = + handleAutomaton + ( runPopulationStream + (commuteReaderPopulation . hoist resampler . commuteReaderPopulationBack) + . hoist commuteReaderPopulation + ) + where + commuteReaderPopulation :: forall m r a. (Monad m) => ReaderT r (PopulationT m) a -> PopulationT (ReaderT r m) a + commuteReaderPopulation = fromWeightedList . ReaderT . fmap runPopulationT . runReaderT + + commuteReaderPopulationBack :: forall m r a. (Monad m) => PopulationT (ReaderT r m) a -> ReaderT r (PopulationT m) a + commuteReaderPopulationBack = ReaderT . fmap fromWeightedList . runReaderT . runPopulationT + + runPopulationStream :: + forall m b. + (Monad m) => + (forall x. PopulationT m x -> PopulationT m x) -> + StreamT (PopulationT m) b -> + StreamT m [(b, Log Double)] + runPopulationStream resampler StreamT {step, state} = + StreamT + { state = replicate nParticles (state, 1 / fromIntegral nParticles) + , step = \states -> do + resultsAndProbabilities <- runPopulationT $ normalize $ resampler $ do + state <- fromWeightedList $ pure states + step state + return $! Result (first resultState <$> resultsAndProbabilities) (first output <$> resultsAndProbabilities) + } + +-- FIXME see PR re-adding this to monad-bayes +normalize :: (Monad m) => PopulationT m a -> PopulationT m a +normalize = fromWeightedList . fmap (\particles -> second (/ (sum $ snd <$> particles)) <$> particles) . runPopulationT diff --git a/rhine-bayes/src/Data/MonadicStreamFunction/Bayes.hs b/rhine-bayes/src/Data/MonadicStreamFunction/Bayes.hs deleted file mode 100644 index 05ed84871..000000000 --- a/rhine-bayes/src/Data/MonadicStreamFunction/Bayes.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Data.MonadicStreamFunction.Bayes where - --- base -import Control.Arrow -import Data.Functor (($>)) -import Data.Tuple (swap) - --- transformers - --- log-domain -import Numeric.Log hiding (sum) - --- monad-bayes -import Control.Monad.Bayes.Population - --- dunai -import Data.MonadicStreamFunction -import Data.MonadicStreamFunction.InternalCore (MSF (..)) - --- | Run the Sequential Monte Carlo algorithm continuously on an 'MSF' -runPopulationS :: - forall m a b. - (Monad m) => - -- | Number of particles - Int -> - -- | Resampler - (forall x. PopulationT m x -> PopulationT m x) -> - MSF (PopulationT m) a b -> - -- FIXME Why not MSF m a (PopulationT b) - MSF m a [(b, Log Double)] -runPopulationS nParticles resampler = runPopulationsS resampler . (spawn nParticles $>) - --- | Run the Sequential Monte Carlo algorithm continuously on a 'PopulationT' of 'MSF's -runPopulationsS :: - (Monad m) => - -- | Resampler - (forall x. PopulationT m x -> PopulationT m x) -> - PopulationT m (MSF (PopulationT m) a b) -> - MSF m a [(b, Log Double)] -runPopulationsS resampler = go - where - go msfs = MSF $ \a -> do - -- TODO This is quite different than the dunai version now. Maybe it's right nevertheless. - -- FIXME This normalizes, which introduces bias, whatever that means - bAndMSFs <- runPopulationT $ normalize $ resampler $ flip unMSF a =<< msfs - return $ - second (go . fromWeightedList . return) $ - unzip $ - (swap . fmap fst &&& swap . fmap snd) . swap <$> bAndMSFs - --- FIXME see PR re-adding this to monad-bayes -normalize :: (Monad m) => PopulationT m a -> PopulationT m a -normalize = fromWeightedList . fmap (\particles -> second (/ (sum $ snd <$> particles)) <$> particles) . runPopulationT diff --git a/rhine-bayes/src/FRP/Rhine/Bayes.hs b/rhine-bayes/src/FRP/Rhine/Bayes.hs index 0f054ec9e..f8e5ddc89 100644 --- a/rhine-bayes/src/FRP/Rhine/Bayes.hs +++ b/rhine-bayes/src/FRP/Rhine/Bayes.hs @@ -10,11 +10,11 @@ import Numeric.Log hiding (sum) import Control.Monad.Bayes.Class import Control.Monad.Bayes.Population --- dunai -import qualified Control.Monad.Trans.MSF.Reader as DunaiReader +-- automaton +import qualified Data.Automaton.Trans.Reader as AutomatonReader --- dunai-bayes -import qualified Data.MonadicStreamFunction.Bayes as DunaiBayes +-- rhine-bayes +import qualified Data.Automaton.Bayes as AutomatonBayes -- rhine import FRP.Rhine @@ -24,18 +24,18 @@ import FRP.Rhine -- | Run the Sequential Monte Carlo algorithm continuously on a 'ClSF'. runPopulationCl :: forall m cl a b. - (Monad m) => + (Monad m, MonadDistribution m) => -- | Number of particles Int -> -- | Resampler (see 'Control.Monad.Bayes.PopulationT' for some standard choices) - (forall x. PopulationT m x -> PopulationT m x) -> + (forall x m. (MonadDistribution m) => PopulationT m x -> PopulationT m x) -> -- | A signal function modelling the stochastic process on which to perform inference. -- @a@ represents observations upon which the model should condition, using e.g. 'score'. -- It can also additionally contain hyperparameters. -- @b@ is the type of estimated current state. ClSF (PopulationT m) cl a b -> ClSF m cl a [(b, Log Double)] -runPopulationCl nParticles resampler = DunaiReader.readerS . DunaiBayes.runPopulationS nParticles resampler . DunaiReader.runReaderS +runPopulationCl nParticles resampler = AutomatonReader.readerS . AutomatonBayes.runPopulationS nParticles resampler . AutomatonReader.runReaderS -- * Short standard library of stochastic processes diff --git a/rhine-gloss/Main.hs b/rhine-gloss/Main.hs index 156136958..c8a315a69 100644 --- a/rhine-gloss/Main.hs +++ b/rhine-gloss/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -- | Example application for the @gloss@ wrapper. diff --git a/rhine-gloss/rhine-gloss.cabal b/rhine-gloss/rhine-gloss.cabal index d6097b601..722dc1232 100644 --- a/rhine-gloss/rhine-gloss.cabal +++ b/rhine-gloss/rhine-gloss.cabal @@ -37,8 +37,8 @@ library FRP.Rhine.Gloss.Pure.Combined build-depends: + automaton, base >=4.14 && <4.18, - dunai ^>=0.12.2, gloss >=1.12, mmorph >=1.1, monad-schedule >=0.1, @@ -61,6 +61,7 @@ executable rhine-gloss-gears rhine-gloss default-language: Haskell2010 + default-extensions: TypeOperators ghc-options: -W -threaded diff --git a/rhine-gloss/src/FRP/Rhine/Gloss.hs b/rhine-gloss/src/FRP/Rhine/Gloss.hs index 253fa226e..2c5d960d7 100644 --- a/rhine-gloss/src/FRP/Rhine/Gloss.hs +++ b/rhine-gloss/src/FRP/Rhine/Gloss.hs @@ -17,7 +17,6 @@ import Control.Arrow as X import FRP.Rhine as X -- rhine-gloss - import FRP.Rhine.Gloss.Common as X import FRP.Rhine.Gloss.IO as X import FRP.Rhine.Gloss.Pure as X diff --git a/rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs b/rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs index cdea407d9..44d88fe7b 100644 --- a/rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs +++ b/rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs @@ -30,16 +30,16 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Control.Monad.Trans.Writer.Strict --- dunai -import Control.Monad.Trans.MSF (performOnFirstSample) -import qualified Control.Monad.Trans.MSF.Reader as MSFReader -import qualified Control.Monad.Trans.MSF.Writer as MSFWriter -import Data.MonadicStreamFunction.InternalCore - -- 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.Stream.Result (Result (..)) + -- rhine import FRP.Rhine @@ -114,7 +114,7 @@ flowGlossClSF :: IO () flowGlossClSF settings clsf = flowGloss settings $ clsf >-> arrMCl paintAll @@ GlossClock -type WorldMSF = MSF Identity ((Float, Maybe Event), ()) (Picture, Maybe ()) +type WorldAutomaton = Automaton Identity ((Float, Maybe Event), ()) (Picture, Maybe ()) -- | The main function that will start the @gloss@ backend and run the 'Rhine' flowGloss :: @@ -123,12 +123,12 @@ flowGloss :: Rhine GlossM cl () () -> IO () flowGloss GlossSettings {..} rhine = - play display backgroundColor stepsPerSecond (worldMSF, Blank) getPic handleEvent simStep + play display backgroundColor stepsPerSecond (worldAutomaton, Blank) getPic handleEvent simStep where - worldMSF :: WorldMSF - worldMSF = MSFWriter.runWriterS $ MSFReader.runReaderS $ morphS (runYieldT . unGlossM) $ performOnFirstSample $ eraseClock rhine - stepWith :: (Float, Maybe Event) -> (WorldMSF, Picture) -> (WorldMSF, Picture) - stepWith (diff, eventMaybe) (msf, _) = let ((picture, _), msf') = runIdentity $ unMSF msf ((diff, eventMaybe), ()) in (msf', picture) + 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, _) = runIdentity $ stepAutomaton automaton ((diff, eventMaybe), ()) in (automaton', picture) getPic (_, pic) = pic handleEvent event = stepWith (0, Just event) simStep diff = stepWith (diff, Nothing) diff --git a/rhine-terminal/rhine-terminal.cabal b/rhine-terminal/rhine-terminal.cabal index 3e29528ab..50d95b9b2 100644 --- a/rhine-terminal/rhine-terminal.cabal +++ b/rhine-terminal/rhine-terminal.cabal @@ -28,7 +28,6 @@ library exposed-modules: FRP.Rhine.Terminal build-depends: base >=4.11 && <4.18, - dunai ^>=0.12.2, exceptions >=0.10.4, monad-schedule >=0.1.2, rhine ==1.2, diff --git a/rhine/ChangeLog.md b/rhine/ChangeLog.md index 250250797..0b67ddbf2 100644 --- a/rhine/ChangeLog.md +++ b/rhine/ChangeLog.md @@ -1,5 +1,14 @@ # Revision history for rhine +## 1.3 + +* Dropped `dunai` dependency in favour of state automata. + See [the versions readme](./versions.md) for details. +* Moved the monad argument `m` in `ClSFExcept`: + It is now `ClSFExcept cl a b m e` instead of `ClSFExcept m cl a b e`. + The advantage is that now the type is an instance of `MonadTrans` and `MFunctor`. + Analogous changes have been made to `BehaviourFExcept`. + ## 1.2.1 * Added `FRP.Rhine.Clock.Realtime.Never` (clock that never ticks) diff --git a/rhine/bench/WordCount.hs b/rhine/bench/WordCount.hs index 0af29bc6c..227080b73 100644 --- a/rhine/bench/WordCount.hs +++ b/rhine/bench/WordCount.hs @@ -23,11 +23,10 @@ import Data.Text.Lazy.IO (hGetContents) import Criterion.Main -- dunai +import Control.Monad.Trans.MSF.Except qualified as Dunai import Data.MonadicStreamFunction qualified as Dunai -- rhine - -import Control.Monad.Trans.MSF.Except qualified as Dunai import FRP.Rhine import FRP.Rhine.Clock.Except ( DelayIOError, diff --git a/rhine/rhine.cabal b/rhine/rhine.cabal index 1b75a139b..94cbeace8 100644 --- a/rhine/rhine.cabal +++ b/rhine/rhine.cabal @@ -46,10 +46,13 @@ source-repository this common opts build-depends: + automaton ^>=0.1.0.0, base >=4.14 && <4.18, monad-schedule ^>=0.1.2, mtl >=2.2 && <2.4, + selective ^>=0.7, text >=1.2 && <2.1, + time >=1.8, transformers >=0.5, vector-sized >=1.4, @@ -78,8 +81,10 @@ common opts common test-deps build-depends: + QuickCheck ^>=2.14, tasty ^>=1.4, tasty-hunit ^>=0.10, + tasty-quickcheck ^>=0.10, common bench-deps build-depends: @@ -140,10 +145,12 @@ library MonadRandom >=0.5, containers >=0.5, deepseq >=1.4, - dunai ^>=0.12.2, free >=5.1, + mmorph ^>=1.2, + profunctors ^>=5.6, random >=1.1, simple-affine-space ^>=0.2, + sop-core ^>=0.5, text >=1.2 && <2.1, time >=1.8, time-domain ^>=0.1.0.2, diff --git a/rhine/src/FRP/Rhine.hs b/rhine/src/FRP/Rhine.hs index 5b36ee4fe..bf08caee0 100644 --- a/rhine/src/FRP/Rhine.hs +++ b/rhine/src/FRP/Rhine.hs @@ -12,12 +12,11 @@ main = flow \$ constMCl (putStrLn \"Hello World!\") \@\@ (waitClock :: Milliseco -} module FRP.Rhine (module X) where --- dunai -import Data.MonadicStreamFunction as X hiding ((>>>^), (^>>>)) -import Data.VectorSpace as X +-- automaton +import Data.Automaton 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 diff --git a/rhine/src/FRP/Rhine/ClSF.hs b/rhine/src/FRP/Rhine/ClSF.hs index 982a0a0d3..91d91c995 100644 --- a/rhine/src/FRP/Rhine/ClSF.hs +++ b/rhine/src/FRP/Rhine/ClSF.hs @@ -1,5 +1,5 @@ {- | -Clocked signal functions, i.e. monadic stream functions ('MSF's) +Clocked signal functions, i.e. monadic stream functions ('Automaton's) that are aware of time. This module reexports core functionality (such as time effects and 'Behaviour's), diff --git a/rhine/src/FRP/Rhine/ClSF/Core.hs b/rhine/src/FRP/Rhine/ClSF/Core.hs index fc65a8730..26b5158f6 100644 --- a/rhine/src/FRP/Rhine/ClSF/Core.hs +++ b/rhine/src/FRP/Rhine/ClSF/Core.hs @@ -22,8 +22,8 @@ import Control.Arrow import Control.Monad.Trans.Class import Control.Monad.Trans.Reader (ReaderT, mapReaderT, withReaderT) --- dunai -import Data.MonadicStreamFunction as X hiding ((>>>^), (^>>>)) +-- automaton +import Data.Automaton as X -- rhine import FRP.Rhine.Clock @@ -34,7 +34,7 @@ import FRP.Rhine.Clock with the additional side effect of being time-aware, that is, reading the current 'TimeInfo' of the clock @cl@. -} -type ClSF m cl a b = MSF (ReaderT (TimeInfo cl) m) a b +type ClSF m cl a b = Automaton (ReaderT (TimeInfo cl) m) a b {- | A clocked signal is a 'ClSF' with no input required. It produces its output on its own. @@ -67,7 +67,7 @@ hoistClSF :: (forall c. m1 c -> m2 c) -> ClSF m1 cl a b -> ClSF m2 cl a b -hoistClSF hoist = morphS $ mapReaderT hoist +hoistClSF hoist = hoistS $ mapReaderT hoist -- | Hoist a 'ClSF' and its clock along a monad morphism. hoistClSFAndClock :: @@ -76,7 +76,7 @@ hoistClSFAndClock :: ClSF m1 cl a b -> ClSF m2 (HoistClock m1 m2 cl) a b hoistClSFAndClock hoist = - morphS $ withReaderT (retag id) . mapReaderT hoist + hoistS $ withReaderT (retag id) . mapReaderT hoist -- | Lift a 'ClSF' into a monad transformer. liftClSF :: @@ -95,8 +95,8 @@ liftClSFAndClock = hoistClSFAndClock lift {- | A monadic stream function without dependency on time is a 'ClSF' for any clock. -} -timeless :: (Monad m) => MSF m a b -> ClSF m cl a b -timeless = liftTransS +timeless :: (Monad m) => Automaton m a b -> ClSF m cl a b +timeless = liftS -- | Utility to lift Kleisli arrows directly to 'ClSF's. arrMCl :: (Monad m) => (a -> m b) -> ClSF m cl a b diff --git a/rhine/src/FRP/Rhine/ClSF/Except.hs b/rhine/src/FRP/Rhine/ClSF/Except.hs index f358db7ca..75f417b29 100644 --- a/rhine/src/FRP/Rhine/ClSF/Except.hs +++ b/rhine/src/FRP/Rhine/ClSF/Except.hs @@ -5,7 +5,7 @@ {- | This module provides exception handling, and thus control flow, to synchronous signal functions. -The API presented here closely follows dunai's 'Control.Monad.Trans.MSF.Except', +The API presented here closely follows @automaton@'s 'Data.Automaton.Trans.Except', and reexports everything needed from there. -} module FRP.Rhine.ClSF.Except ( @@ -14,7 +14,7 @@ module FRP.Rhine.ClSF.Except ( safe, safely, exceptS, - runMSFExcept, + runAutomatonExcept, currentInput, ) where @@ -27,12 +27,9 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except as X import Control.Monad.Trans.Reader --- dunai -import Control.Monad.Trans.MSF.Except hiding (once, once_, throwOn, throwOn', throwS, try) -import Data.MonadicStreamFunction - --- TODO Find out whether there is a cleverer way to handle exports -import Control.Monad.Trans.MSF.Except qualified as MSFE +-- automaton +import Data.Automaton.Trans.Except hiding (once, once_, throwOn, throwOn', throwS, try) +import Data.Automaton.Trans.Except qualified as AutomatonE -- rhine import FRP.Rhine.ClSF.Core @@ -46,11 +43,11 @@ throwS :: (Monad m) => ClSF (ExceptT e m) cl e a throwS = arrMCl throwE -- | Immediately throw the given exception. -throw :: (Monad m) => e -> MSF (ExceptT e m) a b +throw :: (Monad m) => e -> Automaton (ExceptT e m) a b throw = constM . throwE -- | Do not throw an exception. -pass :: (Monad m) => MSF (ExceptT e m) a a +pass :: (Monad m) => Automaton (ExceptT e m) a a pass = Category.id -- | Throw the given exception when the 'Bool' turns true. @@ -90,11 +87,11 @@ throwMaybe = proc me -> case me of -- * Monad interface {- | A synchronous exception-throwing signal function. -It is based on a @newtype@ from Dunai, 'MSFExcept', +It is based on a @newtype@ from Dunai, 'AutomatonExcept', to exhibit a monad interface /in the exception type/. `return` then corresponds to throwing an exception, and `(>>=)` is exception handling. -(For more information, see the documentation of 'MSFExcept'.) +(For more information, see the documentation of 'AutomatonExcept'.) * @m@: The monad that the signal function may take side effects in * @cl@: The clock on which the signal function ticks @@ -102,7 +99,7 @@ and `(>>=)` is exception handling. * @b@: The output type * @e@: The type of exceptions that can be thrown -} -type ClSFExcept m cl a b e = MSFExcept (ReaderT (TimeInfo cl) m) a b e +type ClSFExcept m cl a b e = AutomatonExcept (ReaderT (TimeInfo cl) m) a b e {- | A clock polymorphic 'ClSFExcept', or equivalently an exception-throwing behaviour. @@ -116,20 +113,20 @@ type BehaviorFExcept m time a b e = BehaviourFExcept m time a b e -- | Leave the monad context, to use the 'ClSFExcept' as an 'Arrow'. runClSFExcept :: (Monad m) => ClSFExcept m cl a b e -> ClSF (ExceptT e m) cl a b -runClSFExcept = morphS commuteExceptReader . runMSFExcept +runClSFExcept = hoistS commuteExceptReader . runAutomatonExcept {- | Enter the monad context in the exception for 'ClSF's in the 'ExceptT' monad. The 'ClSF' will be run until it encounters an exception. -} try :: (Monad m) => ClSF (ExceptT e m) cl a b -> ClSFExcept m cl a b e -try = MSFE.try . morphS commuteReaderExcept +try = AutomatonE.try . hoistS commuteReaderExcept {- | Within the same tick, perform a monadic action, and immediately throw the value as an exception. -} once :: (Monad m) => (a -> m e) -> ClSFExcept m cl a b e -once f = MSFE.once $ lift . f +once f = AutomatonE.once $ lift . f -- | A variant of 'once' without input. once_ :: (Monad m) => m e -> ClSFExcept m cl a b e @@ -139,4 +136,4 @@ once_ = once . const and then throws an exception. -} step :: (Monad m) => (a -> m (b, e)) -> ClSFExcept m cl a b e -step f = MSFE.step $ lift . f +step f = AutomatonE.step $ lift . f diff --git a/rhine/src/FRP/Rhine/ClSF/Random.hs b/rhine/src/FRP/Rhine/ClSF/Random.hs index ca464d7e0..7dafb4285 100644 --- a/rhine/src/FRP/Rhine/ClSF/Random.hs +++ b/rhine/src/FRP/Rhine/ClSF/Random.hs @@ -3,8 +3,8 @@ {- | Create 'ClSF's with randomness without 'IO'. Uses the @MonadRandom@ package. - This module copies the API from @dunai@'s - 'Control.Monad.Trans.MSF.Random'. + This module copies the API from @automaton@'s + 'Data.Automaton.Trans.Random'. -} module FRP.Rhine.ClSF.Random ( module FRP.Rhine.ClSF.Random, @@ -18,10 +18,10 @@ import Control.Monad.IO.Class -- MonadRandom import Control.Monad.Random --- dunai -import Control.Monad.Trans.MSF.Except (performOnFirstSample) -import Control.Monad.Trans.MSF.Random as X hiding (evalRandS, getRandomRS, getRandomRS_, getRandomS, runRandS) -import Control.Monad.Trans.MSF.Random qualified as MSF +-- automaton +import Data.Automaton.Trans.Except (performOnFirstSample) +import Data.Automaton.Trans.Random as X hiding (evalRandS, getRandomRS, getRandomRS_, getRandomS, runRandS) +import Data.Automaton.Trans.Random qualified as Automaton -- rhine import FRP.Rhine.ClSF.Core @@ -36,7 +36,7 @@ runRandS :: -- | The initial random seed g -> ClSF m cl a (g, b) -runRandS clsf = MSF.runRandS (morphS commuteReaderRand clsf) +runRandS clsf = Automaton.runRandS (hoistS commuteReaderRand clsf) -- | Updates the generator every step but discards the generator. evalRandS :: diff --git a/rhine/src/FRP/Rhine/ClSF/Reader.hs b/rhine/src/FRP/Rhine/ClSF/Reader.hs index 20a8db48b..177ad7f32 100644 --- a/rhine/src/FRP/Rhine/ClSF/Reader.hs +++ b/rhine/src/FRP/Rhine/ClSF/Reader.hs @@ -13,8 +13,8 @@ import Data.Tuple (swap) -- transformers import Control.Monad.Trans.Reader --- dunai -import Control.Monad.Trans.MSF.Reader qualified as MSF +-- automaton +import Data.Automaton.Trans.Reader qualified as Automaton -- rhine import FRP.Rhine.ClSF.Core @@ -23,6 +23,7 @@ import FRP.Rhine.ClSF.Core commuteReaders :: ReaderT r1 (ReaderT r2 m) a -> ReaderT r2 (ReaderT r1 m) a commuteReaders a = ReaderT $ \r1 -> ReaderT $ \r2 -> runReaderT (runReaderT a r2) r1 +{-# INLINE commuteReaders #-} {- | Create ("wrap") a 'ReaderT' layer in the monad stack of a behaviour. Each tick, the 'ReaderT' side effect is performed @@ -33,7 +34,8 @@ readerS :: ClSF m cl (a, r) b -> ClSF (ReaderT r m) cl a b readerS behaviour = - morphS commuteReaders $ MSF.readerS $ arr swap >>> behaviour + hoistS commuteReaders $ Automaton.readerS $ arr swap >>> behaviour +{-# INLINE readerS #-} {- | Remove ("run") a 'ReaderT' layer from the monad stack by making it an explicit input to the behaviour. @@ -43,7 +45,8 @@ runReaderS :: ClSF (ReaderT r m) cl a b -> ClSF m cl (a, r) b runReaderS behaviour = - arr swap >>> MSF.runReaderS (morphS commuteReaders behaviour) + arr swap >>> Automaton.runReaderS (hoistS commuteReaders behaviour) +{-# INLINE runReaderS #-} -- | Remove a 'ReaderT' layer by passing the readonly environment explicitly. runReaderS_ :: @@ -52,3 +55,4 @@ runReaderS_ :: r -> ClSF m cl a b runReaderS_ behaviour r = arr (,r) >>> runReaderS behaviour +{-# INLINE runReaderS_ #-} diff --git a/rhine/src/FRP/Rhine/ClSF/Upsample.hs b/rhine/src/FRP/Rhine/ClSF/Upsample.hs index b9b8428af..f16d88493 100644 --- a/rhine/src/FRP/Rhine/ClSF/Upsample.hs +++ b/rhine/src/FRP/Rhine/ClSF/Upsample.hs @@ -7,22 +7,22 @@ module FRP.Rhine.ClSF.Upsample where -- dunai -import Control.Monad.Trans.MSF.Reader +import Data.Automaton.Trans.Reader -- rhine import FRP.Rhine.ClSF.Core import FRP.Rhine.Clock import FRP.Rhine.Schedule -{- | An 'MSF' can be given arbitrary other arguments +{- | An 'Automaton' can be given arbitrary other arguments that cause it to tick without doing anything and replicating the last output. -} -upsampleMSF :: (Monad m) => b -> MSF m a b -> MSF m (Either arbitrary a) b -upsampleMSF b msf = right msf >>> accumulateWith (<>) (Right b) >>> arr fromRight +upsampleAutomaton :: (Monad m) => b -> Automaton m a b -> Automaton m (Either arbitrary a) b +upsampleAutomaton b automaton = right automaton >>> accumulateWith (<>) (Right b) >>> arr fromRight where fromRight (Right b') = b' - fromRight (Left _) = error "fromRight: This case never occurs in upsampleMSF." + fromRight (Left _) = error "fromRight: This case never occurs in upsampleAutomaton." -- Note that the Semigroup instance of Either a arbitrary -- updates when the first argument is Right. @@ -37,7 +37,7 @@ upsampleR :: b -> ClSF m clR a b -> ClSF m (ParallelClock clL clR) a b -upsampleR b clsf = readerS $ arr remap >>> upsampleMSF b (runReaderS clsf) +upsampleR b clsf = readerS $ arr remap >>> upsampleAutomaton b (runReaderS clsf) where remap (TimeInfo {tag = Left tag}, _) = Left tag remap (TimeInfo {tag = Right tag, ..}, a) = Right (TimeInfo {..}, a) @@ -52,7 +52,7 @@ upsampleL :: b -> ClSF m clL a b -> ClSF m (ParallelClock clL clR) a b -upsampleL b clsf = readerS $ arr remap >>> upsampleMSF b (runReaderS clsf) +upsampleL b clsf = readerS $ arr remap >>> upsampleAutomaton b (runReaderS clsf) where remap (TimeInfo {tag = Right tag}, _) = Left tag remap (TimeInfo {tag = Left tag, ..}, a) = Right (TimeInfo {..}, a) diff --git a/rhine/src/FRP/Rhine/ClSF/Util.hs b/rhine/src/FRP/Rhine/ClSF/Util.hs index ccf4171b0..5d051d558 100644 --- a/rhine/src/FRP/Rhine/ClSF/Util.hs +++ b/rhine/src/FRP/Rhine/ClSF/Util.hs @@ -26,9 +26,7 @@ import Data.Sequence import Control.Monad.Trans.Reader (ask, asks) -- dunai -import Control.Monad.Trans.MSF.Reader (readerS) -import Data.MonadicStreamFunction.Instances.Num () -import Data.MonadicStreamFunction.Instances.VectorSpace () +import Data.Automaton.Trans.Reader (readerS) -- simple-affine-space import Data.VectorSpace @@ -178,7 +176,7 @@ derivativeFrom :: v -> BehaviorF m td v v derivativeFrom v0 = proc v -> do - vLast <- iPre v0 -< v + vLast <- delay v0 -< v TimeInfo {..} <- timeInfo -< () returnA -< (v ^-^ vLast) ^/ sinceLast @@ -205,7 +203,7 @@ threePointDerivativeFrom :: BehaviorF m td v v threePointDerivativeFrom v0 = proc v -> do dv <- derivativeFrom v0 -< v - dv' <- iPre zeroVector -< dv + dv' <- delay zeroVector -< dv returnA -< (dv ^+^ dv') ^/ 2 {- | Like 'threePointDerivativeFrom', @@ -441,5 +439,5 @@ scaledTimer diff = timer diff >>> arr (/ diff) {- | Remembers the last 'Just' value, defaulting to the given initialisation value. -} -lastS :: (Monad m) => a -> MSF m (Maybe a) a +lastS :: (Monad m) => a -> Automaton m (Maybe a) a lastS a = arr Last >>> mappendFrom (Last (Just a)) >>> arr (getLast >>> fromJust) diff --git a/rhine/src/FRP/Rhine/Clock.hs b/rhine/src/FRP/Rhine/Clock.hs index 1f3a3fb66..24abb2564 100644 --- a/rhine/src/FRP/Rhine/Clock.hs +++ b/rhine/src/FRP/Rhine/Clock.hs @@ -22,14 +22,15 @@ module FRP.Rhine.Clock ( where -- base +import Control.Arrow import Control.Category qualified as Category -- transformers import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Class (MonadTrans, lift) --- dunai -import Data.MonadicStreamFunction as X hiding ((>>>^), (^>>>)) +-- automaton +import Data.Automaton (Automaton, arrM, hoistS) -- time-domain import Data.TimeDomain as X @@ -41,7 +42,7 @@ A clock creates a stream of time stamps and additional information, possibly together with side effects in a monad 'm' that cause the environment to wait until the specified time is reached. -} -type RunningClock m time tag = MSF m () (time, tag) +type RunningClock m time tag = Automaton m () (time, tag) {- | When initialising a clock, the initial time is measured @@ -109,11 +110,11 @@ type Rescaling cl time = Time cl -> time -} type RescalingM m cl time = Time cl -> m time -{- | An effectful, stateful morphism of time domains is an 'MSF' +{- | 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. -} -type RescalingS m cl time tag = MSF m (Time cl, Tag cl) (time, tag) +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. @@ -128,7 +129,7 @@ rescaleMToSInit :: (Monad m) => (time1 -> m time2) -> time1 -> - m (MSF m (time1, tag) (time2, tag), time2) + m (Automaton m (time1, tag) (time2, tag), time2) rescaleMToSInit rescaling time1 = (arrM rescaling *** Category.id,) <$> rescaling time1 -- ** Applying rescalings to clocks @@ -241,10 +242,8 @@ instance type Tag (HoistClock m1 m2 cl) = Tag cl initClock HoistClock {..} = do (runningClock, initialTime) <- monadMorphism $ initClock unhoistedClock - let hoistMSF = morphS - -- TODO Look out for API changes in dunai here return - ( hoistMSF monadMorphism runningClock + ( hoistS monadMorphism runningClock , initialTime ) diff --git a/rhine/src/FRP/Rhine/Clock/Except.hs b/rhine/src/FRP/Rhine/Clock/Except.hs index 0b11d18ca..8bbf6b2b7 100644 --- a/rhine/src/FRP/Rhine/Clock/Except.hs +++ b/rhine/src/FRP/Rhine/Clock/Except.hs @@ -8,20 +8,18 @@ import Control.Monad ((<=<)) import Data.Functor ((<&>)) import Data.Void --- transformers -import Control.Monad.Trans.MSF.Except - -- time import Data.Time (UTCTime, getCurrentTime) -- mtl import Control.Monad.Error.Class import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.MSF qualified as MSFExcept --- dunai -import Control.Monad.Trans.MSF.Reader (readerS, runReaderS) -import Data.MonadicStreamFunction (morphS) +-- automaton +import Data.Automaton (hoistS) +import Data.Automaton.Trans.Except +import Data.Automaton.Trans.Except qualified as AutomatonExcept +import Data.Automaton.Trans.Reader (readerS, runReaderS) -- rhine import FRP.Rhine.ClSF.Core (ClSF) @@ -54,7 +52,7 @@ instance (Exception e, Clock IO cl, MonadIO eio, MonadError e eio) => Clock eio ioerror $ Exception.try $ initClock getExceptClock - <&> first (morphS (ioerror . Exception.try)) + <&> first (hoistS (ioerror . Exception.try)) where ioerror :: (MonadError e eio, MonadIO eio) => IO (Either e a) -> eio a ioerror = liftEither <=< liftIO @@ -81,7 +79,7 @@ instance (Time cl1 ~ Time cl2, Clock (ExceptT e m) cl1, Clock m cl2, Monad m) => case tryToInit of Right (runningClock, initTime) -> do let catchingClock = safely $ do - e <- MSFExcept.try runningClock + e <- AutomatonExcept.try runningClock let cl2 = handler e (runningClock', _) <- once_ $ initClock cl2 safe $ runningClock' >>> arr (second Left) @@ -136,7 +134,7 @@ instance (TimeDomain time, MonadError e m) => Clock m (Single m time tag e) wher type Tag (Single m time tag e) = tag initClock Single {singleTag, getTime, exception} = do initTime <- getTime - let runningClock = morphS (errorT . runExceptT) $ runMSFExcept $ do + let runningClock = hoistS (errorT . runExceptT) $ runAutomatonExcept $ do step_ (initTime, singleTag) return exception errorT :: (MonadError e m) => m (Either e a) -> m a diff --git a/rhine/src/FRP/Rhine/Clock/FixedStep.hs b/rhine/src/FRP/Rhine/Clock/FixedStep.hs index 8746d2bf9..551df585a 100644 --- a/rhine/src/FRP/Rhine/Clock/FixedStep.hs +++ b/rhine/src/FRP/Rhine/Clock/FixedStep.hs @@ -12,6 +12,7 @@ and a deterministic schedule for such clocks. module FRP.Rhine.Clock.FixedStep where -- base +import Control.Arrow import Data.Functor (($>)) import Data.Maybe (fromMaybe) import GHC.TypeLits @@ -23,6 +24,9 @@ import Data.Vector.Sized (Vector, fromList) import Control.Monad.Schedule.Class import Control.Monad.Schedule.Trans (ScheduleT, wait) +-- automaton +import Data.Automaton (accumulateWith, arrM) + -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy diff --git a/rhine/src/FRP/Rhine/Clock/Periodic.hs b/rhine/src/FRP/Rhine/Clock/Periodic.hs index ee203b11b..01ae458c7 100644 --- a/rhine/src/FRP/Rhine/Clock/Periodic.hs +++ b/rhine/src/FRP/Rhine/Clock/Periodic.hs @@ -15,16 +15,16 @@ The time differences are supplied at the type level. module FRP.Rhine.Clock.Periodic (Periodic (Periodic)) where -- base +import Control.Arrow import Data.List.NonEmpty hiding (unfold) -import Data.Maybe (fromMaybe) import GHC.TypeLits (KnownNat, Nat, natVal) --- dunai -import Data.MonadicStreamFunction - -- monad-schedule import Control.Monad.Schedule.Trans +-- automaton +import Data.Automaton (Automaton (..), accumulateWith, concatS, withSideEffect) + -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy @@ -80,15 +80,6 @@ instance -- * Utilities --- TODO Port back to dunai when naming issues are resolved - -- | Repeatedly outputs the values of a given list, in order. -cycleS :: (Monad m) => NonEmpty a -> MSF m () a -cycleS as = unfold (second (fromMaybe as) . uncons) as - -{- --- TODO Port back to dunai when naming issues are resolved -delayList :: [a] -> MSF a a -delayList [] = id -delayList (a : as) = delayList as >>> delay a --} +cycleS :: (Monad m) => NonEmpty a -> Automaton m () a +cycleS as = concatS $ arr $ const $ toList as diff --git a/rhine/src/FRP/Rhine/Clock/Realtime/Audio.hs b/rhine/src/FRP/Rhine/Clock/Realtime/Audio.hs index 70f6c6556..77102edfd 100644 --- a/rhine/src/FRP/Rhine/Clock/Realtime/Audio.hs +++ b/rhine/src/FRP/Rhine/Clock/Realtime/Audio.hs @@ -21,6 +21,7 @@ module FRP.Rhine.Clock.Realtime.Audio ( where -- base +import Control.Arrow import Data.Time.Clock import GHC.Float (double2Float) import GHC.TypeLits (KnownNat, Nat, natVal) @@ -28,8 +29,9 @@ import GHC.TypeLits (KnownNat, Nat, natVal) -- transformers import Control.Monad.IO.Class --- dunai -import Control.Monad.Trans.MSF.Except hiding (step) +-- automaton +import Data.Automaton +import Data.Automaton.Trans.Except hiding (step) -- rhine import FRP.Rhine.Clock @@ -100,11 +102,11 @@ instance initClock audioClock = do let step = - picosecondsToDiffTime $ -- The only sufficiently precise conversion function - round (10 ^ (12 :: Integer) / theRateNum audioClock :: Double) + picosecondsToDiffTime $ + round (10 ^ (12 :: Integer) / theRateNum audioClock :: Double) -- The only sufficiently precise conversion function bufferSize = theBufferSize audioClock - runningClock :: (MonadIO m) => UTCTime -> Maybe Double -> MSF m () (UTCTime, Maybe Double) + runningClock :: (MonadIO m) => UTCTime -> Maybe Double -> Automaton m () (UTCTime, Maybe Double) runningClock initialTime maybeWasLate = safely $ do bufferFullTime <- try $ proc () -> do n <- count -< () diff --git a/rhine/src/FRP/Rhine/Clock/Realtime/Busy.hs b/rhine/src/FRP/Rhine/Clock/Realtime/Busy.hs index 688d8ed3c..f0ddecced 100644 --- a/rhine/src/FRP/Rhine/Clock/Realtime/Busy.hs +++ b/rhine/src/FRP/Rhine/Clock/Realtime/Busy.hs @@ -5,11 +5,15 @@ module FRP.Rhine.Clock.Realtime.Busy where -- base +import Control.Arrow import Control.Monad.IO.Class -- time import Data.Time.Clock +-- automaton +import Data.Automaton (constM) + -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy diff --git a/rhine/src/FRP/Rhine/Clock/Realtime/Event.hs b/rhine/src/FRP/Rhine/Clock/Realtime/Event.hs index 736bf60fe..72172a804 100644 --- a/rhine/src/FRP/Rhine/Clock/Realtime/Event.hs +++ b/rhine/src/FRP/Rhine/Clock/Realtime/Event.hs @@ -66,7 +66,7 @@ Ideally, this action is run _outside_ of 'flow', e.g. @runEventChanT $ flow myRhine@. This way, exactly one channel is created. -Caution: Don't use this with 'morphS', +Caution: Don't use this with 'hoistS', since it would create a new channel every tick. Instead, create one @chan :: Chan c@, e.g. with 'newChan', and then use 'withChanS'. diff --git a/rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs b/rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs index 0a4e86eb3..b0e981cd6 100644 --- a/rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs +++ b/rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs @@ -9,15 +9,21 @@ Provides a clock that ticks at every multiple of a fixed number of milliseconds. module FRP.Rhine.Clock.Realtime.Millisecond where -- base +import Control.Arrow import Control.Concurrent (threadDelay) import Control.Monad.IO.Class (liftIO) import Data.Maybe (fromMaybe) -import Data.Time.Clock import GHC.TypeLits +-- time +import Data.Time.Clock + -- vector-sized import Data.Vector.Sized (Vector, fromList) +-- automaton +import Data.Automaton (arrM) + -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.FixedStep diff --git a/rhine/src/FRP/Rhine/Clock/Realtime/Never.hs b/rhine/src/FRP/Rhine/Clock/Realtime/Never.hs index 3da4e0718..a68e1783e 100644 --- a/rhine/src/FRP/Rhine/Clock/Realtime/Never.hs +++ b/rhine/src/FRP/Rhine/Clock/Realtime/Never.hs @@ -7,18 +7,19 @@ module FRP.Rhine.Clock.Realtime.Never where -- base import Control.Concurrent (threadDelay) import Control.Monad (forever) +import Control.Monad.IO.Class import Data.Void (Void) -- time import Data.Time.Clock +-- automaton +import Data.Automaton (constM) + -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy --- transformers -import Control.Monad.IO.Class - -- | A clock that never ticks. data Never = Never diff --git a/rhine/src/FRP/Rhine/Clock/Realtime/Stdin.hs b/rhine/src/FRP/Rhine/Clock/Realtime/Stdin.hs index e19056cc0..9246f65c9 100644 --- a/rhine/src/FRP/Rhine/Clock/Realtime/Stdin.hs +++ b/rhine/src/FRP/Rhine/Clock/Realtime/Stdin.hs @@ -19,6 +19,9 @@ import Control.Monad.IO.Class import Data.Text qualified as Text import Data.Text.IO qualified as Text +-- automaton +import Data.Automaton (constM) + -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy diff --git a/rhine/src/FRP/Rhine/Clock/Select.hs b/rhine/src/FRP/Rhine/Clock/Select.hs index 9b2876e5d..63dedbdd3 100644 --- a/rhine/src/FRP/Rhine/Clock/Select.hs +++ b/rhine/src/FRP/Rhine/Clock/Select.hs @@ -14,16 +14,17 @@ that ticks only on certain subevents. -} module FRP.Rhine.Clock.Select where +-- base +import Control.Arrow +import Data.Maybe (maybeToList) + +-- automaton +import Data.Automaton (Automaton, concatS) + -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy --- dunai -import Data.MonadicStreamFunction.Async (concatS) - --- base -import Data.Maybe (maybeToList) - {- | A clock that selects certain subevents of type 'a', from the tag of a main clock. @@ -66,8 +67,8 @@ instance (Monad m, Clock m cl) => Clock m (SelectClock cl a) where instance GetClockProxy (SelectClock cl a) -{- | Helper function that runs an 'MSF' with 'Maybe' output +{- | Helper function that runs an 'Automaton' with 'Maybe' output until it returns a value. -} -filterS :: (Monad m) => MSF m () (Maybe b) -> MSF m () b +filterS :: (Monad m) => Automaton m () (Maybe b) -> Automaton m () b filterS = concatS . (>>> arr maybeToList) diff --git a/rhine/src/FRP/Rhine/Clock/Unschedule.hs b/rhine/src/FRP/Rhine/Clock/Unschedule.hs index d0c56c5f2..025930d28 100644 --- a/rhine/src/FRP/Rhine/Clock/Unschedule.hs +++ b/rhine/src/FRP/Rhine/Clock/Unschedule.hs @@ -5,12 +5,16 @@ 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) + -- rhine import FRP.Rhine.Clock @@ -29,7 +33,7 @@ unyieldClock cl = UnscheduleClock cl $ const $ liftIO Concurrent.yield instance (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 (morphS run) <$> initClock scheduleClock + 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/Util.hs b/rhine/src/FRP/Rhine/Clock/Util.hs index b4f492f54..0f95f960a 100644 --- a/rhine/src/FRP/Rhine/Clock/Util.hs +++ b/rhine/src/FRP/Rhine/Clock/Util.hs @@ -3,9 +3,15 @@ module FRP.Rhine.Clock.Util where +-- base +import Control.Arrow + -- time-domain import Data.TimeDomain +-- automaton +import Data.Automaton (Automaton, delay) + -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy @@ -19,9 +25,9 @@ genTimeInfo :: (Monad m, Clock m cl) => ClockProxy cl -> Time cl -> - MSF m (Time cl, Tag cl) (TimeInfo cl) + Automaton m (Time cl, Tag cl) (TimeInfo cl) genTimeInfo _ initialTime = proc (absolute, tag) -> do - lastTime <- iPre initialTime -< absolute + lastTime <- delay initialTime -< absolute returnA -< TimeInfo diff --git a/rhine/src/FRP/Rhine/Reactimation.hs b/rhine/src/FRP/Rhine/Reactimation.hs index d115705e7..232a07210 100644 --- a/rhine/src/FRP/Rhine/Reactimation.hs +++ b/rhine/src/FRP/Rhine/Reactimation.hs @@ -6,9 +6,6 @@ as main loops. -} module FRP.Rhine.Reactimation where --- dunai -import Data.MonadicStreamFunction.InternalCore - -- rhine import FRP.Rhine.ClSF.Core import FRP.Rhine.Clock @@ -58,8 +55,9 @@ flow :: Rhine m cl () () -> m () flow rhine = do - msf <- eraseClock rhine - reactimate $ msf >>> arr (const ()) + automaton <- eraseClock rhine + reactimate $ automaton >>> arr (const ()) +{-# INLINE flow #-} {- | Run a synchronous 'ClSF' with its clock as a main loop, similar to Yampa's, or Dunai's, 'reactimate'. @@ -75,3 +73,4 @@ reactimateCl :: ClSF m cl () () -> m () reactimateCl cl clsf = flow $ clsf @@ cl +{-# INLINE reactimateCl #-} diff --git a/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs b/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs index 4ce17ebbf..980e45471 100644 --- a/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs +++ b/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs @@ -14,12 +14,10 @@ module FRP.Rhine.Reactimation.ClockErasure where -- base import Control.Monad (join) --- dunai -import Control.Monad.Trans.MSF.Reader -import Data.MonadicStreamFunction +-- automaton +import Data.Automaton.Trans.Reader -- rhine - import FRP.Rhine.ClSF hiding (runReaderS) import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy @@ -35,10 +33,11 @@ eraseClockClSF :: ClockProxy cl -> Time cl -> ClSF m cl a b -> - MSF m (Time cl, Tag cl, a) b + Automaton m (Time cl, Tag cl, a) b eraseClockClSF proxy initialTime clsf = proc (time, tag, a) -> do timeInfo <- genTimeInfo proxy initialTime -< (time, tag) runReaderS clsf -< (timeInfo, a) +{-# INLINE eraseClockClSF #-} {- | Run a signal network as a monadic stream function. @@ -53,7 +52,7 @@ eraseClockSN :: (Monad m, Clock m cl, GetClockProxy cl) => Time cl -> SN m cl a b -> - MSF m (Time cl, Tag cl, Maybe a) (Maybe 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) @@ -133,6 +132,7 @@ eraseClockSN initialTime (FirstResampling sn buf) = _ -> Nothing dMaybe <- mapMaybeS $ eraseClockResBuf (inProxy proxy) (outProxy proxy) initialTime buf -< resBufInput returnA -< (,) <$> bMaybe <*> join dMaybe +{-# INLINE eraseClockSN #-} {- | Translate a resampling buffer into a monadic stream function. @@ -149,7 +149,7 @@ eraseClockResBuf :: ClockProxy cl2 -> Time cl1 -> ResBuf m cl1 cl2 a b -> - MSF m (Either (Time cl1, Tag cl1, a) (Time cl2, Tag cl2)) (Maybe b) + Automaton m (Either (Time cl1, Tag cl1, a) (Time cl2, Tag cl2)) (Maybe b) eraseClockResBuf proxy1 proxy2 initialTime resBuf0 = feedback resBuf0 $ proc (input, resBuf) -> do case input of Left (time1, tag1, a) -> do @@ -160,3 +160,4 @@ eraseClockResBuf proxy1 proxy2 initialTime resBuf0 = feedback resBuf0 $ proc (in timeInfo2 <- genTimeInfo proxy2 initialTime -< (time2, tag2) (b, resBuf') <- arrM (uncurry get) -< (resBuf, timeInfo2) returnA -< (Just b, resBuf') +{-# INLINE eraseClockResBuf #-} diff --git a/rhine/src/FRP/Rhine/Reactimation/Combinators.hs b/rhine/src/FRP/Rhine/Reactimation/Combinators.hs index 4397285f6..c0acc54fd 100644 --- a/rhine/src/FRP/Rhine/Reactimation/Combinators.hs +++ b/rhine/src/FRP/Rhine/Reactimation/Combinators.hs @@ -44,6 +44,7 @@ infix 5 @@ cl -> Rhine m cl a b (@@) = Rhine . Synchronous +{-# INLINE (@@) #-} {- | A purely syntactical convenience construction enabling quadruple syntax for sequential composition, as described below. diff --git a/rhine/src/FRP/Rhine/ResamplingBuffer.hs b/rhine/src/FRP/Rhine/ResamplingBuffer.hs index 972466efd..57e6fafde 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer.hs @@ -15,6 +15,9 @@ module FRP.Rhine.ResamplingBuffer ( ) where +-- base +import Control.Arrow + -- rhine import FRP.Rhine.Clock diff --git a/rhine/src/FRP/Rhine/ResamplingBuffer/ClSF.hs b/rhine/src/FRP/Rhine/ResamplingBuffer/ClSF.hs index a6f9e3ff4..7c965ed0d 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/ClSF.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/ClSF.hs @@ -8,8 +8,9 @@ module FRP.Rhine.ResamplingBuffer.ClSF where -- transformers import Control.Monad.Trans.Reader (runReaderT) --- dunai -import Data.MonadicStreamFunction.InternalCore (unMSF) +-- automaton +import Data.Automaton +import Data.Stream.Result -- rhine import FRP.Rhine.ClSF.Core @@ -36,9 +37,9 @@ clsfBuffer = clsfBuffer' [] [(TimeInfo cl1, a)] -> ClSF m cl2 [(TimeInfo cl1, a)] b -> ResamplingBuffer m cl1 cl2 a b - clsfBuffer' as msf = ResamplingBuffer {..} + clsfBuffer' as automaton = ResamplingBuffer {..} where - put ti1 a = return $ clsfBuffer' ((ti1, a) : as) msf + put ti1 a = return $ clsfBuffer' ((ti1, a) : as) automaton get ti2 = do - (b, msf') <- runReaderT (unMSF msf as) ti2 - return (b, clsfBuffer msf') + Result automaton' b <- runReaderT (stepAutomaton automaton as) ti2 + return (b, clsfBuffer automaton') diff --git a/rhine/src/FRP/Rhine/ResamplingBuffer/Interpolation.hs b/rhine/src/FRP/Rhine/ResamplingBuffer/Interpolation.hs index 7c1b820c6..d3b9a112d 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/Interpolation.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/Interpolation.hs @@ -101,8 +101,8 @@ cubic :: ResamplingBuffer m cl1 cl2 v v {- FOURMOLU_DISABLE -} cubic = - ((iPre zeroVector &&& threePointDerivative) &&& (sinceInitS >-> iPre 0)) - >-> (clId &&& iPre (zeroVector, 0)) + ((delay zeroVector &&& threePointDerivative) &&& (sinceInitS >-> delay 0)) + >-> (clId &&& delay (zeroVector, 0)) ^->> keepLast ((zeroVector, 0), (zeroVector, 0)) >>-^ proc (((dv, v), t1), ((dv', v'), t1')) -> do t2 <- sinceInitS -< () diff --git a/rhine/src/FRP/Rhine/ResamplingBuffer/Util.hs b/rhine/src/FRP/Rhine/ResamplingBuffer/Util.hs index 2b44cc86e..08c058e18 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/Util.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/Util.hs @@ -8,8 +8,8 @@ module FRP.Rhine.ResamplingBuffer.Util where -- transformers import Control.Monad.Trans.Reader (runReaderT) --- dunai -import Data.MonadicStreamFunction.InternalCore +-- automaton +import Data.Stream.Result (Result (..)) -- rhine import FRP.Rhine.ClSF @@ -33,7 +33,7 @@ resBuf >>-^ clsf = ResamplingBuffer put_ get_ put_ theTimeInfo a = (>>-^ clsf) <$> put resBuf theTimeInfo a get_ theTimeInfo = do (b, resBuf') <- get resBuf theTimeInfo - (c, clsf') <- unMSF clsf b `runReaderT` theTimeInfo + Result clsf' c <- stepAutomaton clsf b `runReaderT` theTimeInfo return (c, resBuf' >>-^ clsf') infix 1 ^->> @@ -47,7 +47,7 @@ infix 1 ^->> clsf ^->> resBuf = ResamplingBuffer put_ get_ where put_ theTimeInfo a = do - (b, clsf') <- unMSF clsf a `runReaderT` theTimeInfo + Result clsf' b <- stepAutomaton clsf a `runReaderT` theTimeInfo resBuf' <- put resBuf theTimeInfo b return $ clsf' ^->> resBuf' get_ theTimeInfo = second (clsf ^->>) <$> get resBuf theTimeInfo diff --git a/rhine/src/FRP/Rhine/Schedule.hs b/rhine/src/FRP/Rhine/Schedule.hs index 3026bd870..6de3b26dc 100644 --- a/rhine/src/FRP/Rhine/Schedule.hs +++ b/rhine/src/FRP/Rhine/Schedule.hs @@ -17,35 +17,68 @@ and utilities to work with them. module FRP.Rhine.Schedule where -- base -import Data.List.NonEmpty (NonEmpty (..)) -import Data.List.NonEmpty qualified as N +import Control.Arrow +import Data.List.NonEmpty as N --- dunai -import Data.MonadicStreamFunction -import Data.MonadicStreamFunction.Async (concatS) -import Data.MonadicStreamFunction.InternalCore +-- transformers +import Control.Monad.Trans.Reader -- monad-schedule import Control.Monad.Schedule.Class +-- automaton +import Data.Automaton +import Data.Automaton.Final (getFinal, toFinal) +import Data.Stream +import Data.Stream.Final qualified as StreamFinal +import Data.Stream.Optimized (OptimizedStreamT (..), toStreamT) +import Data.Stream.Result + -- rhine import FRP.Rhine.Clock -- * Scheduling -scheduleList :: (Monad m, MonadSchedule m) => NonEmpty (MSF m a b) -> MSF m a (NonEmpty b) -scheduleList msfs = scheduleList' msfs [] - where - scheduleList' msfs running = MSF $ \a -> do - let bsAndConts = flip unMSF a <$> msfs - (done, running) <- schedule (N.head bsAndConts :| N.tail bsAndConts ++ running) - let (bs, dones) = N.unzip done - return (bs, scheduleList' dones running) - -{- | Two clocks in the 'ScheduleT' monad transformer - can always be canonically scheduled. - Indeed, this is the purpose for which 'ScheduleT' was defined. +{- | 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 $ + StreamT + { state = (getFinal . toFinal <$> automatons0, []) + , step = \(automatons, running) -> ReaderT $ \a -> do + let bsAndConts = flip (runReaderT . StreamFinal.getFinal) a <$> automatons + (done, running') <- schedule (N.head bsAndConts :| N.tail bsAndConts ++ running) + return $ Result (resultState <$> done, running') $ output <$> done + } + +{- | Run two automata concurrently. + +Whenever one automaton returns a value, it is returned. + +This is similar to 'scheduleList', but more efficient. +-} +schedulePair :: (Monad m, MonadSchedule m) => Automaton m a b -> Automaton m a b -> Automaton m a b +schedulePair (Automaton automatonL) (Automaton automatonR) = Automaton $! Stateful $! scheduleStreams (toStreamT automatonL) (toStreamT automatonR) + where + scheduleStreams :: (Monad m, MonadSchedule m) => StreamT m b -> StreamT m b -> StreamT m b + scheduleStreams (StreamT stateL0 stepL) (StreamT stateR0 stepR) = + StreamT + { state = (stepL stateL0, stepR stateR0) + , step + } + where + step (runningL, runningR) = do + result <- race runningL runningR + case result of + Left (Result stateL' b, runningR') -> return $ Result (stepL stateL', runningR') b + Right (runningL', Result stateR' b) -> return $ Result (runningL', stepR stateR') b + +-- | Run two running clocks concurrently. runningSchedule :: ( Monad m , MonadSchedule m @@ -58,7 +91,7 @@ runningSchedule :: RunningClock m (Time cl1) (Tag cl1) -> RunningClock m (Time cl2) (Tag cl2) -> RunningClock m (Time cl1) (Either (Tag cl1) (Tag cl2)) -runningSchedule _ _ rc1 rc2 = concatS $ scheduleList [rc1 >>> arr (second Left), rc2 >>> arr (second Right)] >>> arr N.toList +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, diff --git a/rhine/src/FRP/Rhine/Type.hs b/rhine/src/FRP/Rhine/Type.hs index 1a597bd10..c330c7dbd 100644 --- a/rhine/src/FRP/Rhine/Type.hs +++ b/rhine/src/FRP/Rhine/Type.hs @@ -10,8 +10,8 @@ A signal network together with a matching clock value. -} module FRP.Rhine.Type where --- dunai -import Data.MonadicStreamFunction +-- automaton +import Data.Automaton -- rhine import FRP.Rhine.Clock @@ -51,13 +51,14 @@ the input 'a' has to be given at all times, even those when it doesn't tick. eraseClock :: (Monad m, Clock m cl, GetClockProxy cl) => Rhine m cl a b -> - m (MSF m a (Maybe b)) + m (Automaton m a (Maybe b)) eraseClock Rhine {..} = do (runningClock, initTime) <- initClock clock -- Run the main loop return $ proc a -> do (time, tag) <- runningClock -< () eraseClockSN initTime sn -< (time, tag, a <$ inTag (toClockProxy sn) tag) +{-# INLINE eraseClock #-} {- | Loop back data from the output to the input. @@ -79,3 +80,4 @@ feedbackRhine buf Rhine {..} = { sn = Feedback buf sn , clock } +{-# INLINE feedbackRhine #-} diff --git a/rhine/test/Schedule.hs b/rhine/test/Schedule.hs index 8c385b3bd..bd13f00ee 100644 --- a/rhine/test/Schedule.hs +++ b/rhine/test/Schedule.hs @@ -16,8 +16,11 @@ import Test.Tasty.HUnit -- monad-schedule import Control.Monad.Schedule.Trans (Schedule, runScheduleT, wait) +-- automaton +import Data.Automaton (accumulateWith, constM, embed) + -- rhine -import FRP.Rhine.Clock (Clock (initClock), RunningClockInit, accumulateWith, constM, embed) +import FRP.Rhine.Clock (Clock (initClock), RunningClockInit) import FRP.Rhine.Clock.FixedStep (FixedStep (FixedStep)) import FRP.Rhine.Schedule import Util diff --git a/rhine/test/Util.hs b/rhine/test/Util.hs index 68c0179ec..6fece5f40 100644 --- a/rhine/test/Util.hs +++ b/rhine/test/Util.hs @@ -1,11 +1,12 @@ module Util where +-- base +import Data.Functor.Identity (Identity (runIdentity)) + -- monad-schedule import Control.Monad.Schedule.Trans (Schedule, runScheduleT) -- rhine - -import Data.Functor.Identity (Identity (runIdentity)) import FRP.Rhine runScheduleRhinePure :: (Clock (Schedule (Diff (Time cl))) cl, GetClockProxy cl) => Rhine (Schedule (Diff (Time cl))) cl a b -> [a] -> [Maybe b] @@ -13,8 +14,8 @@ runScheduleRhinePure rhine = runSchedule . runRhine rhine runRhine :: (Clock m cl, GetClockProxy cl, Monad m) => Rhine m cl a b -> [a] -> m [Maybe b] runRhine rhine input = do - msf <- eraseClock rhine - embed msf input + automaton <- eraseClock rhine + embed automaton input -- FIXME Move to monad-schedule runSchedule :: Schedule diff a -> a diff --git a/stack.9.0.2.yaml b/stack.9.0.2.yaml index dc9353177..68a1bcc9f 100644 --- a/stack.9.0.2.yaml +++ b/stack.9.0.2.yaml @@ -28,6 +28,7 @@ extra-deps: - hspec-discover-2.11.7@sha256:6307eb16d308258a99a242025df50217d835ba0a3f205b1202a100a175877b38,2169 - hspec-expectations-0.8.4@sha256:4237f094a7931202ff57ac6475542b0b314b50a7024550e2b6eb87cfb0d4ff93,1702 - dunai-0.12.2 +- mmorph-1.2.0@sha256:df9b213ec18f811cb3137b478d148f3f1680ee43f841cb775835fa282fdb0295,1083 nix: packages: diff --git a/stack.9.0.2.yaml.lock b/stack.9.0.2.yaml.lock index b5a272cc6..66cb7b905 100644 --- a/stack.9.0.2.yaml.lock +++ b/stack.9.0.2.yaml.lock @@ -144,6 +144,13 @@ packages: size: 2232 original: hackage: dunai-0.12.2 +- completed: + hackage: mmorph-1.2.0@sha256:df9b213ec18f811cb3137b478d148f3f1680ee43f841cb775835fa282fdb0295,1083 + pantry-tree: + sha256: 3dff3f49e5604657a2874faa3a0a2f38990a02b48d6c2b6ae56c2f22b4184a04 + size: 346 + original: + hackage: mmorph-1.2.0@sha256:df9b213ec18f811cb3137b478d148f3f1680ee43f841cb775835fa282fdb0295,1083 snapshots: - completed: sha256: f1c4aca9b9b81afbb9db55571acb0690cdc01ac97a178234de281f9dc075e95e diff --git a/versions.md b/versions.md new file mode 100644 index 000000000..c22ba532e --- /dev/null +++ b/versions.md @@ -0,0 +1,95 @@ +# Major major version bumps + +This document lists those major version bumps that are more likely to have broken your Rhine-depending code, +as well as guidance on how to fix these breakages. +You might still want to consult the changelogs of the individual packages, since only the biggest breakages are documented here. + +## 1.2 -> 1.3: Removed dunai dependency + +Rhine doesn't depend on [`dunai`](https://hackage.haskell.org/package/dunai) anymore. +Instead, its components are internally implemented as automata (a.k.a. state machines, transducers, Mealy machines, ...). +This doesn't make a big difference semantically, but it allows GHC to optimize the code substantially, +resulting in much faster programs, especially when the program consists of many components. + +This change is purely a change of the internal representation, it nearly doesn't affect the API of Rhine. +Where Rhine did in the past re-export symbols from `dunai`, +it now defines those names in a new package with the same semantics, [`automaton`](https://hackage.haskell.org/package/automaton). + +Naming and module structure of Rhine have staid largely the same, +a few changes are highlighted further below. + +You probably don't need to change anything if your code doesn't have a direct dependency on `dunai`. +There is only one tiny special case you need to be aware of, recursive definitions. + +### Direct `dunai` dependency in your code: Replace by `automaton` + +One reason you might have a dependency on `dunai` is because you wrote your own clock. +Else, you might have needed special combinators that Rhine didn't reexport, or defined your own `MSF` somewhere. + +If so, you need to replace the `MSF` type from `Data.MonadicStreamFunction` by the `Automaton` type from `Data.Automaton`. +This is typically done by just removing the `dunai` dependency from your code. +`Data.Automaton` is automatically re-exported in `FRP.Rhine`. + +A lot of code written for a `dunai` `MSF` will continue to work for a Rhine `Automaton`, +but there are a few cases where it doesn't, most prominently: + +* `iPre` is renamed to `delay` +* `morphS` is renamed to `hoistS` +* `morphGS` is renamed to `morph` +* You cannot build an `MSF` directly in continuation style. Consider this in `dunai` style: + ```haskell + myMSF s = MSF $ \a -> do + (b, s') <- doSomething a s + return (b, myMSF s') + ``` + You have to write this in "initial encoding", making the state explicit: + ```haskell + automaton = unfoldM s $ \a s -> do + (b, s') <- doSomething a s + return $! Result s' b + ``` + In those rare cases where you really need the continuation style, have a look at `Data.Automaton.Final`. + +### Avoid recursive definitions of `MSF`s + +One thing that doesn't work with the new representation is a recursion in the definition of an automaton itself. +Consider e.g. this construction that you can write in @dunai@: + +```haskell +myParallely :: Monad m => MSF m a b -> MSF m [a] [b] +myParallely msf = proc as -> do + case as of + [] -> returnA -< [] + (a : as') -> do + b <- msf -< a + bs <- myParallely msf -< as + returnA -< b : bs +``` +The trouble here is that `myParallely` is used in the definition of itself. +In @dunai@, this is fine. +In @automaton@, this will loop at runtime, making the program unresponsive. +(The reason for this is that automata have an internal existential state type, which mustn't be recursive.) + +For the rare cases where you might want to define an `Automaton` like this, +you will typically find a function that does the job for you. +For example, in this case you probably would have wanted to use `parallely`, +depending on what your intended semantics was. +In other situations, you might want to use a specific fixpoint operator like `fixA`. + +In the most general case, you can follow this mechanical process to rewrite a recursive definition: + +1. Rewrite your definition as the fixpoint of a function `f :: AutomatonT m a -> AutomatonT m a`. + For example, if you wanted to define `many a = ((:) <$> a <*> many a) <|> return []`, + then your function is `f x = ((:) <$> a <*> x) <|> return []`. + (Note that in this case, `a` is an external parameter to the fixpoint.) +2. Evaluate `f` completely, on a generic automaton. +3. Recognise how `f` transforms the state type of the automaton, and define a datatype that captures this transformation. +4. Use a fixpoint operator such as `fixStream` to define the recursion. + +For examples, see the definitions of `fixA`, `many`, or `parallely`. + +## 0.9 -> 1.0: Removed explicit schedules + +As a big simplification and breaking change, +explicit schedules were removed in version 1.0. +For an overview of the required changes, see [this page](/version1.md). From 3ea62401c81b6355d43ca6e24de981e3f15c130a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Tue, 7 May 2024 15:23:57 +0200 Subject: [PATCH 04/12] Move position of monad in Except types --- automaton/src/Data/Automaton/Trans/Except.hs | 38 +++++++++++--------- automaton/src/Data/Stream/Except.hs | 23 +++++++----- rhine-examples/src/Ball.hs | 2 +- rhine/src/FRP/Rhine/ClSF/Except.hs | 18 +++++----- 4 files changed, 47 insertions(+), 34 deletions(-) diff --git a/automaton/src/Data/Automaton/Trans/Except.hs b/automaton/src/Data/Automaton/Trans/Except.hs index 5bc2e692c..042969758 100644 --- a/automaton/src/Data/Automaton/Trans/Except.hs +++ b/automaton/src/Data/Automaton/Trans/Except.hs @@ -177,10 +177,10 @@ This type is useful because it is a monad in the /exception type/ @e@. Consider this example: @ -automaton :: AutomatonExcept m a b e1 -f :: e1 -> AutomatonExcept m a b e2 +automaton :: AutomatonExcept a b m e1 +f :: e1 -> AutomatonExcept a b m e2 -example :: AutomatonExcept m a b e2 +example :: AutomatonExcept a b m e2 example = automaton >>= f @ @@ -195,7 +195,7 @@ or just the '(>>)' operator, you should do this. The encoding of the internal state type will be much more efficiently optimized. The reason for this is that in an expression @ma >>= f@, -the type of @f@ is @e1 -> AutomatonExcept m a b e2@, +the type of @f@ is @e1 -> AutomatonExcept a b m e2@, which implies that the state of the 'AutomatonExcept' produced isn't known at compile time, and thus GHC cannot optimize the automaton. But often the full expressiveness of '>>=' isn't necessary, and in these cases, @@ -203,17 +203,23 @@ a much faster automaton is produced by using 'Functor', 'Applicative' and 'Selec Note: By "exceptions", we mean an 'ExceptT' transformer layer, not 'IO' exceptions. -} -newtype AutomatonExcept m a b e = AutomatonExcept {getAutomatonExcept :: StreamExcept (ReaderT a m) b e} +newtype AutomatonExcept a b m e = AutomatonExcept {getAutomatonExcept :: StreamExcept b (ReaderT a m) e} deriving newtype (Functor, Applicative, Selective, Monad) -runAutomatonExcept :: (Monad m) => AutomatonExcept m a b e -> Automaton (ExceptT e m) a b +instance MonadTrans (AutomatonExcept a b) where + lift = AutomatonExcept . lift . lift + +instance MFunctor (AutomatonExcept a b) where + hoist morph = AutomatonExcept . hoist (mapReaderT morph) . getAutomatonExcept + +runAutomatonExcept :: (Monad m) => AutomatonExcept a b m e -> Automaton (ExceptT e m) a b runAutomatonExcept = Automaton . hoist commuteReaderBack . runStreamExcept . getAutomatonExcept {- | Execute an 'Automaton' in 'ExceptT' until it raises an exception. Typically used to enter the monad context of 'AutomatonExcept'. -} -try :: (Monad m) => Automaton (ExceptT e m) a b -> AutomatonExcept m a b e +try :: (Monad m) => Automaton (ExceptT e m) a b -> AutomatonExcept a b m e try = AutomatonExcept . InitialExcept . hoist commuteReader . getAutomaton {- | Immediately throw the current input as an exception. @@ -221,7 +227,7 @@ try = AutomatonExcept . InitialExcept . hoist commuteReader . getAutomaton Useful inside 'AutomatonExcept' if you don't want to advance a further step in execution, but first see what the current input is before continuing. -} -currentInput :: (Monad m) => AutomatonExcept m e b e +currentInput :: (Monad m) => AutomatonExcept e b m e currentInput = try throwS {- | If no exception can occur, the 'Automaton' can be executed without the 'ExceptT' @@ -235,7 +241,7 @@ automaton = safely $ do once $ \input -> putStrLn $ "Whoops, something happened when receiving input " ++ show input ++ ": " ++ show e ++ ", but I'll continue now." safe fallbackAutomaton -} -safely :: (Monad m) => AutomatonExcept m a b Void -> Automaton m a b +safely :: (Monad m) => AutomatonExcept a b m Void -> Automaton m a b safely = Automaton . StreamExcept.safely . getAutomatonExcept {- | An 'Automaton' without an 'ExceptT' layer never throws an exception, and can @@ -244,21 +250,21 @@ thus have an arbitrary exception type. In particular, the exception type can be 'Void', so it can be used as the last statement in an 'AutomatonExcept' @do@-block. See 'safely' for an example. -} -safe :: (Monad m) => Automaton m a b -> AutomatonExcept m a b e +safe :: (Monad m) => Automaton m a b -> AutomatonExcept a b m e safe = try . liftS {- | Inside the 'AutomatonExcept' monad, execute an action of the wrapped monad. This passes the last input value to the action, but doesn't advance a tick. -} -once :: (Monad m) => (a -> m e) -> AutomatonExcept m a b e +once :: (Monad m) => (a -> m e) -> AutomatonExcept a b m e once f = AutomatonExcept $ InitialExcept $ StreamOptimized.constM $ ExceptT $ ReaderT $ fmap Left <$> f -- | Variant of 'once' without input. -once_ :: (Monad m) => m e -> AutomatonExcept m a b e +once_ :: (Monad m) => m e -> AutomatonExcept a b m e once_ = once . const -- | Advances a single tick with the given Kleisli arrow, and then throws an exception. -step :: (Monad m) => (a -> m (b, e)) -> AutomatonExcept m a b e +step :: (Monad m) => (a -> m (b, e)) -> AutomatonExcept a b m e step f = try $ proc a -> do n <- count -< () (b, e) <- arrM (lift . f) -< a @@ -266,13 +272,13 @@ step f = try $ proc a -> do returnA -< b -- | Advances a single tick outputting the value, and then throws '()'. -step_ :: (Monad m) => b -> AutomatonExcept m a b () +step_ :: (Monad m) => b -> AutomatonExcept a b m () step_ b = step $ const $ return (b, ()) {- | Converts a list to an 'AutomatonExcept', which outputs an element of the list at each step, throwing '()' when the list ends. -} -listToAutomatonExcept :: (Monad m) => [b] -> AutomatonExcept m a b () +listToAutomatonExcept :: (Monad m) => [b] -> AutomatonExcept a b m () listToAutomatonExcept = mapM_ step_ -- * Utilities definable in terms of 'AutomatonExcept' @@ -288,7 +294,7 @@ performOnFirstSample mAutomaton = safely $ do safe automaton -- | 'reactimate's an 'AutomatonExcept' until it throws an exception. -reactimateExcept :: (Monad m) => AutomatonExcept m () () e -> m e +reactimateExcept :: (Monad m) => AutomatonExcept () () m e -> m e reactimateExcept ae = fmap (either id absurd) $ runExceptT $ reactimate $ runAutomatonExcept ae -- | 'reactimate's an 'Automaton' until it returns 'True'. diff --git a/automaton/src/Data/Stream/Except.hs b/automaton/src/Data/Stream/Except.hs index 4af7d34a7..3d9c8ce42 100644 --- a/automaton/src/Data/Stream/Except.hs +++ b/automaton/src/Data/Stream/Except.hs @@ -20,37 +20,44 @@ import Data.Stream.Final.Except import Data.Stream.Optimized (OptimizedStreamT, applyExcept, constM, selectExcept) import Data.Stream.Optimized qualified as StreamOptimized -data StreamExcept m a e +data StreamExcept a m e = -- | When using '>>=', this encoding needs to be used. FinalExcept (Final (ExceptT e m) a) | -- | This is usually the faster encoding, as it can be optimized by GHC. InitialExcept (OptimizedStreamT (ExceptT e m) a) -toFinal :: (Functor m) => StreamExcept m a e -> Final (ExceptT e m) a +toFinal :: (Functor m) => StreamExcept a m e -> Final (ExceptT e m) a toFinal (FinalExcept final) = final toFinal (InitialExcept initial) = StreamOptimized.toFinal initial -runStreamExcept :: StreamExcept m a e -> OptimizedStreamT (ExceptT e m) a +runStreamExcept :: StreamExcept a m e -> OptimizedStreamT (ExceptT e m) a runStreamExcept (FinalExcept final) = StreamOptimized.fromFinal final runStreamExcept (InitialExcept initial) = initial -instance (Monad m) => Functor (StreamExcept m a) where +instance (Monad m) => Functor (StreamExcept a m) where fmap f (FinalExcept fe) = FinalExcept $ hoist (withExceptT f) fe fmap f (InitialExcept ae) = InitialExcept $ hoist (withExceptT f) ae -instance (Monad m) => Applicative (StreamExcept m a) where +instance (Monad m) => Applicative (StreamExcept a m) where pure = InitialExcept . constM . throwE InitialExcept f <*> InitialExcept a = InitialExcept $ applyExcept f a f <*> a = ap f a -instance (Monad m) => Selective (StreamExcept m a) where +instance (Monad m) => Selective (StreamExcept a m) where select (InitialExcept e) (InitialExcept f) = InitialExcept $ selectExcept e f select e f = selectM e f -- | 'return'/'pure' throw exceptions, '(>>=)' uses the last thrown exception as input for an exception handler. -instance (Monad m) => Monad (StreamExcept m a) where +instance (Monad m) => Monad (StreamExcept a m) where (>>) = (*>) ae >>= f = FinalExcept $ handleExceptT (toFinal ae) (toFinal . f) -safely :: (Monad m) => StreamExcept m a Void -> OptimizedStreamT m a +instance MonadTrans (StreamExcept a) where + lift = InitialExcept . constM . ExceptT . fmap Left + +instance MFunctor (StreamExcept a) where + hoist morph (InitialExcept automaton) = InitialExcept $ hoist (mapExceptT morph) automaton + hoist morph (FinalExcept final) = FinalExcept $ hoist (mapExceptT morph) final + +safely :: (Monad m) => StreamExcept a m Void -> OptimizedStreamT m a safely = hoist (fmap (either absurd id) . runExceptT) . runStreamExcept diff --git a/rhine-examples/src/Ball.hs b/rhine-examples/src/Ball.hs index 8691ccc35..0beba7abd 100644 --- a/rhine-examples/src/Ball.hs +++ b/rhine-examples/src/Ball.hs @@ -56,7 +56,7 @@ falling v0 = proc _ -> do throwMaybe -< guard $ height < 0 returnA -< pos -ballModes :: ClSFExcept IO SimClock (Maybe BallVel) Ball void +ballModes :: ClSFExcept SimClock (Maybe BallVel) Ball IO void ballModes = do v0 <- try waiting once_ $ putStrLn "Catch!" diff --git a/rhine/src/FRP/Rhine/ClSF/Except.hs b/rhine/src/FRP/Rhine/ClSF/Except.hs index 75f417b29..4266dbc69 100644 --- a/rhine/src/FRP/Rhine/ClSF/Except.hs +++ b/rhine/src/FRP/Rhine/ClSF/Except.hs @@ -99,41 +99,41 @@ and `(>>=)` is exception handling. * @b@: The output type * @e@: The type of exceptions that can be thrown -} -type ClSFExcept m cl a b e = AutomatonExcept (ReaderT (TimeInfo cl) m) a b e +type ClSFExcept cl a b m e = AutomatonExcept a b (ReaderT (TimeInfo cl) m) e {- | A clock polymorphic 'ClSFExcept', or equivalently an exception-throwing behaviour. Any clock with time domain @time@ may occur. -} -type BehaviourFExcept m time a b e = - forall cl. (time ~ Time cl) => ClSFExcept m cl a b e +type BehaviourFExcept time a b m e = + forall cl. (time ~ Time cl) => ClSFExcept cl a b m e -- | Compatibility to U.S. american spelling. -type BehaviorFExcept m time a b e = BehaviourFExcept m time a b e +type BehaviorFExcept time a b m e = BehaviourFExcept time a b m e -- | Leave the monad context, to use the 'ClSFExcept' as an 'Arrow'. -runClSFExcept :: (Monad m) => ClSFExcept m cl a b e -> ClSF (ExceptT e m) cl a b +runClSFExcept :: (Monad m) => ClSFExcept cl a b m e -> ClSF (ExceptT e m) cl a b runClSFExcept = hoistS commuteExceptReader . runAutomatonExcept {- | Enter the monad context in the exception for 'ClSF's in the 'ExceptT' monad. The 'ClSF' will be run until it encounters an exception. -} -try :: (Monad m) => ClSF (ExceptT e m) cl a b -> ClSFExcept m cl a b e +try :: (Monad m) => ClSF (ExceptT e m) cl a b -> ClSFExcept cl a b m e try = AutomatonE.try . hoistS commuteReaderExcept {- | Within the same tick, perform a monadic action, and immediately throw the value as an exception. -} -once :: (Monad m) => (a -> m e) -> ClSFExcept m cl a b e +once :: (Monad m) => (a -> m e) -> ClSFExcept cl a b m e once f = AutomatonE.once $ lift . f -- | A variant of 'once' without input. -once_ :: (Monad m) => m e -> ClSFExcept m cl a b e +once_ :: (Monad m) => m e -> ClSFExcept cl a b m e once_ = once . const {- | Advances a single tick with the given Kleisli arrow, and then throws an exception. -} -step :: (Monad m) => (a -> m (b, e)) -> ClSFExcept m cl a b e +step :: (Monad m) => (a -> m (b, e)) -> ClSFExcept cl a b m e step f = AutomatonE.step $ lift . f From 2d487e461652acee56c25ee0b63acefb0da07009 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Tue, 16 Apr 2024 15:14:31 +0200 Subject: [PATCH 05/12] Generalise flow type signature --- rhine/src/FRP/Rhine/Reactimation.hs | 17 ++++++++++++++++- rhine/test/Clock/Except.hs | 10 +++++----- 2 files changed, 21 insertions(+), 6 deletions(-) diff --git a/rhine/src/FRP/Rhine/Reactimation.hs b/rhine/src/FRP/Rhine/Reactimation.hs index 232a07210..7f07ab3c3 100644 --- a/rhine/src/FRP/Rhine/Reactimation.hs +++ b/rhine/src/FRP/Rhine/Reactimation.hs @@ -53,12 +53,27 @@ flow :: , Time cl ~ Time (Out cl) ) => Rhine m cl () () -> - m () + m void flow rhine = do automaton <- eraseClock rhine reactimate $ automaton >>> arr (const ()) {-# INLINE flow #-} +{- | Like 'flow', but with the type signature specialized to @m ()@. + +This is sometimes useful when dealing with ambiguous types. +-} +flow_ :: + ( Monad m + , Clock m cl + , GetClockProxy cl + , Time cl ~ Time (In cl) + , Time cl ~ Time (Out cl) + ) => + Rhine m cl () () -> + m () +flow_ = flow + {- | Run a synchronous 'ClSF' with its clock as a main loop, similar to Yampa's, or Dunai's, 'reactimate'. -} diff --git a/rhine/test/Clock/Except.hs b/rhine/test/Clock/Except.hs index cbd586eda..0417c3bea 100644 --- a/rhine/test/Clock/Except.hs +++ b/rhine/test/Clock/Except.hs @@ -86,7 +86,7 @@ catchClockTests = , testCase "Can recover from an exception" $ withTestStdin $ do let stopInClsf :: ClSF ME TestCatchClockMaybe () () stopInClsf = catchClSF clId $ constMCl empty - result <- runExceptT $ runMaybeT $ flow $ stopInClsf @@ testClockMaybe + result <- runExceptT $ runMaybeT $ flow_ $ stopInClsf @@ testClockMaybe result @?= Right Nothing ] @@ -115,13 +115,13 @@ failingClockTests = testGroup "FailingClock" [ testCase "flow fails immediately" $ do - result <- runExceptT $ flow $ clId @@ FailingClock + result <- runExceptT $ flow_ $ clId @@ FailingClock result @?= Left () , testCase "CatchClock recovers from failure at init" $ do let clsfStops :: ClSF (MaybeT IO) CatchFailingClock () () clsfStops = catchClSF clId $ constM $ lift empty - result <- runMaybeT $ flow $ clsfStops @@ catchFailingClock + result <- runMaybeT $ flow_ $ clsfStops @@ catchFailingClock result @?= Nothing -- The ClSF stopped the execution, not the clock ] @@ -143,13 +143,13 @@ delayedClockTests = tag <- tagS -< () textSoFar <- mappendS -< either (const []) pure tag throwOn' -< (isLeft tag, Just textSoFar) - result <- runExceptT $ flow $ throwCollectedText @@ delayedClock + result <- runExceptT $ flow_ $ throwCollectedText @@ delayedClock result @?= Left (Just ["data", "test"]) , testCase "DelayException throws error after 1 step" $ withTestStdin $ do let dontThrow :: ClSF (ExceptT (Maybe [Text]) IO) DelayedClock () () dontThrow = clId - result <- runExceptT $ flow $ dontThrow @@ delayedClock + result <- runExceptT $ flow_ $ dontThrow @@ delayedClock result @?= Left Nothing ] From 3ec574785b70b919e84036a7edb57a636a2185fa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Thu, 28 Mar 2024 16:21:45 +0100 Subject: [PATCH 06/12] Add benchmarks --- rhine/bench/Main.hs | 3 +- rhine/bench/Sum.hs | 73 ++++++++++++++++++++++++++++++++++++++++ rhine/bench/Test.hs | 19 +++++++++-- rhine/bench/WordCount.hs | 22 ++++++++++++ rhine/rhine.cabal | 18 ++++++++++ 5 files changed, 131 insertions(+), 4 deletions(-) create mode 100644 rhine/bench/Sum.hs diff --git a/rhine/bench/Main.hs b/rhine/bench/Main.hs index 5c3b36b9f..e1368426a 100644 --- a/rhine/bench/Main.hs +++ b/rhine/bench/Main.hs @@ -2,7 +2,8 @@ import Criterion.Main -- rhine +import Sum import WordCount main :: IO () -main = defaultMain [WordCount.benchmarks] +main = defaultMain [WordCount.benchmarks, Sum.benchmarks] diff --git a/rhine/bench/Sum.hs b/rhine/bench/Sum.hs new file mode 100644 index 000000000..36013cfd4 --- /dev/null +++ b/rhine/bench/Sum.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE PackageImports #-} + +{- | Sums up natural numbers. + +First create a lazy list [0, 1, 2, ...] and then sum over it. +Most of the implementations really benchmark 'embed', as the lazy list is created using it. +-} +module Sum where + +import "base" Control.Monad (foldM) +import "base" Data.Functor.Identity +import "base" Data.Void (absurd) + +import "criterion" Criterion.Main + +import "dunai" Data.MonadicStreamFunction as Dunai + +import "automaton" Data.Stream as Stream (StreamT (..)) +import "automaton" Data.Stream.Optimized (OptimizedStreamT (Stateful)) +import "automaton" Data.Stream.Result (Result (..)) +import "rhine" FRP.Rhine as Rhine + +nMax :: Int +nMax = 1_000_000 + +benchmarks :: Benchmark +benchmarks = + bgroup + "Sum" + [ bench "rhine" $ nf rhine nMax + , bench "rhine flow" $ nf rhineFlow nMax + , bench "dunai" $ nf dunai nMax + , bench "automaton" $ nf automaton nMax + , bench "direct" $ nf direct nMax + , bench "direct monad" $ nf directM nMax + ] + +rhine :: Int -> Int +rhine n = sum $ runIdentity $ Rhine.embed Rhine.count $ replicate n () + +-- FIXME separate ticket to improve performance of this +rhineFlow :: Int -> Int +rhineFlow n = + either id absurd $ + flow $ + (@@ Trivial) $ proc () -> do + k <- Rhine.count -< () + s <- Rhine.sumN -< k + if k < n + then returnA -< () + else arrMCl Left -< s + +dunai :: Int -> Int +dunai n = sum $ runIdentity $ Dunai.embed Dunai.count $ replicate n () + +automaton :: Int -> Int +automaton n = sum $ runIdentity $ Rhine.embed myCount $ replicate n () + where + myCount :: Automaton Identity () Int + myCount = + Automaton $ + Stateful + StreamT + { state = 1 + , Stream.step = \s -> return $! Result (s + 1) s + } + +direct :: Int -> Int +direct n = sum [0 .. n] + +directM :: Int -> Int +directM n = runIdentity $ foldM (\a b -> return $ a + b) 0 [0 .. n] diff --git a/rhine/bench/Test.hs b/rhine/bench/Test.hs index 743c0944a..33b36d89a 100644 --- a/rhine/bench/Test.hs +++ b/rhine/bench/Test.hs @@ -1,3 +1,6 @@ +-- rhine + +import Sum import WordCount -- tasty @@ -14,7 +17,17 @@ main :: IO () main = defaultMain $ testGroup - "WordCount" - [ testCase "rhine" $ rhineWordCount >>= (@?= wordCount) - , testCase "dunai" $ dunaiWordCount >>= (@?= wordCount) + "Benchmark tests" + [ testGroup + "WordCount" + [ testCase "rhine" $ rhineWordCount >>= (@?= wordCount) + , testCase "dunai" $ dunaiWordCount >>= (@?= wordCount) + ] + , testGroup + "Sum" + [ testCase "rhine" $ Sum.rhine Sum.nMax @?= Sum.direct Sum.nMax + , testCase "dunai" $ Sum.dunai Sum.nMax @?= Sum.direct Sum.nMax + , testCase "automaton" $ Sum.automaton Sum.nMax @?= Sum.direct Sum.nMax + , testCase "rhine flow" $ Sum.rhineFlow Sum.nMax @?= Sum.direct Sum.nMax + ] ] diff --git a/rhine/bench/WordCount.hs b/rhine/bench/WordCount.hs index 227080b73..f9aaa931e 100644 --- a/rhine/bench/WordCount.hs +++ b/rhine/bench/WordCount.hs @@ -26,6 +26,9 @@ import Criterion.Main import Control.Monad.Trans.MSF.Except qualified as Dunai import Data.MonadicStreamFunction qualified as Dunai +-- automaton +import Data.Automaton.Trans.Except qualified as Automaton + -- rhine import FRP.Rhine import FRP.Rhine.Clock.Except ( @@ -43,6 +46,7 @@ benchmarks = "WordCount" [ bench "rhine" $ nfIO rhineWordCount , bench "dunai" $ nfIO dunaiWordCount + , bench "automaton" $ nfIO automatonWordCount , bgroup "Text" [ bench "IORef" $ nfIO textWordCount @@ -79,6 +83,24 @@ rhineWordCount = do nWords <- mappendS -< either (const 0) (Sum . length . words) lineOrStop throwOn' -< (either isEOFError (const False) lineOrStop, Right $ getSum nWords) +{- | Implementation using automata. + +Within the automata framework, this is what the Rhine implementation could optimize to at most, +if all the extra complexity introduced by clocks is optimized away completely. +-} +automatonWordCount :: IO Int +automatonWordCount = do + Left (Right nWords) <- withInput $ runExceptT $ reactimate wc + return nWords + where + wc = proc () -> do + lineOrEOF <- constM $ liftIO $ Control.Exception.try getLine -< () + nWords <- mappendS -< either (const 0) (Sum . length . words) lineOrEOF + case lineOrEOF of + Right _ -> returnA -< () + Left e -> + Automaton.throwS -< if isEOFError e then Right $ getSum nWords else Left e + {- | Idiomatic dunai implementation. Compared to Rhine, this doesn't have the overhead of clocks, diff --git a/rhine/rhine.cabal b/rhine/rhine.cabal index 94cbeace8..30238de2d 100644 --- a/rhine/rhine.cabal +++ b/rhine/rhine.cabal @@ -190,12 +190,24 @@ benchmark benchmark autogen-modules: Paths_rhine other-modules: Paths_rhine + Sum WordCount build-depends: rhine main-is: Main.hs + ghc-options: + -Wall + + if flag(core) + ghc-options: + -fforce-recomp + -ddump-to-file + -ddump-simpl + -dsuppress-all + -dno-suppress-type-signatures + -dno-suppress-type-applications test-suite benchmark-test import: opts, bench-deps, test-deps @@ -204,9 +216,15 @@ test-suite benchmark-test autogen-modules: Paths_rhine other-modules: Paths_rhine + Sum WordCount build-depends: rhine main-is: Test.hs + +flag core + description: Dump GHC core files for debugging. + default: False + manual: True From 913840760b0bde88923038ad94b475272db8a0cf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Mon, 5 Feb 2024 17:45:13 +0100 Subject: [PATCH 07/12] rhine-bayes: Bump nParticles, since it's much faster now --- rhine-bayes/app/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/rhine-bayes/app/Main.hs b/rhine-bayes/app/Main.hs index f315bf848..d8df5e81d 100644 --- a/rhine-bayes/app/Main.hs +++ b/rhine-bayes/app/Main.hs @@ -171,7 +171,7 @@ emptyResult = -- | The number of particles used in the filter. Change according to available computing power. nParticles :: Int -nParticles = 100 +nParticles = 400 -- * Visualization From 2256c242ba6b4d914f65edb41eebde8f60ae7956 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Tue, 16 Apr 2024 15:13:56 +0200 Subject: [PATCH 08/12] Formatting --- rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs b/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs index 980e45471..7f9caeafb 100644 --- a/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs +++ b/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs @@ -3,8 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TupleSections #-} -{- | -Translate clocked signal processing components to stream functions without explicit clock types. +{- | Translate clocked signal processing components to stream functions without explicit clock types. This module is not meant to be used externally, and is thus not exported from 'FRP.Rhine'. From 0e7501b2269756460dccf81c9a8cd43c9076642d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Thu, 18 Apr 2024 21:38:16 +0200 Subject: [PATCH 09/12] WIP resbuf initial --- automaton/src/Data/Stream/Internal.hs | 1 + .../FRP/Rhine/Reactimation/ClockErasure.hs | 15 ++--- rhine/src/FRP/Rhine/ResamplingBuffer.hs | 29 +++++---- rhine/src/FRP/Rhine/ResamplingBuffer/ClSF.hs | 25 ++++---- .../src/FRP/Rhine/ResamplingBuffer/Collect.hs | 9 +-- rhine/src/FRP/Rhine/ResamplingBuffer/FIFO.hs | 14 +++-- .../FRP/Rhine/ResamplingBuffer/KeepLast.hs | 3 +- rhine/src/FRP/Rhine/ResamplingBuffer/LIFO.hs | 13 ++-- .../FRP/Rhine/ResamplingBuffer/Timeless.hs | 21 +++---- rhine/src/FRP/Rhine/ResamplingBuffer/Util.hs | 60 +++++++++++-------- 10 files changed, 104 insertions(+), 86 deletions(-) diff --git a/automaton/src/Data/Stream/Internal.hs b/automaton/src/Data/Stream/Internal.hs index 6885da2e1..ca662233d 100644 --- a/automaton/src/Data/Stream/Internal.hs +++ b/automaton/src/Data/Stream/Internal.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StrictData #-} +-- | Helper functions and types for Data.Stream. You will typically not need them. module Data.Stream.Internal where -- | A strict tuple type diff --git a/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs b/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs index 7f9caeafb..846962dbb 100644 --- a/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs +++ b/rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs @@ -15,6 +15,7 @@ import Control.Monad (join) -- automaton import Data.Automaton.Trans.Reader +import Data.Stream.Result (Result (..)) -- rhine import FRP.Rhine.ClSF hiding (runReaderS) @@ -98,17 +99,17 @@ eraseClockSN initialTime (Precompose clsf sn) = 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 buf0 sn) = +eraseClockSN initialTime (Feedback ResamplingBuffer {buffer, put, get} sn) = let proxy = toClockProxy sn in - feedback buf0 $ proc ((time, tag, aMaybe), buf) -> do + 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) - (c, buf') <- arrM $ uncurry get -< (buf, timeInfo) + 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 @@ -116,7 +117,7 @@ eraseClockSN initialTime (Feedback buf0 sn) = returnA -< (Nothing, buf') Just (tagOut, (b, d)) -> do timeInfo <- genTimeInfo (outProxy proxy) initialTime -< (time, tagOut) - buf'' <- arrM $ uncurry $ uncurry put -< ((buf', timeInfo), d) + buf'' <- arrM $ uncurry $ uncurry put -< ((timeInfo, d), buf') returnA -< (Just b, buf'') eraseClockSN initialTime (FirstResampling sn buf) = let @@ -149,14 +150,14 @@ eraseClockResBuf :: Time cl1 -> ResBuf m cl1 cl2 a b -> Automaton m (Either (Time cl1, Tag cl1, a) (Time cl2, Tag cl2)) (Maybe b) -eraseClockResBuf proxy1 proxy2 initialTime resBuf0 = feedback resBuf0 $ proc (input, resBuf) -> do +eraseClockResBuf proxy1 proxy2 initialTime ResamplingBuffer {buffer, put, get} = feedback buffer $ proc (input, resBuf) -> do case input of Left (time1, tag1, a) -> do timeInfo1 <- genTimeInfo proxy1 initialTime -< (time1, tag1) - resBuf' <- arrM (uncurry $ uncurry put) -< ((resBuf, timeInfo1), a) + resBuf' <- arrM (uncurry $ uncurry put) -< ((timeInfo1, a), resBuf) returnA -< (Nothing, resBuf') Right (time2, tag2) -> do timeInfo2 <- genTimeInfo proxy2 initialTime -< (time2, tag2) - (b, resBuf') <- arrM (uncurry get) -< (resBuf, timeInfo2) + Result resBuf' b <- arrM (uncurry get) -< (timeInfo2, resBuf) returnA -< (Just b, resBuf') {-# INLINE eraseClockResBuf #-} diff --git a/rhine/src/FRP/Rhine/ResamplingBuffer.hs b/rhine/src/FRP/Rhine/ResamplingBuffer.hs index 57e6fafde..698228603 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} @@ -15,10 +16,8 @@ module FRP.Rhine.ResamplingBuffer ( ) where --- base -import Control.Arrow - -- rhine +import Data.Stream.Result import FRP.Rhine.Clock -- A quick note on naming conventions, to whoever cares: @@ -39,18 +38,23 @@ or specific to certain clocks. * 'a': The input type * 'b': The output type -} -data ResamplingBuffer m cla clb a b = ResamplingBuffer - { put :: +data ResamplingBuffer m cla clb a b = forall s. + ResamplingBuffer + { buffer :: s + -- ^ The internal state of the buffer. + , put :: TimeInfo cla -> a -> - m (ResamplingBuffer m cla clb a b) + s -> + m s -- ^ Store one input value of type 'a' at a given time stamp, - -- and return a continuation. + -- and return an updated state. , get :: TimeInfo clb -> - m (b, ResamplingBuffer m cla clb a b) + s -> + m (Result s b) -- ^ Retrieve one output value of type 'b' at a given time stamp, - -- and a continuation. + -- and an updated state. } -- | A type synonym to allow for abbreviation. @@ -62,8 +66,9 @@ hoistResamplingBuffer :: (forall c. m1 c -> m2 c) -> ResamplingBuffer m1 cla clb a b -> ResamplingBuffer m2 cla clb a b -hoistResamplingBuffer hoist ResamplingBuffer {..} = +hoistResamplingBuffer morph ResamplingBuffer {..} = ResamplingBuffer - { put = (((hoistResamplingBuffer hoist <$>) . hoist) .) . put - , get = (second (hoistResamplingBuffer hoist) <$>) . hoist . get + { put = ((morph .) .) . put + , get = (morph .) . get + , buffer } diff --git a/rhine/src/FRP/Rhine/ResamplingBuffer/ClSF.hs b/rhine/src/FRP/Rhine/ResamplingBuffer/ClSF.hs index 7c965ed0d..e2d87cdf6 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/ClSF.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/ClSF.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE RecordWildCards #-} - {- | Collect and process all incoming values statefully and with time stamps. -} module FRP.Rhine.ResamplingBuffer.ClSF where -- transformers -import Control.Monad.Trans.Reader (runReaderT) +import Control.Monad.Trans.Reader (ReaderT, runReaderT) -- automaton import Data.Automaton -import Data.Stream.Result +import Data.Stream +import Data.Stream.Optimized (toStreamT) +import Data.Stream.Result (mapResultState) -- rhine import FRP.Rhine.ClSF.Core @@ -30,16 +30,15 @@ clsfBuffer :: -- The list will contain the /newest/ element in the head. ClSF m cl2 [(TimeInfo cl1, a)] b -> ResamplingBuffer m cl1 cl2 a b -clsfBuffer = clsfBuffer' [] +clsfBuffer = clsfBuffer' . toStreamT . getAutomaton where clsfBuffer' :: (Monad m) => - [(TimeInfo cl1, a)] -> - ClSF m cl2 [(TimeInfo cl1, a)] b -> + StreamT (ReaderT [(TimeInfo cl1, a)] (ReaderT (TimeInfo cl2) m)) b -> ResamplingBuffer m cl1 cl2 a b - clsfBuffer' as automaton = ResamplingBuffer {..} - where - put ti1 a = return $ clsfBuffer' ((ti1, a) : as) automaton - get ti2 = do - Result automaton' b <- runReaderT (stepAutomaton automaton as) ti2 - return (b, clsfBuffer automaton') + clsfBuffer' StreamT {state, step} = + ResamplingBuffer + { buffer = (state, []) + , put = \ti1 a (s, as) -> return (s, (ti1, a) : as) + , get = \ti2 (s, as) -> mapResultState (,[]) <$> runReaderT (runReaderT (step s) as) ti2 + } diff --git a/rhine/src/FRP/Rhine/ResamplingBuffer/Collect.hs b/rhine/src/FRP/Rhine/ResamplingBuffer/Collect.hs index 465f4f62a..ada05bfcc 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/Collect.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/Collect.hs @@ -11,6 +11,7 @@ module FRP.Rhine.ResamplingBuffer.Collect where import Data.Sequence -- rhine +import Data.Stream.Result (Result (..)) import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Timeless @@ -21,7 +22,7 @@ collect :: (Monad m) => ResamplingBuffer m cl1 cl2 a [a] collect = timelessResamplingBuffer AsyncMealy {..} [] where amPut as a = return $ a : as - amGet as = return (as, []) + amGet as = return $! Result [] as {- | Reimplementation of 'collect' with sequences, which gives a performance benefit if the sequence needs to be reversed or searched. @@ -30,7 +31,7 @@ collectSequence :: (Monad m) => ResamplingBuffer m cl1 cl2 a (Seq a) collectSequence = timelessResamplingBuffer AsyncMealy {..} empty where amPut as a = return $ a <| as - amGet as = return (as, empty) + amGet as = return $! Result empty as {- | 'pureBuffer' collects all input values lazily in a list and processes it when output is required. @@ -41,7 +42,7 @@ pureBuffer :: (Monad m) => ([a] -> b) -> ResamplingBuffer m cl1 cl2 a b pureBuffer f = timelessResamplingBuffer AsyncMealy {..} [] where amPut as a = return (a : as) - amGet as = return (f as, []) + amGet as = return $! Result [] $! f as -- TODO Test whether strictness works here, or consider using deepSeq @@ -58,4 +59,4 @@ foldBuffer :: foldBuffer f = timelessResamplingBuffer AsyncMealy {..} where amPut b a = let !b' = f a b in return b' - amGet b = return (b, b) + amGet b = return $! Result b b diff --git a/rhine/src/FRP/Rhine/ResamplingBuffer/FIFO.hs b/rhine/src/FRP/Rhine/ResamplingBuffer/FIFO.hs index 073b92b95..71276d959 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/FIFO.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/FIFO.hs @@ -12,6 +12,8 @@ import Prelude hiding (length, take) import Data.Sequence -- rhine + +import Data.Stream.Result (Result (..)) import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Timeless @@ -25,8 +27,8 @@ fifoUnbounded = timelessResamplingBuffer AsyncMealy {..} empty where amPut as a = return $ a <| as amGet as = case viewr as of - EmptyR -> return (Nothing, empty) - as' :> a -> return (Just a, as') + EmptyR -> return $! Result empty Nothing + as' :> a -> return $! Result as' (Just a) {- | A bounded FIFO buffer that forgets the oldest values when the size is above a given threshold. If the buffer is empty, it will return 'Nothing'. @@ -36,8 +38,8 @@ fifoBounded threshold = timelessResamplingBuffer AsyncMealy {..} empty where amPut as a = return $ take threshold $ a <| as amGet as = case viewr as of - EmptyR -> return (Nothing, empty) - as' :> a -> return (Just a, as') + EmptyR -> return $! Result empty Nothing + as' :> a -> return $! Result as' (Just a) -- | An unbounded FIFO buffer that also returns its current size. fifoWatch :: (Monad m) => ResamplingBuffer m cl1 cl2 a (Maybe a, Int) @@ -45,5 +47,5 @@ fifoWatch = timelessResamplingBuffer AsyncMealy {..} empty where amPut as a = return $ a <| as amGet as = case viewr as of - EmptyR -> return ((Nothing, 0), empty) - as' :> a -> return ((Just a, length as'), as') + EmptyR -> return $! Result empty (Nothing, 0) + as' :> a -> return $! Result as' (Just a, length as') diff --git a/rhine/src/FRP/Rhine/ResamplingBuffer/KeepLast.hs b/rhine/src/FRP/Rhine/ResamplingBuffer/KeepLast.hs index 491210e59..d1a210798 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/KeepLast.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/KeepLast.hs @@ -5,6 +5,7 @@ A buffer keeping the last value, or zero-order hold. -} module FRP.Rhine.ResamplingBuffer.KeepLast where +import Data.Stream.Result (Result (..)) import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Timeless @@ -16,5 +17,5 @@ import FRP.Rhine.ResamplingBuffer.Timeless keepLast :: (Monad m) => a -> ResamplingBuffer m cl1 cl2 a a keepLast = timelessResamplingBuffer AsyncMealy {..} where - amGet a = return (a, a) + amGet a = return $! Result a a amPut _ = return diff --git a/rhine/src/FRP/Rhine/ResamplingBuffer/LIFO.hs b/rhine/src/FRP/Rhine/ResamplingBuffer/LIFO.hs index 92a61412b..c55a74b43 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/LIFO.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/LIFO.hs @@ -12,6 +12,7 @@ import Prelude hiding (length, take) import Data.Sequence -- rhine +import Data.Stream.Result (Result (..)) import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Timeless @@ -25,8 +26,8 @@ lifoUnbounded = timelessResamplingBuffer AsyncMealy {..} empty where amPut as a = return $ a <| as amGet as = case viewl as of - EmptyL -> return (Nothing, empty) - a :< as' -> return (Just a, as') + EmptyL -> return $! Result empty Nothing + a :< as' -> return $! Result as' (Just a) {- | A bounded LIFO buffer that forgets the oldest values when the size is above a given threshold. If the buffer is empty, it will return 'Nothing'. @@ -36,8 +37,8 @@ lifoBounded threshold = timelessResamplingBuffer AsyncMealy {..} empty where amPut as a = return $ take threshold $ a <| as amGet as = case viewl as of - EmptyL -> return (Nothing, empty) - a :< as' -> return (Just a, as') + EmptyL -> return $! Result empty Nothing + a :< as' -> return $! Result as' (Just a) -- | An unbounded LIFO buffer that also returns its current size. lifoWatch :: (Monad m) => ResamplingBuffer m cl1 cl2 a (Maybe a, Int) @@ -45,5 +46,5 @@ lifoWatch = timelessResamplingBuffer AsyncMealy {..} empty where amPut as a = return $ a <| as amGet as = case viewl as of - EmptyL -> return ((Nothing, 0), empty) - a :< as' -> return ((Just a, length as'), as') + EmptyL -> return $! Result empty (Nothing, 0) + a :< as' -> return $! Result as' (Just a, length as') diff --git a/rhine/src/FRP/Rhine/ResamplingBuffer/Timeless.hs b/rhine/src/FRP/Rhine/ResamplingBuffer/Timeless.hs index 767b1e288..341c99155 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/Timeless.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/Timeless.hs @@ -6,6 +6,7 @@ These are used in many other modules implementing 'ResamplingBuffer's. -} module FRP.Rhine.ResamplingBuffer.Timeless where +import Data.Stream.Result import FRP.Rhine.ResamplingBuffer {- | An asynchronous, effectful Mealy machine description. @@ -16,7 +17,7 @@ import FRP.Rhine.ResamplingBuffer data AsyncMealy m s a b = AsyncMealy { amPut :: s -> a -> m s -- ^ Given the previous state and an input value, return the new state. - , amGet :: s -> m (b, s) + , amGet :: s -> m (Result s b) -- ^ Given the previous state, return an output value and a new state. } {- FOURMOLU_ENABLE -} @@ -30,21 +31,15 @@ data AsyncMealy m s a b = AsyncMealy -} timelessResamplingBuffer :: (Monad m) => - AsyncMealy m s a b -> -- The asynchronous Mealy machine from which the buffer is built - + -- | The asynchronous Mealy machine from which the buffer is built + AsyncMealy m s a b -> -- | The initial state s -> ResamplingBuffer m cl1 cl2 a b -timelessResamplingBuffer AsyncMealy {..} = go +timelessResamplingBuffer AsyncMealy {..} buffer = ResamplingBuffer {..} where - go s = - let - put _ a = go <$> amPut s a - get _ = do - (b, s') <- amGet s - return (b, go s') - in - ResamplingBuffer {..} + put _ a s = amPut s a + get _ = amGet -- | A resampling buffer that only accepts and emits units. trivialResamplingBuffer :: (Monad m) => ResamplingBuffer m cl1 cl2 () () @@ -52,6 +47,6 @@ trivialResamplingBuffer = timelessResamplingBuffer AsyncMealy { amPut = const (const (return ())) - , amGet = const (return ((), ())) + , amGet = const (return $! Result () ()) } () diff --git a/rhine/src/FRP/Rhine/ResamplingBuffer/Util.hs b/rhine/src/FRP/Rhine/ResamplingBuffer/Util.hs index 08c058e18..e46b0c9bf 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/Util.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/Util.hs @@ -9,10 +9,13 @@ module FRP.Rhine.ResamplingBuffer.Util where import Control.Monad.Trans.Reader (runReaderT) -- automaton -import Data.Stream.Result (Result (..)) +import Data.Stream (StreamT (..)) +import Data.Stream.Internal (JointState (..)) +import Data.Stream.Optimized (toStreamT) +import Data.Stream.Result (Result (..), mapResultState) -- rhine -import FRP.Rhine.ClSF +import FRP.Rhine.ClSF hiding (step) import FRP.Rhine.Clock import FRP.Rhine.ResamplingBuffer @@ -28,13 +31,16 @@ infix 2 >>-^ ResamplingBuffer m cl1 cl2 a b -> ClSF m cl2 b c -> ResamplingBuffer m cl1 cl2 a c -resBuf >>-^ clsf = ResamplingBuffer put_ get_ +resbuf >>-^ clsf = helper resbuf $ toStreamT $ getAutomaton clsf where - put_ theTimeInfo a = (>>-^ clsf) <$> put resBuf theTimeInfo a - get_ theTimeInfo = do - (b, resBuf') <- get resBuf theTimeInfo - Result clsf' c <- stepAutomaton clsf b `runReaderT` theTimeInfo - return (c, resBuf' >>-^ clsf') + helper ResamplingBuffer { buffer, put, get} StreamT { state, step} = ResamplingBuffer + { buffer = JointState buffer state, + put = \theTimeInfo a (JointState b s) -> (`JointState` s) <$> put theTimeInfo a b + , get = \theTimeInfo (JointState b s) -> do + Result b' b <- get theTimeInfo b + Result s' c <- step s `runReaderT` b `runReaderT` theTimeInfo + return $! Result (JointState b' s') c + } infix 1 ^->> @@ -44,13 +50,17 @@ infix 1 ^->> ClSF m cl1 a b -> ResamplingBuffer m cl1 cl2 b c -> ResamplingBuffer m cl1 cl2 a c -clsf ^->> resBuf = ResamplingBuffer put_ get_ +clsf ^->> resBuf = helper (toStreamT (getAutomaton clsf)) resBuf where - put_ theTimeInfo a = do - Result clsf' b <- stepAutomaton clsf a `runReaderT` theTimeInfo - resBuf' <- put resBuf theTimeInfo b - return $ clsf' ^->> resBuf' - get_ theTimeInfo = second (clsf ^->>) <$> get resBuf theTimeInfo + helper StreamT {state, step} ResamplingBuffer {buffer, put, get} = ResamplingBuffer + { + buffer = JointState buffer state + , put = \theTimeInfo a (JointState buf s) -> do + Result s' b <- step s `runReaderT` a `runReaderT` theTimeInfo + buf' <- put theTimeInfo b buf + return $! JointState buf' s' + , get = \theTimeInfo (JointState buf s) -> mapResultState (`JointState` s) <$> get theTimeInfo buf + } infixl 4 *-* @@ -60,16 +70,18 @@ infixl 4 *-* ResamplingBuffer m cl1 cl2 a b -> ResamplingBuffer m cl1 cl2 c d -> ResamplingBuffer m cl1 cl2 (a, c) (b, d) -resBuf1 *-* resBuf2 = ResamplingBuffer put_ get_ - where - put_ theTimeInfo (a, c) = do - resBuf1' <- put resBuf1 theTimeInfo a - resBuf2' <- put resBuf2 theTimeInfo c - return $ resBuf1' *-* resBuf2' - get_ theTimeInfo = do - (b, resBuf1') <- get resBuf1 theTimeInfo - (d, resBuf2') <- get resBuf2 theTimeInfo - return ((b, d), resBuf1' *-* resBuf2') +ResamplingBuffer buf1 put1 get1 *-* ResamplingBuffer buf2 put2 get2 = ResamplingBuffer + { + buffer = JointState buf1 buf2 + , put = \theTimeInfo (a, c) (JointState s1 s2) -> do + s1' <- put1 theTimeInfo a s1 + s2' <- put2 theTimeInfo c s2 + return $! JointState s1' s2' + , get = \theTimeInfo (JointState s1 s2) -> do + Result s1' b <- get1 theTimeInfo s1 + Result s2' d <- get2 theTimeInfo s2 + return $! Result (JointState s1' s2') (b, d) + } infixl 4 &-& From 044541e9d8a8224495713ef68b759c855de58c88 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Fri, 3 May 2024 18:22:09 +0200 Subject: [PATCH 10/12] Fix haddocks --- rhine/src/FRP/Rhine/ResamplingBuffer.hs | 2 +- rhine/src/FRP/Rhine/ResamplingBuffer/Collect.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/rhine/src/FRP/Rhine/ResamplingBuffer.hs b/rhine/src/FRP/Rhine/ResamplingBuffer.hs index 698228603..61d0e8fff 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer.hs @@ -29,7 +29,7 @@ import FRP.Rhine.Clock {- | A stateful buffer from which one may 'get' a value, or to which one may 'put' a value, depending on the clocks. -`ResamplingBuffer`s can be clock-polymorphic, +'ResamplingBuffer's can be clock-polymorphic, or specific to certain clocks. * 'm': Monad in which the 'ResamplingBuffer' may have side effects diff --git a/rhine/src/FRP/Rhine/ResamplingBuffer/Collect.hs b/rhine/src/FRP/Rhine/ResamplingBuffer/Collect.hs index ada05bfcc..f0efe869f 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/Collect.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/Collect.hs @@ -16,7 +16,7 @@ import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Timeless {- | Collects all input in a list, with the newest element at the head, - which is returned and emptied upon `get`. + which is returned and emptied upon 'get'. -} collect :: (Monad m) => ResamplingBuffer m cl1 cl2 a [a] collect = timelessResamplingBuffer AsyncMealy {..} [] From 13b895fab118afe54eca9b6bb42e5b97f81f4c95 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Tue, 7 May 2024 14:05:45 +0200 Subject: [PATCH 11/12] FIXME --- rhine/src/FRP/Rhine/ClSF/Except.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/rhine/src/FRP/Rhine/ClSF/Except.hs b/rhine/src/FRP/Rhine/ClSF/Except.hs index 4266dbc69..e9b33f057 100644 --- a/rhine/src/FRP/Rhine/ClSF/Except.hs +++ b/rhine/src/FRP/Rhine/ClSF/Except.hs @@ -86,6 +86,8 @@ throwMaybe = proc me -> case me of -- * Monad interface +-- FIXME docs + {- | A synchronous exception-throwing signal function. It is based on a @newtype@ from Dunai, 'AutomatonExcept', to exhibit a monad interface /in the exception type/. From e5ed5ba11c8b7479fcd9eef3160106dceb15af21 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Fri, 19 Apr 2024 11:01:21 +0200 Subject: [PATCH 12/12] WIP Clock erasure should happen at compile time, but can't achieve it through strictness * Maybe through simplifying initClock (https://github.com/turion/rhine/issues/304) * Looking at the Core it turns out that erased clock isn't completely simplified, and it's somehow obvious because it can't be inlined since it's recursive * I was hoping that if the automaton is evaluated strictly enough, it would be reduced to WHNF before reactimation starts but it's unclear whether this would even be visible in Core --- automaton/src/Data/Stream/Optimized.hs | 6 +++--- rhine/src/FRP/Rhine/Reactimation.hs | 3 ++- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/automaton/src/Data/Stream/Optimized.hs b/automaton/src/Data/Stream/Optimized.hs index ef30ff2c5..e6a757d2d 100644 --- a/automaton/src/Data/Stream/Optimized.hs +++ b/automaton/src/Data/Stream/Optimized.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE RankNTypes #-} @@ -160,8 +161,8 @@ handleOptimized f stream = Stateful $ f $ toStreamT stream See 'Data.Stream.reactimate'. -} reactimate :: (Monad m) => OptimizedStreamT m () -> m void -reactimate (Stateful stream) = StreamT.reactimate stream -reactimate (Stateless f) = go +reactimate (Stateful !stream) = StreamT.reactimate stream +reactimate (Stateless !f) = go where go = f *> go {-# INLINE reactimate #-} @@ -173,7 +174,6 @@ since the optimized version doesn't create a state type. -} constM :: m a -> OptimizedStreamT m a constM = Stateless -{-# INLINE constM #-} -- | Perform one step of a stream, resulting in an updated stream and an output value. stepOptimizedStream :: (Functor m) => OptimizedStreamT m a -> m (Result (OptimizedStreamT m a) a) diff --git a/rhine/src/FRP/Rhine/Reactimation.hs b/rhine/src/FRP/Rhine/Reactimation.hs index 7f07ab3c3..47a68bc56 100644 --- a/rhine/src/FRP/Rhine/Reactimation.hs +++ b/rhine/src/FRP/Rhine/Reactimation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GADTs #-} {- | @@ -55,7 +56,7 @@ flow :: Rhine m cl () () -> m void flow rhine = do - automaton <- eraseClock rhine + !automaton <- eraseClock rhine reactimate $ automaton >>> arr (const ()) {-# INLINE flow #-}