automaton (empty) → 1.3

raw patch · 25 files changed

+2514/−0 lines, 25 filesdep +MonadRandomdep +QuickCheckdep +automaton

Dependencies added: MonadRandom, QuickCheck, automaton, base, mmorph, mtl, profunctors, selective, semialign, simple-affine-space, tasty, tasty-hunit, tasty-quickcheck, these, transformers

Files

• CHANGELOG.md +5/−0
• LICENSE +20/−0
• README.md +70/−0
• automaton.cabal +108/−0
• src/Data/Automaton.hs +514/−0
• src/Data/Automaton/Final.hs +36/−0
• src/Data/Automaton/Trans/Except.hs +329/−0
• src/Data/Automaton/Trans/Except/Internal.hs +11/−0
• src/Data/Automaton/Trans/Maybe.hs +120/−0
• src/Data/Automaton/Trans/RWS.hs +40/−0
• src/Data/Automaton/Trans/Random.hs +94/−0
• src/Data/Automaton/Trans/Reader.hs +43/−0
• src/Data/Automaton/Trans/State.hs +69/−0
• src/Data/Automaton/Trans/Writer.hs +42/−0
• src/Data/Stream.hs +418/−0
• src/Data/Stream/Except.hs +70/−0
• src/Data/Stream/Final.hs +63/−0
• src/Data/Stream/Final/Except.hs +18/−0
• src/Data/Stream/Internal.hs +23/−0
• src/Data/Stream/Optimized.hs +221/−0
• src/Data/Stream/Result.hs +44/−0
• test/Automaton.hs +93/−0
• test/Automaton/Except.hs +16/−0
• test/Main.hs +16/−0
• test/Stream.hs +31/−0

@@ -0,0 +1,5 @@+# Revision history for automaton++## 0.1.0.0++* Initial version ;)

@@ -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.

@@ -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.

@@ -0,0 +1,108 @@+cabal-version: 3.0+name: automaton+version: 1.3+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++source-repository head+  type: git+  location: https://github.com/turion/rhine.git++source-repository this+  type: git+  location: https://github.com/turion/rhine.git+  tag: v1.3++common opts+  build-depends:+    MonadRandom >=0.5,+    base >=4.14 && <4.20,+    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 && <1.6,+    tasty-hunit ^>=0.10,+    tasty-quickcheck ^>=0.10,++flag dev+  description: Enable warnings as errors. Active on ci.+  default: False+  manual: True

@@ -0,0 +1,514 @@+{-# 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 ())++{- | 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)

@@ -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

@@ -0,0 +1,329 @@+{-# 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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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_ #-}

@@ -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

@@ -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)

@@ -0,0 +1,418 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Stream where++-- base+import Control.Applicative (Alternative (..), Applicative (..), liftA2)+import Control.Monad ((<$!>))+import Data.Bifunctor (bimap)+import Data.Monoid (Ap (..))+import Prelude hiding (Applicative (..))++-- 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', 'Data.Automaton.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

@@ -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 'Data.Automaton.Trans.Except.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 will 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

@@ -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

@@ -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

@@ -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

@@ -0,0 +1,221 @@+{-# 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 (..), Applicative (..), liftA2)+import Data.Monoid (Ap (..))+import Prelude hiding (Applicative (..))++-- 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 #-}

@@ -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))

@@ -0,0 +1,93 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Automaton where++-- base+import Control.Applicative (Alternative (..))+import Control.Arrow+import Control.Monad (guard)+import Data.Functor.Identity (runIdentity)+import Data.List (uncons)+import Data.Maybe (maybeToList)++-- transformers+import Control.Monad.State.Strict (StateT (..))++-- 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

@@ -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]]

@@ -0,0 +1,16 @@+module Main where++-- tasty+import Test.Tasty++-- automaton+import Automaton+import Stream++main =+  defaultMain $+    testGroup+      "Main"+      [ Automaton.tests+      , Stream.tests+      ]

@@ -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]+        ]+    ]