diff --git a/CHEATSHEET.md b/CHEATSHEET.md index dfcee4b1..8ffb748e 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 5bb979d6..04c810f5 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 00000000..97a7c8ec --- /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 00000000..8b76fa3b --- /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 00000000..8532f50f --- /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 00000000..862cd410 --- /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.2 && <=1.4, + simple-affine-space ^>=0.2, + these >=1.1 && <=1.3, + 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 00000000..d4d065cc --- /dev/null +++ b/automaton/src/Data/Automaton.hs @@ -0,0 +1,516 @@ +{-# 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.Maybe (fromMaybe) +import Data.Monoid (Last (..), 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')) + +-- | Remembers the last 'Just' value, defaulting to the given initialisation value. +lastS :: (Monad m) => a -> Automaton m (Maybe a) a +lastS a = arr Last >>> mappendS >>> arr (getLast >>> fromMaybe a) diff --git a/automaton/src/Data/Automaton/Final.hs b/automaton/src/Data/Automaton/Final.hs new file mode 100644 index 00000000..69fb866c --- /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 00000000..748e6fb4 --- /dev/null +++ b/automaton/src/Data/Automaton/Trans/Except.hs @@ -0,0 +1,328 @@ +{-# 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 a b m e1 +f :: e1 -> AutomatonExcept a b m e2 + +example :: AutomatonExcept a b m 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 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, +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 a b m e = AutomatonExcept {getAutomatonExcept :: StreamExcept b (ReaderT a m) e} + deriving newtype (Functor, Applicative, Selective, Monad) + +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 a b m 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 e b m 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 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 +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 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 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 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 a b m 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 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 a b m () +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 00000000..778a20ca --- /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 00000000..2251a780 --- /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 00000000..4a74dbb6 --- /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 00000000..f7a99fd3 --- /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 00000000..37c4fa91 --- /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 00000000..09023641 --- /dev/null +++ b/automaton/src/Data/Automaton/Trans/State.hs @@ -0,0 +1,69 @@ +{- | 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, (>>>)) +import Data.Tuple (swap) + +-- transformers +import Control.Monad.Trans.State.Strict + +-- automaton +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 00000000..e3aed357 --- /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 00000000..c85cfc2b --- /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 00000000..24289c78 --- /dev/null +++ b/automaton/src/Data/Stream/Except.hs @@ -0,0 +1,70 @@ +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 + +{- | A stream that can terminate with an exception. + +In @automaton@, such streams mainly serve as a vehicle to bring control flow to 'AutomatonExcept' +(which is based on 'StreamExcept'), and the docs there apply here as well. + +'StreamExcept' is not only a 'Monad', it also has more efficient 'Selective', 'Applicative', and 'Functor' interfaces. +-} +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 a m e -> Final (ExceptT e m) a +toFinal (FinalExcept final) = final +toFinal (InitialExcept initial) = StreamOptimized.toFinal initial + +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 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 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 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 a m) where + (>>) = (*>) + ae >>= f = FinalExcept $ handleExceptT (toFinal ae) (toFinal . f) + +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/automaton/src/Data/Stream/Final.hs b/automaton/src/Data/Stream/Final.hs new file mode 100644 index 00000000..ab6a0820 --- /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 00000000..0a638a07 --- /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 00000000..ca662233 --- /dev/null +++ b/automaton/src/Data/Stream/Internal.hs @@ -0,0 +1,23 @@ +{-# 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 +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 00000000..ef30ff2c --- /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 00000000..cb9461f6 --- /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 00000000..26dd4422 --- /dev/null +++ b/automaton/test/Automaton.hs @@ -0,0 +1,92 @@ +{-# 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] + , testCase "lastS" $ runIdentity (embed (lastS 0) [Nothing, Just 10]) @?= [0, 10] + , 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 00000000..ab257431 --- /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 00000000..a5d7b4e7 --- /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 00000000..4e4ce265 --- /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 440ab306..c686d928 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 cba3f783..d8df5e81 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 @@ -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 @@ -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 a00b12d9..afb5f914 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 00000000..07e51b68 --- /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 05ed8487..00000000 --- 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 0f054ec9..f8e5ddc8 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-examples/src/Ball.hs b/rhine-examples/src/Ball.hs index 8691ccc3..0beba7ab 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-gloss/Main.hs b/rhine-gloss/Main.hs index 15613695..c8a315a6 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 d6097b60..722dc123 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 253fa226..2c5d960d 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 cdea407d..44d88fe7 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 3e29528a..50d95b9b 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 25025079..0b67ddbf 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/Main.hs b/rhine/bench/Main.hs index 5c3b36b9..e1368426 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 00000000..36013cfd --- /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 743c0944..33b36d89 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 6a90fb16..f9aaa931 100644 --- a/rhine/bench/WordCount.hs +++ b/rhine/bench/WordCount.hs @@ -23,11 +23,13 @@ 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 +-- automaton +import Data.Automaton.Trans.Except qualified as Automaton -import Control.Monad.Trans.MSF.Except qualified as Dunai +-- rhine import FRP.Rhine import FRP.Rhine.Clock.Except ( DelayIOError, @@ -44,6 +46,7 @@ benchmarks = "WordCount" [ bench "rhine" $ nfIO rhineWordCount , bench "dunai" $ nfIO dunaiWordCount + , bench "automaton" $ nfIO automatonWordCount , bgroup "Text" [ bench "IORef" $ nfIO textWordCount @@ -71,18 +74,37 @@ 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) + +{- | 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 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 +117,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 +150,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 +165,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 diff --git a/rhine/rhine.cabal b/rhine/rhine.cabal index fc9eb5b2..30238de2 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, @@ -162,6 +169,7 @@ test-suite test Clock.Except Clock.FixedStep Clock.Millisecond + Except Paths_rhine Schedule Util @@ -182,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 @@ -196,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 diff --git a/rhine/src/FRP/Rhine.hs b/rhine/src/FRP/Rhine.hs index 5b36ee4f..bf08caee 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 982a0a0d..91d91c99 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 fc65a873..26b5158f 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 f358db7c..9e928908 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,53 +87,54 @@ 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 @automaton@, '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 * @a@: The input type * @b@: The output type +* @m@: The monad that the signal function may take side effects in * @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 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 = morphS commuteExceptReader . runMSFExcept +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 = MSFE.try . morphS commuteReaderExcept +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 f = MSFE.once $ lift . f +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 f = MSFE.step $ lift . f +step :: (Monad m) => (a -> m (b, e)) -> ClSFExcept cl a b m e +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 ca464d7e..7dafb428 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 20a8db48..177ad7f3 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 b9b8428a..f16d8849 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 ccf4171b..87686129 100644 --- a/rhine/src/FRP/Rhine/ClSF/Util.hs +++ b/rhine/src/FRP/Rhine/ClSF/Util.hs @@ -16,8 +16,6 @@ module FRP.Rhine.ClSF.Util where import Control.Arrow import Control.Category (Category) import Control.Category qualified (id) -import Data.Maybe (fromJust) -import Data.Monoid (Last (Last), getLast) -- containers import Data.Sequence @@ -26,9 +24,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 +174,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 +201,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', @@ -435,11 +431,3 @@ scaledTimer :: Diff td -> BehaviorF (ExceptT () m) td a (Diff td) scaledTimer diff = timer diff >>> arr (/ diff) - --- * To be ported to Dunai - -{- | Remembers the last 'Just' value, - defaulting to the given initialisation value. --} -lastS :: (Monad m) => a -> MSF 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 1f3a3fb6..24abb256 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 0b11d18c..8bbf6b2b 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 8746d2bf..551df585 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 ee203b11..01ae458c 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 70f6c655..77102edf 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 688d8ed3..f0ddecce 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 736bf60f..72172a80 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 0a4e86eb..b0e981cd 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 3da4e071..a68e1783 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 e19056cc..9246f65c 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 9b2876e5..63dedbdd 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 d0c56c5f..025930d2 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 b4f492f5..0f95f960 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 d115705e..7f07ab3c 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 @@ -56,10 +53,26 @@ flow :: , Time cl ~ Time (Out cl) ) => Rhine m cl () () -> - m () + m void flow rhine = do - msf <- eraseClock rhine - reactimate $ msf >>> arr (const ()) + 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'. @@ -75,3 +88,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 4ce17ebb..846962db 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'. @@ -14,12 +13,11 @@ 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 +import Data.Stream.Result (Result (..)) -- 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) @@ -100,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 @@ -118,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 @@ -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,14 +149,15 @@ 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) -eraseClockResBuf proxy1 proxy2 initialTime resBuf0 = feedback resBuf0 $ proc (input, resBuf) -> do + Automaton m (Either (Time cl1, Tag cl1, a) (Time cl2, Tag cl2)) (Maybe b) +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/Reactimation/Combinators.hs b/rhine/src/FRP/Rhine/Reactimation/Combinators.hs index 4397285f..c0acc54f 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 972466ef..3b81a566 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,6 +16,9 @@ module FRP.Rhine.ResamplingBuffer ( ) where +-- automaton +import Data.Stream.Result + -- rhine import FRP.Rhine.Clock @@ -27,7 +31,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 @@ -36,18 +40,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. @@ -59,8 +68,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 a6f9e3ff..e2d87cdf 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/ClSF.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/ClSF.hs @@ -1,15 +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) --- dunai -import Data.MonadicStreamFunction.InternalCore (unMSF) +-- automaton +import Data.Automaton +import Data.Stream +import Data.Stream.Optimized (toStreamT) +import Data.Stream.Result (mapResultState) -- rhine import FRP.Rhine.ClSF.Core @@ -29,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 msf = ResamplingBuffer {..} - where - put ti1 a = return $ clsfBuffer' ((ti1, a) : as) msf - get ti2 = do - (b, msf') <- runReaderT (unMSF msf as) ti2 - return (b, clsfBuffer msf') + 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 465f4f62..4c31da9d 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/Collect.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/Collect.hs @@ -10,18 +10,21 @@ module FRP.Rhine.ResamplingBuffer.Collect where -- containers import Data.Sequence +-- automaton +import Data.Stream.Result (Result (..)) + -- rhine 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 {..} [] 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 +33,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 +44,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 +61,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 073b92b9..1e9ddc0d 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/FIFO.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/FIFO.hs @@ -11,6 +11,9 @@ import Prelude hiding (length, take) -- containers import Data.Sequence +-- automaton +import Data.Stream.Result (Result (..)) + -- rhine import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Timeless @@ -25,8 +28,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 +39,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 +48,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/Interpolation.hs b/rhine/src/FRP/Rhine/ResamplingBuffer/Interpolation.hs index 7c1b820c..d3b9a112 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/KeepLast.hs b/rhine/src/FRP/Rhine/ResamplingBuffer/KeepLast.hs index 491210e5..6e95383f 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/KeepLast.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/KeepLast.hs @@ -5,6 +5,10 @@ A buffer keeping the last value, or zero-order hold. -} module FRP.Rhine.ResamplingBuffer.KeepLast where +-- automaton +import Data.Stream.Result (Result (..)) + +-- rhine import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Timeless @@ -16,5 +20,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 92a61412..d5225efe 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/LIFO.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/LIFO.hs @@ -11,6 +11,9 @@ import Prelude hiding (length, take) -- containers import Data.Sequence +-- automaton +import Data.Stream.Result (Result (..)) + -- rhine import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Timeless @@ -25,8 +28,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 +39,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 +48,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 767b1e28..cc251af2 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/Timeless.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/Timeless.hs @@ -6,6 +6,10 @@ These are used in many other modules implementing 'ResamplingBuffer's. -} module FRP.Rhine.ResamplingBuffer.Timeless where +-- automaton +import Data.Stream.Result + +-- rhine import FRP.Rhine.ResamplingBuffer {- | An asynchronous, effectful Mealy machine description. @@ -14,9 +18,9 @@ import FRP.Rhine.ResamplingBuffer -} {- FOURMOLU_DISABLE -} data AsyncMealy m s a b = AsyncMealy - { amPut :: s -> a -> m s + { 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 +34,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 +50,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 2b44cc86..e46b0c9b 100644 --- a/rhine/src/FRP/Rhine/ResamplingBuffer/Util.hs +++ b/rhine/src/FRP/Rhine/ResamplingBuffer/Util.hs @@ -8,11 +8,14 @@ module FRP.Rhine.ResamplingBuffer.Util where -- transformers import Control.Monad.Trans.Reader (runReaderT) --- dunai -import Data.MonadicStreamFunction.InternalCore +-- automaton +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 - (c, clsf') <- unMSF 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 - (b, clsf') <- unMSF 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 &-& diff --git a/rhine/src/FRP/Rhine/Schedule.hs b/rhine/src/FRP/Rhine/Schedule.hs index 3026bd87..6de3b26d 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 1a597bd1..c330c7db 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/Clock/Except.hs b/rhine/test/Clock/Except.hs index cbd586ed..0417c3be 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 ] diff --git a/rhine/test/Except.hs b/rhine/test/Except.hs new file mode 100644 index 00000000..114f7240 --- /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 163607fd..ebafabf0 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 ] diff --git a/rhine/test/Schedule.hs b/rhine/test/Schedule.hs index 8c385b3b..bd13f00e 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 68c0179e..6fece5f4 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 dc935317..86f05b33 100644 --- a/stack.9.0.2.yaml +++ b/stack.9.0.2.yaml @@ -1,6 +1,7 @@ resolver: lts-19.08 packages: +- automaton - rhine - rhine-examples - rhine-gloss @@ -28,6 +29,8 @@ 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 +- selective-0.7.0.1@sha256:542ab572491898552b42d62d43a7e8c70fb93d714c06c06a4de6f331fee87df2,3509 nix: packages: diff --git a/stack.9.0.2.yaml.lock b/stack.9.0.2.yaml.lock index b5a272cc..ae53c1e0 100644 --- a/stack.9.0.2.yaml.lock +++ b/stack.9.0.2.yaml.lock @@ -68,9 +68,9 @@ packages: original: hackage: monad-bayes-1.2.0@sha256:bf83cf8e6d163c461b9964dbff48d4476b2a82421962af317b3a3d0d738ea2a2,6456 - completed: - hackage: criterion-1.6.3.0@sha256:cf27e6c83f91674fb67ef253cae644ad0ce079b7e2cfa6402e13e930f78499ec,5373 + hackage: criterion-1.6.3.0@sha256:62f9196ded68c39855a3a5dadb35dd43828ca091eeeb2ff38fdd259040d8e694,5616 pantry-tree: - sha256: 2102113a4ac228305ea9396967878c6921377bafc92425c1b8cf82f8afbef40e + sha256: 49fd0557bac66fa04f4cdb5b2c0f108b2c2057f69d9d56eaecdbcdb316b42385 size: 2323 original: hackage: criterion-1.6.3.0 @@ -144,6 +144,20 @@ 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 +- completed: + hackage: selective-0.7.0.1@sha256:542ab572491898552b42d62d43a7e8c70fb93d714c06c06a4de6f331fee87df2,3509 + pantry-tree: + sha256: 0c83390d679a54549b03180465335118331f120511a11e82a1c8e2d9cbd5ed55 + size: 1292 + original: + hackage: selective-0.7.0.1@sha256:542ab572491898552b42d62d43a7e8c70fb93d714c06c06a4de6f331fee87df2,3509 snapshots: - completed: sha256: f1c4aca9b9b81afbb9db55571acb0690cdc01ac97a178234de281f9dc075e95e diff --git a/stack.9.2.8.yaml b/stack.9.2.8.yaml index 75e2b028..46d164c5 100644 --- a/stack.9.2.8.yaml +++ b/stack.9.2.8.yaml @@ -1,6 +1,7 @@ resolver: lts-20.26 packages: +- automaton - rhine - rhine-examples - rhine-gloss @@ -22,6 +23,7 @@ extra-deps: - criterion-1.6.3.0@sha256:cf27e6c83f91674fb67ef253cae644ad0ce079b7e2cfa6402e13e930f78499ec,5373 - criterion-measurement-0.2.1.0@sha256:646d5b5c55499580747746396b731ef9d6e2cd59fa7b488354788e68eae8e9bc,2098 - optparse-applicative-0.18.1.0@sha256:b4cf8d9018e5e67cb1f14edb5130b6d05ad8bc1b5f6bd4efaa6ec0b7f28f559d,5132 +- selective-0.7.0.1@sha256:542ab572491898552b42d62d43a7e8c70fb93d714c06c06a4de6f331fee87df2,3509 nix: packages: diff --git a/stack.9.2.8.yaml.lock b/stack.9.2.8.yaml.lock index 66ae730d..d77335ba 100644 --- a/stack.9.2.8.yaml.lock +++ b/stack.9.2.8.yaml.lock @@ -102,6 +102,13 @@ packages: size: 3124 original: hackage: optparse-applicative-0.18.1.0@sha256:b4cf8d9018e5e67cb1f14edb5130b6d05ad8bc1b5f6bd4efaa6ec0b7f28f559d,5132 +- completed: + hackage: selective-0.7.0.1@sha256:542ab572491898552b42d62d43a7e8c70fb93d714c06c06a4de6f331fee87df2,3509 + pantry-tree: + sha256: 0c83390d679a54549b03180465335118331f120511a11e82a1c8e2d9cbd5ed55 + size: 1292 + original: + hackage: selective-0.7.0.1@sha256:542ab572491898552b42d62d43a7e8c70fb93d714c06c06a4de6f331fee87df2,3509 snapshots: - completed: sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2 diff --git a/stack.9.4.7.yaml b/stack.9.4.7.yaml index a51aed46..bb628b22 100644 --- a/stack.9.4.7.yaml +++ b/stack.9.4.7.yaml @@ -1,6 +1,7 @@ resolver: lts-21.21 packages: +- automaton - rhine - rhine-examples - rhine-gloss @@ -17,6 +18,7 @@ extra-deps: - hspec-discover-2.11.7@sha256:6307eb16d308258a99a242025df50217d835ba0a3f205b1202a100a175877b38,2169 - hspec-expectations-0.8.4@sha256:4237f094a7931202ff57ac6475542b0b314b50a7024550e2b6eb87cfb0d4ff93,1702 - vector-0.12.3.1@sha256:39141f312871b7c793a63be76635999e84d442aa3290aec59f30638ec0bf23a7,8218 +- selective-0.7.0.1@sha256:542ab572491898552b42d62d43a7e8c70fb93d714c06c06a4de6f331fee87df2,3509 nix: packages: diff --git a/stack.9.4.7.yaml.lock b/stack.9.4.7.yaml.lock index 454afdcd..6a525ab5 100644 --- a/stack.9.4.7.yaml.lock +++ b/stack.9.4.7.yaml.lock @@ -67,6 +67,13 @@ packages: size: 3842 original: hackage: vector-0.12.3.1@sha256:39141f312871b7c793a63be76635999e84d442aa3290aec59f30638ec0bf23a7,8218 +- completed: + hackage: selective-0.7.0.1@sha256:542ab572491898552b42d62d43a7e8c70fb93d714c06c06a4de6f331fee87df2,3509 + pantry-tree: + sha256: 0c83390d679a54549b03180465335118331f120511a11e82a1c8e2d9cbd5ed55 + size: 1292 + original: + hackage: selective-0.7.0.1@sha256:542ab572491898552b42d62d43a7e8c70fb93d714c06c06a4de6f331fee87df2,3509 snapshots: - completed: sha256: 7d4b649cf368f9076d8aa049aa44efe58950971d105892734e9957b2a26a2186 diff --git a/stack.yaml.lock b/stack.yaml.lock index b4832bc4..1f3518d9 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -4,13 +4,6 @@ # https://docs.haskellstack.org/en/stable/lock_files packages: -- completed: - hackage: dunai-0.11.1@sha256:b527b801c8b3901a4ebec733ac0bb6ff9cdd2b6b04ec385e18922f49c39e4b51,6372 - pantry-tree: - sha256: 7d851bd99aa0b02b43a4238c3b963de6e207b79b3ddc55e10aea6dc550936ad0 - size: 2172 - original: - hackage: dunai-0.11.1@sha256:b527b801c8b3901a4ebec733ac0bb6ff9cdd2b6b04ec385e18922f49c39e4b51,6372 - completed: hackage: simple-affine-space-0.2.1@sha256:bc9b1f5ae236b2898cd6f20da2d4589fd662fac2e2057f29b01330f65c030434,2046 pantry-tree: @@ -81,6 +74,69 @@ packages: size: 741 original: hackage: hspec-expectations-0.8.4@sha256:4237f094a7931202ff57ac6475542b0b314b50a7024550e2b6eb87cfb0d4ff93,1702 +- completed: + hackage: dunai-0.12.2@sha256:e769c1b89b5571138c20c387c304758f87f2b9c599fcfe6fc5a81cd7c4ec86b7,6982 + pantry-tree: + sha256: 79a567d02d6d018530dcfa5ac9f7d5e9fead24e9038ba63fa1ed902369f7df31 + size: 2232 + original: + hackage: dunai-0.12.2 +- completed: + hackage: criterion-1.6.3.0@sha256:cf27e6c83f91674fb67ef253cae644ad0ce079b7e2cfa6402e13e930f78499ec,5373 + pantry-tree: + sha256: 2102113a4ac228305ea9396967878c6921377bafc92425c1b8cf82f8afbef40e + size: 2323 + original: + hackage: criterion-1.6.3.0@sha256:cf27e6c83f91674fb67ef253cae644ad0ce079b7e2cfa6402e13e930f78499ec,5373 +- completed: + hackage: criterion-measurement-0.2.1.0@sha256:646d5b5c55499580747746396b731ef9d6e2cd59fa7b488354788e68eae8e9bc,2098 + pantry-tree: + sha256: 2557db6ed7b4e5718d9ca6271caf4bcfc97b966ed32b051f346c8d17e1c31809 + size: 726 + original: + hackage: criterion-measurement-0.2.1.0@sha256:646d5b5c55499580747746396b731ef9d6e2cd59fa7b488354788e68eae8e9bc,2098 +- completed: + hackage: optparse-applicative-0.18.1.0@sha256:b4cf8d9018e5e67cb1f14edb5130b6d05ad8bc1b5f6bd4efaa6ec0b7f28f559d,5132 + pantry-tree: + sha256: 32f52adc150eb146bf4d167ff0cb21fc1e3cd7ecc1b9e5e83b986a1cd1bc58cd + size: 3124 + original: + hackage: optparse-applicative-0.18.1.0@sha256:b4cf8d9018e5e67cb1f14edb5130b6d05ad8bc1b5f6bd4efaa6ec0b7f28f559d,5132 +- completed: + hackage: selective-0.7.0.1@sha256:542ab572491898552b42d62d43a7e8c70fb93d714c06c06a4de6f331fee87df2,3509 + pantry-tree: + sha256: 0c83390d679a54549b03180465335118331f120511a11e82a1c8e2d9cbd5ed55 + size: 1292 + original: + hackage: selective-0.7.0.1@sha256:542ab572491898552b42d62d43a7e8c70fb93d714c06c06a4de6f331fee87df2,3509 +- completed: + hackage: semialign-1.3@sha256:7be9ef5ca1d6b052991f68c053aab68b9d1ab3b1938c9557ac84c97937815223,2888 + pantry-tree: + sha256: e5daa7e0023dabb1b21a04bf084364b94e45e81b380e950b90f51294a1990b87 + size: 537 + original: + hackage: semialign-1.3@sha256:7be9ef5ca1d6b052991f68c053aab68b9d1ab3b1938c9557ac84c97937815223,2888 +- completed: + hackage: these-1.2@sha256:011e22f6891ca028f87c04ea48796696c92d593313a9c699f7ff4f9ffd7aec6e,2882 + pantry-tree: + sha256: 37483703ce7326c07608b06f2f741fb0f708cb06bd10ec57d87108d068046b05 + size: 351 + original: + hackage: these-1.2@sha256:011e22f6891ca028f87c04ea48796696c92d593313a9c699f7ff4f9ffd7aec6e,2882 +- completed: + hackage: assoc-1.1.1@sha256:ad458c9e06a23dd275f8dbb02d13e250b8e40ac4858bc67e7992628563d14f5d,1381 + pantry-tree: + sha256: 6b353c95614aa239936eb4f6d0a4ac91b0c846c3b5356ff9537613a773648e89 + size: 290 + original: + hackage: assoc-1.1.1@sha256:ad458c9e06a23dd275f8dbb02d13e250b8e40ac4858bc67e7992628563d14f5d,1381 +- completed: + hackage: foldable1-classes-compat-0.1@sha256:f2f1c40f9e3322ce8d4101cb2925b420e19b993ef543a6b106d91accf08be78d,3782 + pantry-tree: + sha256: d022a7175e27fd85dd1053ac6f4bf8818cfe0d8e360908aba7d7a1c3d95b227b + size: 518 + original: + hackage: foldable1-classes-compat-0.1@sha256:f2f1c40f9e3322ce8d4101cb2925b420e19b993ef543a6b106d91accf08be78d,3782 snapshots: - completed: sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2 diff --git a/versions.md b/versions.md new file mode 100644 index 00000000..c22ba532 --- /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).