automaton 1.5 → 1.6

raw patch · 17 files changed

+794/−89 lines, 17 filesdep +changesetdep +witherabledep ~basesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: changeset, witherable

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• Setup.hs +0/−2
• automaton.cabal +10/−3
• src/Data/Automaton.hs +153/−20
• src/Data/Automaton/Filter.hs +148/−0
• src/Data/Automaton/Trans/Accum.hs +5/−4
• src/Data/Automaton/Trans/Changeset.hs +64/−0
• src/Data/Stream.hs +140/−18
• src/Data/Stream/Except.hs +34/−10
• src/Data/Stream/Filter.hs +88/−0
• src/Data/Stream/Optimized.hs +8/−5
• src/Data/Stream/Recursive.hs +27/−22
• src/Data/Stream/Result.hs +6/−2
• test/Automaton.hs +10/−2
• test/Automaton/Filter.hs +38/−0
• test/Automaton/Trans/Changeset.hs +24/−0
• test/Stream.hs +30/−1

@@ -1,5 +1,14 @@ # Revision history for automaton +## 1.6++* Fix `lastS`. Thanks to Sebastian Wålinder for reporting.+* Add `FilterAutomaton`+* Extend the automaton library by many useful functions and instances+* Improve runtime performance considerably in many places by inlining+* Add [`ChangesetT`](https://hackage.haskell.org/package/changeset) support+* Add `AccumT` example+ ## 1.5  * Fixed naming Final vs. Recursive vs. Coalgebraic

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: automaton-version: 1.5+version: 1.6 synopsis: Effectful streams and automata in coalgebraic encoding description:   Effectful streams have an internal state and a step function.@@ -24,12 +24,13 @@ source-repository this   type: git   location: https://github.com/turion/rhine.git-  tag: v1.5+  tag: v1.6  common opts   build-depends:     MonadRandom >=0.5,-    base >=4.16 && <4.21,+    base >=4.16 && <4.22,+    changeset ^>=0.1.0.2,     mmorph ^>=1.2,     mtl >=2.2 && <2.4,     profunctors ^>=5.6,@@ -38,6 +39,7 @@     simple-affine-space ^>=0.2,     these >=1.1 && <=1.3,     transformers >=0.5,+    witherable ^>=0.5,    if flag(dev)     ghc-options: -Werror@@ -64,8 +66,10 @@   import: opts   exposed-modules:     Data.Automaton+    Data.Automaton.Filter     Data.Automaton.Recursive     Data.Automaton.Trans.Accum+    Data.Automaton.Trans.Changeset     Data.Automaton.Trans.Except     Data.Automaton.Trans.Maybe     Data.Automaton.Trans.RWS@@ -75,6 +79,7 @@     Data.Automaton.Trans.Writer     Data.Stream     Data.Stream.Except+    Data.Stream.Filter     Data.Stream.Internal     Data.Stream.Optimized     Data.Stream.Recursive@@ -94,7 +99,9 @@   other-modules:     Automaton     Automaton.Except+    Automaton.Filter     Automaton.Trans.Accum+    Automaton.Trans.Changeset     Stream    build-depends:

@@ -3,7 +3,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-} @@ -31,9 +30,8 @@ import Control.Monad.Trans.Reader  -- profunctors-import Data.Profunctor (Choice (..), Profunctor (..), Strong)-import Data.Profunctor.Strong (Strong (..))-import Data.Profunctor.Traversing+import Data.Profunctor (Choice (..), Cochoice (..), Profunctor (..), Strong (..))+import Data.Profunctor.Traversing (Traversing (..))  -- selective import Control.Selective (Selective)@@ -41,11 +39,18 @@ -- simple-affine-space import Data.VectorSpace (VectorSpace (..)) --- align+-- these+import Data.These (these)++-- witherable+import Witherable (Filterable (..), Witherable)++-- semialign import Data.Semialign (Align (..), Semialign (..))  -- automaton-import Data.Stream (StreamT (..), fixStream)+import Data.Stream (StreamT (..))+import Data.Stream qualified as StreamT import Data.Stream.Internal (JointState (..)) import Data.Stream.Optimized (   OptimizedStreamT (..),@@ -80,8 +85,8 @@ sequentially :: Automaton m a c sequentially = automaton1 >>> automaton2 -parallely :: Automaton m (a, b) (b, c)-parallely = automaton1 *** automaton2+inParallel :: Automaton m (a, b) (b, c)+inParallel = 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.@@ -128,6 +133,9 @@   dot (Automaton s) (Automaton v) = coerce $ dot s v   normalize (Automaton v) = coerce v +{- | Run both automata in parallel and use @'Semialign' m@ to decide which automaton produces output.+  If you understand @m@ as an effect that models the passage of time, then 'align' runs both automata concurrently.+-} instance (Semialign m) => Semialign (Automaton m a) where   align automaton1 automaton2 =     Automaton $@@ -257,6 +265,12 @@   right (Automaton (Stateless ma)) = Automaton $! Stateless $! ReaderT $! either (pure . Left) (fmap Right . runReaderT ma)   {-# INLINE right #-} +  f ||| g = f +++ g >>> arr untag+    where+      untag (Left x) = x+      untag (Right y) = y+  {-# INLINE (|||) #-}+ -- | Caution, this can make your program hang. Try to use 'feedback' or 'unfold' where possible, or combine 'loop' with 'delay'. instance (MonadFix m) => ArrowLoop (Automaton m) where   loop (Automaton (Stateless ma)) = Automaton $! Stateless $! ReaderT (\b -> fst <$> mfix ((. snd) $ ($ b) $ curry $ runReaderT ma))@@ -374,14 +388,19 @@  -- * Modifying automata --- | Change the output type and effect of an automaton without changing its state type.+-- | Change the input and output type and effect of an automaton without changing its state type. withAutomaton :: (Functor m1, Functor m2) => (forall s. (a1 -> m1 (Result s b1)) -> (a2 -> m2 (Result s b2))) -> Automaton m1 a1 b1 -> Automaton m2 a2 b2 withAutomaton f = Automaton . StreamOptimized.mapOptimizedStreamT (ReaderT . f . runReaderT) . getAutomaton {-# INLINE withAutomaton #-} -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+-- | Change the output type and effect of an automaton without changing its state type.+withAutomaton_ :: (Functor m1, Functor m2) => (forall s. m1 (Result s b1) -> m2 (Result s b2)) -> Automaton m1 a b1 -> Automaton m2 a b2+withAutomaton_ f = Automaton . StreamOptimized.mapOptimizedStreamT (mapReaderT f) . getAutomaton+{-# INLINE withAutomaton_ #-}++instance (Functor m) => Profunctor (Automaton m) where+  dimap f g Automaton {getAutomaton} = Automaton $ g <$> StreamOptimized.hoist' (withReaderT f) getAutomaton+  lmap f Automaton {getAutomaton} = Automaton $ StreamOptimized.hoist' (withReaderT f) getAutomaton   rmap = fmap  instance (Monad m) => Choice (Automaton m) where@@ -414,6 +433,22 @@   wander f (Automaton (Stateless m)) = Automaton $ Stateless $ ReaderT $ f $ runReaderT m   {-# INLINE wander #-} +instance (Monad m) => Cochoice (Automaton m) where+  unleft = handleAutomaton $ \StreamT {state, step} ->+    let+      go s ea = do+        Result s' ebd <- runReaderT (step s) ea+        case ebd of+          Left b -> pure $ Result s' b+          Right d -> go s $ Right d+     in+      StreamT+        { state+        , step = \s -> ReaderT $ \a -> go s $ Left a+        }++-- ** Traversing automata+ -- | Only step the automaton if the input is 'Just'. mapMaybeS :: (Monad m) => Automaton m a b -> Automaton m (Maybe a) (Maybe b) mapMaybeS = traverse'@@ -434,23 +469,71 @@  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]+parallelyList :: (Applicative m) => Automaton m a b -> Automaton m [a] [b]+parallelyList = parallely++{- | Launch many copies of the automaton in parallel, depending on the input shape.++* This generalises 'parallelyList' from lists to arbitrary 'Witherable's satisfying 'Align'+  such as 'Map's, 'Seq'uences', and other data structures.+* The copies of the automaton are launched on demand as the input shape changes in such a way that there are new positions.+* The automaton copy on a particular position will always receive the input from that position.+* Only those automaton copies on positions with a matching input will be stepped.++For example, if the first input is a map with keys @k1@ and @k2@,+two copies will be started, one for each key.+If the next input map has keys @k1@ and @k3@,+the first automaton at key @k1@ will be stepped,+the copy at @k2@ will not be stepped and keeps its state,+and a new copy will be launched at @k3@.++Caution: Uses memory of the order of the largest input that was ever input during runtime.+-}+parallely :: (Applicative m, Witherable t, Align t) => Automaton m a b -> Automaton m (t a) (t 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' :: (Applicative m, Witherable t, Align t) => StreamT (ReaderT a m) b -> StreamT (ReaderT (t a) m) (t b)+    parallely' StreamT {state, step} =+      StreamT+        { state = nil+        , step = \s -> ReaderT $ \as ->+            let aligned = align s as+                traversed = traverse (these (\s -> pure $ Result s Nothing) (fmap (fmap Just) . runReaderT (step state)) (\s a -> fmap Just <$> runReaderT (step s) a)) aligned+                tupleised = fmap (\(Result s aMaybe) -> (s, aMaybe)) <$> traversed+             in tupleised <&> (\sas -> let output = Witherable.mapMaybe snd sas in Result (fst <$> sas) output)+        } parallely Automaton {getAutomaton = Stateless f} = Automaton $ Stateless $ ReaderT $ traverse $ runReaderT f +-- ** Interaction with 'StreamT'++{- | Create an 'Automaton' from a stream.++It will ignore its input.+-}+fromStream :: (Monad m) => StreamT m a -> Automaton m any a+fromStream = Automaton . Stateful . hoist lift++{- | Create a 'StreamT' from an 'Automaton'.++The resulting stream can read the current input as an effect in 'ReaderT'.+-}+toStreamT :: (Functor m) => Automaton m a b -> StreamT (ReaderT a m) b+toStreamT = StreamOptimized.toStreamT . getAutomaton+ -- | 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 +-- | Like 'handleAutomaton_', but with fewer constraints.+handleAutomatonF_ :: (Functor m) => (forall m. (Functor m) => StreamT m a -> StreamT m b) -> Automaton m i a -> Automaton m i b+handleAutomatonF_ f = Automaton . StreamOptimized.withOptimizedF 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 :: (Functor 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 +-- ** Buffering+ {- | Buffer the output of an automaton. See 'Data.Stream.concatS'.  The input for the automaton is not buffered.@@ -460,6 +543,36 @@ concatS :: (Monad m) => Automaton m a [b] -> Automaton m a b concatS (Automaton automaton) = Automaton $ Data.Stream.Optimized.concatS automaton +-- * Handling effects++{- | Continuously interpret a first order effect.++Several types are relevant here:++* @sig@: An effect signature functor, that encodes one effect.+  For example, @'Either' e@ for raising exceptions of type @e@, or @(w, )@ for a logging effect.+* @eff@: A monad that carries the effect.+  This can be a monad transformer stack including a transformer corresponding to @sig@, such as 'ExceptT' for 'Either'.+  It can also be the @Eff@ monad of an effect library such as @polysemy@, @bluefin@, @effectful@ and so on.+* @m@: The underlying monad in which the interpretation is performed, think "@eff@ without the effects from @sig@".++This function takes two functions, one to create effects in @eff@ from the signature, and the other to fully interpret them in @m@,+storing the complete effect information in @sig@ again.+It then executes the given automaton, extracting the effect by interpretation, and sending it back in.+The execution semantics is that of the monad @eff@, while the pure effect of the whole computation is returned in the output, encoded in @sig@.++For examples, see 'Data.Stream.handleEffect'.+-}+handleEffect ::+  (Monad m, Monad eff, Functor sig) =>+  -- | Send a declarative effect in the signature to the effect carrier monad.+  (forall x. sig x -> eff x) ->+  -- | Interpret the effect in @m@, returning its result in the signature.+  (forall x. eff x -> m (sig x)) ->+  Automaton eff a b ->+  Automaton m a (sig b)+handleEffect send interpret = handleAutomaton $ StreamT.handleEffect (lift . send) (\raction -> ReaderT $ \a -> interpret $ runReaderT raction a)+ -- * Examples  -- | Pass through a value unchanged, and perform a side effect depending on it@@ -480,10 +593,17 @@   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.+{- | Like 'accumulateWith', with 'mappend' as the accumulation function.++The new values are 'mappend'ed from the left.+-} mappendFrom :: (Monoid w, Monad m) => w -> Automaton m w w mappendFrom = accumulateWith mappend +-- | Like 'mappendFrom', but 'mappend'ing new values from the right.+mappendFromR :: (Monoid w, Monad m) => w -> Automaton m w w+mappendFromR = accumulateWith $ flip mappend+ -- | Delay the input by one step. delay ::   (Applicative m) =>@@ -519,11 +639,24 @@ -- | Sum up all inputs so far, initialised at 0. sumN :: (Monad m, Num a) => Automaton m a a sumN = arr Sum >>> mappendS >>> arr getSum+{-# INLINE sumN #-}  -- | Count the natural numbers, beginning at 1. count :: (Num n, Monad m) => Automaton m a n count = feedback 0 $! arr (\(_, n) -> let n' = n + 1 in (n', n'))+{-# INLINE count #-}  -- | Remembers the last 'Just' value, defaulting to the given initialisation value. lastS :: (Monad m) => a -> Automaton m (Maybe a) a-lastS a = arr Last >>> mappendS >>> arr (getLast >>> fromMaybe a)+lastS a = arr Last >>> mappendFromR mempty >>> arr (getLast >>> fromMaybe a)+{-# INLINE lastS #-}++-- | Call the monadic action once on the first tick and provide its result indefinitely.+initialised :: (Monad m) => (a -> m b) -> Automaton m a b+initialised = Automaton . Stateful . StreamT.initialised . ReaderT+{-# INLINE initialised #-}++-- | Like 'initialised', but ignores the input.+initialised_ :: (Monad m) => m b -> Automaton m a b+initialised_ = initialised . const+{-# INLINE initialised_ #-}

@@ -0,0 +1,148 @@+{-# LANGUAGE DerivingVia #-}++{- | Often, we want to work with automata that don't produce exactly one output per input.+In these situations, 'FilterAutomaton' is a good abstraction.++For example, we might want to filter out certain values at some point, and only work with the remaining ones from there on.+So for each input, the automaton will either output a value, or it will not output a value.+A simple ad hoc solution is to create an automaton of type @'Automaton' m a ('Maybe' b)@,+where 'Nothing' encodes the absence of a value.+When composing a longer chain of such filtering automata, it often gets tedious to join all of the 'Maybe' layers.+'FilterAutomaton' abstracts this.++Instead of locking into the concrete 'Maybe' type, a more general API based on well-established type classes such as 'Witherable' was chosen.+As a result, it can be used with a custom type encoding optionality,+and even generalised to situations where you might have several outputs per input, using e.g. the list monad.+-}+module Data.Automaton.Filter where++-- base+import Control.Applicative (Alternative (..))+import Control.Arrow+import Control.Category (Category (..))+import Control.Monad (join)+import Data.Functor ((<&>))+import Data.Functor.Compose (Compose (..))+import Prelude hiding (filter, id, (.))++-- transformers+import Control.Monad.Trans.Reader (ReaderT (..))++-- profunctors+import Data.Profunctor (Choice (..), Profunctor (..), Strong (..))+import Data.Profunctor.Choice (Cochoice (..))+import Data.Profunctor.Traversing (Traversing (..))++-- witherable+import Witherable (Filterable (..))++-- semialign+import Data.Align (Align (..), Semialign)+import Data.Semialign (Semialign (..))++-- automaton+import Data.Automaton+import Data.Stream (hoist')+import Data.Stream.Filter (FilterStream (..), streamFilter)+import Data.Stream.Optimized (OptimizedStreamT (Stateful))++{- | An automaton that filters or traverses its output using a type operator @f@.++When @f@ is 'Maybe', then @'FilterAutomaton' 'Maybe' a b@ can filter in the sense that not every input necessarily leads to an output.++@f@ can also be a type that allows multiple positions, such as lists, or 'NonEmpty'.+In this case, 'FilterAutomaton' branches out and can explore multiple outputs at the same time.+(It keeps a single state, though.)+-}+newtype FilterAutomaton m f a b = FilterAutomaton+  { getFilterAutomaton :: Automaton m a (f b)+  -- ^ Interpret a 'FilterAutomaton'.+  --   For instance if @f = 'Maybe'@, the resulting automaton will output 'Nothing' whenever there is no output of the 'FilterAutomaton'.+  }+  deriving (Functor, Applicative, Alternative) via Compose (Automaton m a) f++-- | Create a 'FilterAutomaton' that ignores its input from a 'FilterStream'.+fromFilterStream :: (Monad m) => FilterStream m f a -> FilterAutomaton m f any a+fromFilterStream = FilterAutomaton . fromStream . getFilterStream++{- | Create a 'FilterStream' from a 'FilterAutomaton'.++The current input can be read as an effect in 'ReaderT'.+-}+toFilterStream :: (Functor m) => FilterAutomaton m f a b -> FilterStream (ReaderT a m) f b+toFilterStream = FilterStream . toStreamT . getFilterAutomaton++-- | Use a filtering function to create a 'FilterAutomaton'.+arrFilter :: (Monad m) => (a -> f b) -> FilterAutomaton m f a b+arrFilter = FilterAutomaton . arr++-- | Filter the input according to a predicate.+filterS :: (Monad m, Filterable f, Applicative f) => (a -> Bool) -> FilterAutomaton m f a a+filterS f = filter f id'++{- | Given an @f@-effect in the step, push it into the output type.++This works by internally tracking the @f@ effects in the state, and at the same time joining them in the output.++For example, if @f@ is lists, and @automaton :: Automaton (Compose m []) a b@ creates a 2-element list at some point,+the internal state of @automatonFilter automaton@ will split into two, and there are two outputs.++Likewise, if @f@ is 'Maybe', and a 'Nothing' occurs at some point, then this automaton is deactivated forever.+-}+automatonFilter :: (Monad f, Traversable f, Monad m) => Automaton (Compose m f) a b -> FilterAutomaton m f a b+automatonFilter = FilterAutomaton . Automaton . Stateful . getFilterStream . streamFilter . hoist' (\ramf -> Compose $ ReaderT $ getCompose . runReaderT ramf) . toStreamT++-- | Like 'Category.id', but only requiring @'Applicative' f@.+id' :: (Monad m, Applicative f) => FilterAutomaton m f a a+id' = arrFilter pure++instance (Monad m, Traversable f, Monad f) => Category (FilterAutomaton m f) where+  id = id'+  FilterAutomaton g . FilterAutomaton f = FilterAutomaton $ traverse' g . f <&> join++instance (Monad m, Traversable f, Monad f) => Arrow (FilterAutomaton m f) where+  arr f = FilterAutomaton $ arr $ f >>> pure+  first (FilterAutomaton automaton) = FilterAutomaton $ first automaton <&> (\(fc, d) -> (,d) <$> fc)++instance (Traversable f, Monad m, Monad f) => ArrowChoice (FilterAutomaton m f) where+  FilterAutomaton automaton1 +++ FilterAutomaton automaton2 = FilterAutomaton $ automaton1 +++ automaton2 <&> either (fmap Left) (fmap Right)++-- | There is no 'Witherable' instance though since it isn't 'Traversable'.+instance (Functor m, Filterable f) => Filterable (FilterAutomaton m f a) where+  mapMaybe f (FilterAutomaton automaton) = FilterAutomaton $ automaton <&> mapMaybe f++-- | Lift a regular 'Automaton' (which doesn't filter) to a 'FilterAutomaton'.+liftFilter :: (Monad m, Applicative f) => Automaton m a b -> FilterAutomaton m f a b+liftFilter = FilterAutomaton . fmap pure++{- | Postcompose with an 'Automaton'.++The postcomposed automaton will be stepped for every output of the filter automaton.+-}+rmapS :: (Traversable f, Monad m) => FilterAutomaton m f a b -> Automaton m b c -> FilterAutomaton m f a c+rmapS (FilterAutomaton fa) a = FilterAutomaton $ fa >>> traverse' a++-- | Precompose with an 'Automaton'.+lmapS :: (Monad m) => Automaton m a b -> FilterAutomaton m f b c -> FilterAutomaton m f a c+lmapS a (FilterAutomaton fa) = FilterAutomaton $ a >>> fa++instance (Functor m, Functor f) => Profunctor (FilterAutomaton m f) where+  dimap f g FilterAutomaton {getFilterAutomaton} = FilterAutomaton $ dimap f (fmap g) getFilterAutomaton++instance (Monad m, Monad f, Traversable f) => Strong (FilterAutomaton m f) where+  first' = first++instance (Monad m, Monad f, Traversable f) => Choice (FilterAutomaton m f) where+  left' = left++-- | When looping, this will break when any of the positions in @f@ breaks.+instance (Monad m, Traversable f) => Cochoice (FilterAutomaton m f) where+  unright = FilterAutomaton . unright . fmap sequence . getFilterAutomaton++-- | Run two automata in parallel and 'align' their outputs.+instance (Applicative m, Semialign f) => Semialign (FilterAutomaton m f a) where+  align fa1 fa2 = FilterAutomaton $ align <$> getFilterAutomaton fa1 <*> getFilterAutomaton fa2++-- | Constantly output the empty shape.+instance (Applicative m, Align f) => Align (FilterAutomaton m f a) where+  nil = FilterAutomaton $ constM $ pure nil

@@ -12,7 +12,8 @@ where  -- base-import Control.Arrow (arr, returnA, (>>>))+import Control.Arrow (returnA)+import Data.Functor ((<&>))  -- transformers import Control.Monad.Trans.Accum@@ -27,7 +28,7 @@  This is the opposite of 'runAccumS'. -}-accumS :: (Functor m, Monad m) => Automaton m (w, a) (w, b) -> Automaton (AccumT w m) a b+accumS :: (Functor m) => Automaton m (w, a) (w, b) -> Automaton (AccumT w m) a b accumS = withAutomaton $ \f a -> AccumT $ \w ->   (\(Result s (w', b)) -> (Result s b, w'))     <$> f (w, a)@@ -36,7 +37,7 @@  This is the opposite of 'accumS'. -}-runAccumS :: (Functor m, Monad m) => Automaton (AccumT w m) a b -> Automaton m (w, a) (w, b)+runAccumS :: (Functor m) => Automaton (AccumT w m) a b -> Automaton m (w, a) (w, b) runAccumS = withAutomaton $ \f (w, a) ->   (\(Result s b, w') -> Result s (w', b))     <$> runAccumT (f a) w@@ -57,4 +58,4 @@  -- | Like 'runAccumS_', but don't output the current accum. runAccumS__ :: (Functor m, Monoid w, Monad m) => Automaton (AccumT w m) a b -> Automaton m a b-runAccumS__ automaton = runAccumS_ automaton >>> arr snd+runAccumS__ automaton = runAccumS_ automaton <&> snd

@@ -0,0 +1,64 @@+{- | Handle a global 'ChangesetT' layer in an 'Automaton'.++A global accumulation state can be hidden by an automaton by making it an internal state.+-}+module Data.Automaton.Trans.Changeset (+  module Control.Monad.Trans.Changeset,+  changesetS,+  getChangesetS,+  runChangesetS,+  runChangesetS_,+)+where++-- base+import Control.Arrow (arr, returnA, (>>>))+import Data.Functor ((<&>))++-- changeset+import Control.Monad.Trans.Changeset+import Data.Monoid.RightAction (RightAction (actRight))++-- automaton+import Data.Automaton (Automaton, feedback, withAutomaton)+import Data.Stream.Result (Result (..))++{- | Convert from explicit states to the 'ChangesetT' monad transformer.++The original automaton is interpreted to take the current accumulated state as input and return the log to be appended as output.++This is the opposite of 'runChangesetS'.+-}+changesetS :: (Functor m) => Automaton m (s, a) (w, b) -> Automaton (ChangesetT s w m) a b+changesetS = withAutomaton $ \f a -> ChangesetT $ \s ->+  f (s, a)+    <&> (\(Result s' (w, b)) -> (w, Result s' b))++{- | Make the accumulation transition in 'ChangesetT' explicit as 'Automaton' inputs and outputs.++This is the opposite of 'changesetS'.+-}+getChangesetS :: (Functor m) => Automaton (ChangesetT s w m) a b -> Automaton m (s, a) (w, b)+getChangesetS = withAutomaton $ \f (s, a) ->+  getChangesetT (f a) s+    <&> (\(w, Result s' b) -> Result s' (w, b))++{- | Convert global accumulation state to internal state of an 'Automaton'.++The current state is output on every step.+-}+runChangesetS ::+  (Monad m, Monoid w, RightAction w s) =>+  -- | Initial state+  s ->+  -- | An automaton with a global accumulation state effect+  Automaton (ChangesetT s w m) a b ->+  Automaton m a (s, b)+runChangesetS s automaton = feedback s $ proc (a, s) -> do+  (w, b) <- getChangesetS automaton -< (s, a)+  let s' = s `actRight` w+  returnA -< ((s', b), s')++-- | Like 'runChangesetS', but don't output the current state.+runChangesetS_ :: (Monoid w, Monad m, RightAction w s) => s -> Automaton (ChangesetT s w m) a b -> Automaton m a b+runChangesetS_ s automaton = runChangesetS s automaton >>> arr snd

@@ -11,12 +11,17 @@ import Control.Applicative (Alternative (..), Applicative (..), liftA2) import Control.Monad ((<$!>)) import Data.Bifunctor (bimap)+import Data.Function ((&))+import Data.Functor ((<&>)) import Data.Monoid (Ap (..))+import Data.Tuple (swap) import Prelude hiding (Applicative (..))  -- transformers import Control.Monad.Trans.Class-import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE, withExceptT)+import Control.Monad.Trans.Except (ExceptT (..), except, runExceptT, throwE, withExceptT)+import Control.Monad.Trans.Maybe (MaybeT (..))+import Control.Monad.Trans.Writer (WriterT (runWriterT), writer)  -- mmorph import Control.Monad.Morph (MFunctor (hoist))@@ -35,6 +40,7 @@  -- automaton import Data.Stream.Internal+import Data.Stream.Recursive (Recursive (..)) import Data.Stream.Result  -- * Creating streams@@ -75,7 +81,8 @@ 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.+data StreamT m a+  = forall s.   StreamT   { state :: s   -- ^ The internal state of the stream@@ -103,6 +110,48 @@ constM ma = StreamT () $ const $ Result () <$> ma {-# INLINE constM #-} +-- | Like 'fmap' or 'rmap', but the postcomposed function may have an effect in @m@.+mmap :: (Monad m) => (a -> m b) -> StreamT m a -> StreamT m b+mmap f StreamT {state, step} =+  StreamT+    { state+    , step = \s -> do+        Result s' a <- step s+        Result s' <$> f a+    }+{-# INLINE mmap #-}++{- | Translate a coalgebraically encoded stream into a recursive one.++This is usually a performance penalty.+-}+toRecursive :: (Functor m) => StreamT m a -> Recursive m a+toRecursive automaton = Recursive $ mapResultState toRecursive <$> stepStream automaton+{-# INLINE toRecursive #-}++{- | Translate a recursive stream into a coalgebraically encoded one.++The internal state is the stream itself.+-}+fromRecursive :: Recursive m a -> StreamT m a+fromRecursive coalgebraic =+  StreamT+    { state = coalgebraic+    , step = getRecursive+    }+{-# INLINE fromRecursive #-}++-- | Call the monadic action once on the first tick and provide its result indefinitely.+initialised :: (Monad m) => m a -> StreamT m a+initialised action =+  let step mr@(Just r) = pure $! Result mr r+      step Nothing = (step . Just =<< action)+   in StreamT+        { state = Nothing+        , step+        }+{-# INLINE initialised #-}+ instance (Functor m) => Functor (StreamT m) where   fmap f StreamT {state, step} = StreamT state $! fmap (fmap f) <$> step   {-# INLINE fmap #-}@@ -116,6 +165,14 @@     StreamT (JointState stateF0 stateA0) (\(JointState stateF stateA) -> apResult <$> stepF stateF <*> stepA stateA)   {-# INLINE (<*>) #-} +instance (Foldable m) => Foldable (StreamT m) where+  foldMap f StreamT {state, step} = go state+    where+      go s = step s & foldMap (\(Result s' a) -> f a <> go s')++instance (Traversable m, Functor m) => Traversable (StreamT m) where+  traverse f = fmap fromRecursive . traverse f . toRecursive+ 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@@ -242,16 +299,29 @@     go (s, []) = do       Result s' as <- step s       go (s', as)-    go (s, a : as) = return $ Result (s, as) a+    go (s, a : as) = pure $ Result (s, as) a {-# INLINE concatS #-} +{- | At each step, duplicate the @m@ effect of the current step to the output.++This is useful if @m@ has some means of static analysis, or if you want to re-perform the effects.+-}+snapshot :: (Functor m) => StreamT m a -> StreamT m (m a)+snapshot StreamT {state, step} =+  StreamT+    { state+    , step = \s ->+        let result = step s+         in flip Result (output <$> result) . resultState <$> result+    }+ -- ** 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.+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) =@@ -263,7 +333,7 @@     step (Left s1) = do       resultOrException <- lift $ runExceptT $ step1 s1       case resultOrException of-        Right result -> return $! mapResultState Left result+        Right result -> pure $! mapResultState Left result         Left f -> step (Right (state2, f))     step (Right (s2, f)) = mapResultState (Right . (,f)) <$!> withExceptT f (step2 s2) {-# INLINE applyExcept #-}@@ -284,7 +354,7 @@       resultOrException <- runExceptT $ step s       case resultOrException of         Left _ -> stepNew state-        Right result -> return result+        Right result -> pure result  -- | 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)@@ -309,7 +379,7 @@     step (Left stateE) = do       resultOrException <- lift $ runExceptT $ stepE stateE       case resultOrException of-        Right result -> return $ mapResultState Left result+        Right result -> pure $ 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@@ -326,20 +396,20 @@       eitherResult :: Result s (Either a b) -> Either (Result s a) (Result s b)       eitherResult (Result s eab) = bimap (Result s) (Result s) eab +{- | Run both streams in parallel and use @'Semialign' m@ to decide which stream produces output.+  If you understand @m@ as an effect that models the passage of time, then 'align' runs both streams concurrently.+-} 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)+      { state = JointState s10 s20+      , step = \(JointState s1 s2) -> align (step1 s1) (step2 s2) <&> updateTheseState s1 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)+      updateTheseState :: s1 -> s2 -> These (Result s1 a) (Result s2 b) -> Result (JointState s1 s2) (These a b)+      updateTheseState _s1 s2 (This (Result s1 a)) = Result (JointState s1 s2) $ This a+      updateTheseState s1 _s2 (That (Result s2 b)) = Result (JointState s1 s2) $ That b+      updateTheseState _ _ (These (Result s1 a) (Result s2 b)) = Result (JointState s1 s2) $ These a b   {-# INLINE align #-}  instance (Align m) => Align (StreamT m) where@@ -426,7 +496,7 @@   where     step fix@(Fix {getFix}) = mapResultState Fix <$> transformStep fix step getFix -{- | The solution to the equation @'fixA stream = stream <*> 'fixA' stream@.+{- | 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 coalgebraic encoding of the state.@@ -434,3 +504,55 @@ 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++-- * Effect handling++-- | Lift the monad of a stream into a transformer.+liftS :: (Monad m, MonadTrans t) => StreamT m a -> StreamT (t m) a+liftS = hoist lift++{- | Continuously interpret a first order effect.++Several types are relevant here:++* @sig@: An effect signature functor, that encodes one effect.+  For example, @'Either' e@ for raising exceptions of type @e@, or @(w, )@ for a logging effect.+* @eff@: A monad that carries the effect.+  This can be a monad transformer stack including a transformer corresponding to @sig@, such as 'ExceptT' for 'Either'.+  It can also be the @Eff@ monad of an effect library such as @polysemy@, @bluefin@, @effectful@ and so on.+* @m@: The underlying monad in which the interpretation is performed, think "@eff@ without the effects from @sig@".++This function takes two functions, one to create effects in @eff@ from the signature, and the other to fully interpret them in @m@,+storing the complete effect information in @sig@ again.+It then executes the given automaton, extracting the effect by interpretation, and sending it back in.+The execution semantics is that of the monad @eff@, while the pure effect of the whole computation is returned in the output, encoded in @sig@.++For examples, see 'handleExceptT', 'handleWriterT' and similar functions below.+-}+handleEffect ::+  (Monad m, Monad eff, Functor sig) =>+  -- | Send a declarative effect in the signature to the effect carrier monad.+  (forall x. sig x -> eff x) ->+  -- | Interpret the effect in @m@, returning its result in the signature.+  (forall x. eff x -> m (sig x)) ->+  StreamT eff a ->+  StreamT m (sig a)+handleEffect send interpret StreamT {state, step} =+  StreamT+    { state = pure state+    , step = \s -> do+        results <- interpret $ step =<< s+        pure $! mapResultState send $ unzipResult results+    }++-- | Execute a stream until it throws an exception, then output the exception forever.+handleExceptT :: (Monad m) => StreamT (ExceptT e m) a -> StreamT m (Either e a)+handleExceptT = handleEffect except runExceptT++-- | Return the accumulated log at every step alongside the value.+handleWriterT :: (Monad m, Monoid w) => StreamT (WriterT w m) a -> StreamT m (w, a)+handleWriterT = handleEffect (writer . swap) (fmap swap . runWriterT)++-- | Execute a stream until it stops, then output 'Nothing' forever.+handleMaybeT :: (Monad m) => StreamT (MaybeT m) a -> StreamT m (Maybe a)+handleMaybeT = handleEffect (MaybeT . pure) runMaybeT

@@ -1,7 +1,11 @@ module Data.Stream.Except where  -- base+import Control.Category ((>>>)) import Control.Monad (ap)+import Data.Bifunctor (bimap)+import Data.Function ((&))+import Data.Functor ((<&>)) import Data.Void  -- transformers@@ -16,10 +20,12 @@  -- automaton import Data.Stream (foreverExcept)-import Data.Stream.Optimized (OptimizedStreamT, applyExcept, constM, selectExcept)+import Data.Stream.Optimized as OptimizedStreamT (OptimizedStreamT, applyExcept, constM, hoist', selectExcept) import Data.Stream.Optimized qualified as StreamOptimized import Data.Stream.Recursive (Recursive (..))+import Data.Stream.Recursive as Recursive (hoist') import Data.Stream.Recursive.Except+import Data.Stream.Result  {- | A stream that can terminate with an exception. @@ -36,21 +42,40 @@  -- | Apply a function to the output of the stream mapOutput :: (Functor m) => (a -> b) -> StreamExcept a m e -> StreamExcept b m e-mapOutput f (RecursiveExcept final) = RecursiveExcept $ f <$> final-mapOutput f (CoalgebraicExcept initial) = CoalgebraicExcept $ f <$> initial+mapOutput f (RecursiveExcept recursive) = RecursiveExcept $ f <$> recursive+mapOutput f (CoalgebraicExcept coalgebraic) = CoalgebraicExcept $ f <$> coalgebraic  toRecursive :: (Functor m) => StreamExcept a m e -> Recursive (ExceptT e m) a-toRecursive (RecursiveExcept coalgebraic) = coalgebraic+toRecursive (RecursiveExcept recursive) = recursive toRecursive (CoalgebraicExcept coalgebraic) = StreamOptimized.toRecursive coalgebraic  runStreamExcept :: StreamExcept a m e -> OptimizedStreamT (ExceptT e m) a-runStreamExcept (RecursiveExcept coalgebraic) = StreamOptimized.fromRecursive coalgebraic+runStreamExcept (RecursiveExcept recursive) = StreamOptimized.fromRecursive recursive runStreamExcept (CoalgebraicExcept coalgebraic) = coalgebraic -instance (Monad m) => Functor (StreamExcept a m) where-  fmap f (RecursiveExcept fe) = RecursiveExcept $ hoist (withExceptT f) fe-  fmap f (CoalgebraicExcept ae) = CoalgebraicExcept $ hoist (withExceptT f) ae+stepInstant :: (Functor m) => StreamExcept a m e -> m (Either e (Result (StreamExcept a m e) a))+stepInstant = runStreamExcept >>> StreamOptimized.stepOptimizedStream >>> runExceptT >>> fmap (fmap (mapResultState CoalgebraicExcept)) +-- | Run all steps of the stream, discarding all output, until the exception is reached.+instance (Functor m, Foldable m) => Foldable (StreamExcept a m) where+  foldMap f = stepInstant >>> foldMap (either f $ resultState >>> foldMap f)++instance (Traversable m) => Traversable (StreamExcept a m) where+  traverse f streamExcept = traverseRecursive (toRecursive streamExcept) & fmap (Recursive >>> RecursiveExcept)+    where+      traverseRecursive =+        getRecursive+          >>> runExceptT+          >>> fmap (bimap f (mapResultState traverseRecursive >>> (\Result {resultState, output} -> (Result <$> resultState) <&> ($ output))) >>> bitraverseEither)+          >>> sequenceA+          >>> fmap (ExceptT >>> fmap (mapResultState Recursive))+      bitraverseEither :: (Functor f) => Either (f a) (f b) -> f (Either a b)+      bitraverseEither = either (fmap Left) (fmap Right)++instance (Functor m) => Functor (StreamExcept a m) where+  fmap f (RecursiveExcept fe) = RecursiveExcept $ Recursive.hoist' (withExceptT f) fe+  fmap f (CoalgebraicExcept ae) = CoalgebraicExcept $ OptimizedStreamT.hoist' (withExceptT f) ae+ instance (Monad m) => Applicative (StreamExcept a m) where   pure = CoalgebraicExcept . constM . throwE   CoalgebraicExcept f <*> CoalgebraicExcept a = CoalgebraicExcept $ applyExcept f a@@ -74,7 +99,6 @@  safely :: (Monad m) => StreamExcept a m Void -> OptimizedStreamT m a safely = hoist (fmap (either absurd id) . runExceptT) . runStreamExcept- safe :: (Monad m) => OptimizedStreamT m a -> StreamExcept a m void safe = CoalgebraicExcept . hoist lift @@ -85,4 +109,4 @@ forever (CoalgebraicExcept (StreamOptimized.Stateful stream)) = StreamOptimized.Stateful $ foreverExcept stream forever (CoalgebraicExcept (StreamOptimized.Stateless f)) = StreamOptimized.Stateless go   where-    go = runExceptT f >>= either (const go) return+    go = runExceptT f >>= either (const go) pure

@@ -0,0 +1,88 @@+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingVia #-}++module Data.Stream.Filter where++-- base+import Control.Applicative (Alternative (..))+import Control.Category (Category (..))+import Control.Monad (forM, join)+import Data.Functor ((<&>))+import Data.Functor.Compose (Compose (..))+import Prelude hiding (filter, id, (.))++-- witherable+import Witherable (Filterable (..), Witherable (..))++-- semialign+import Data.Align (Align (..), Semialign (..))++-- automaton+import Data.Stream (StreamT (..), constM)+import Data.Stream.Result (unzipResult)++{- | A stream that filters or traverses its output using a type operator @f@.++When @f@ is 'Maybe', then @'FilterStream' 'Maybe' a@ can filter in the sense that on a given step there might not be an output.++@f@ can also be a type that allows multiple positions, such as lists, or 'NonEmpty'.+In this case, 'FilterStream' branches out and can explore multiple outputs at the same time.+(It keeps a single state, though.)+-}+newtype FilterStream m f a = FilterStream+  { getFilterStream :: StreamT m (f a)+  -- ^ Interpret a 'FilterStream'.+  --   For instance if @f = 'Maybe'@, the resulting stream will output 'Nothing' whenever there is no output of the 'FilterStream'.+  }+  deriving (Functor, Foldable, Traversable)+  deriving (Applicative) via Compose (StreamT m) f+  deriving (Alternative) via Compose (StreamT m) f++-- | Use a filtered value to create a 'FilterStream'.+constFilter :: (Applicative m) => f a -> FilterStream m f a+constFilter = FilterStream . pure++-- | Use an effectful filtered value to create a 'FilterStream'.+filterM :: (Functor m) => m (f a) -> FilterStream m f a+filterM = FilterStream . constM++-- | Filter a stream according to a predicate.+filterS :: (Monad m, Witherable f, Applicative f) => (a -> Bool) -> FilterStream m f a -> FilterStream m f a+filterS f = FilterStream . fmap (filter f) . getFilterStream++{- | Given an @f@-effect in the step function of a stream, push it into the output type.++This works by internally tracking the @f@ effects in the state, and at the same time joining them in the output.++For example, if @f@ is lists, and @stream :: StreamT (Compose m []) a@ creates a 2-element list at some point,+the internal state of @streamFilter stream@ will split into two, and there are two outputs.++Likewise, if @f@ is 'Maybe', and a 'Nothing' occurs at some point, then this automaton is deactivated forever.+-}+streamFilter :: (Monad f, Traversable f, Monad m) => StreamT (Compose m f) a -> FilterStream m f a+streamFilter StreamT {state, step} =+  FilterStream $+    StreamT+      { state = pure state+      , step = \states -> unzipResult . join <$> forM states (getCompose . step)+      }++-- | Given a branching stream, concatenate all branches at every step.+runListS :: (Monad m) => StreamT (Compose m []) a -> StreamT m [a]+runListS = getFilterStream . streamFilter++-- | Lift a regular 'StreamT' (which doesn't filter) to a 'FilterStream'.+liftFilter :: (Monad m, Applicative f) => StreamT m a -> FilterStream m f a+liftFilter = FilterStream . fmap pure++instance (Functor m, Filterable f) => Filterable (FilterStream m f) where+  mapMaybe f (FilterStream automaton) = FilterStream $ automaton <&> mapMaybe f++instance (Functor m, Traversable m, Filterable f, Traversable f) => Witherable (FilterStream m f)++-- | Run two streams in parallel and 'align' their outputs.+instance (Semialign f, Applicative m) => Semialign (FilterStream m f) where+  align a b = FilterStream $ align <$> getFilterStream a <*> getFilterStream b++instance (Align f, Applicative m) => Align (FilterStream m f) where+  nil = constFilter nil

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-}@@ -35,7 +35,6 @@ import Data.Stream hiding (hoist') import Data.Stream qualified as StreamT import Data.Stream.Recursive (Recursive (..))-import Data.Stream.Recursive qualified as Recursive (fromRecursive, toRecursive) import Data.Stream.Result  {- | An optimized version of 'StreamT' which has an extra constructor for stateless streams.@@ -51,7 +50,7 @@     Stateful (StreamT m a)   | -- | A stateless stream is simply an action in a monad which is performed repetitively.     Stateless (m a)-  deriving (Functor)+  deriving (Functor, Foldable, Traversable)  {- | Remove the optimization layer. @@ -150,6 +149,10 @@ 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 +-- | Like 'withOptimized', but with fewer constraints.+withOptimizedF :: (Functor n) => (forall m. (Functor m) => StreamT m a -> StreamT m b) -> OptimizedStreamT n a -> OptimizedStreamT n b+withOptimizedF 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.@@ -188,7 +191,7 @@ This will typically be a performance penalty. -} toRecursive :: (Functor m) => OptimizedStreamT m a -> Recursive m a-toRecursive (Stateful stream) = Recursive.toRecursive stream+toRecursive (Stateful stream) = StreamT.toRecursive stream toRecursive (Stateless f) = go   where     go = Recursive $ Result go <$> f@@ -198,7 +201,7 @@   The internal state is the stream itself. -} fromRecursive :: Recursive m a -> OptimizedStreamT m a-fromRecursive = Stateful . Recursive.fromRecursive+fromRecursive = Stateful . StreamT.fromRecursive {-# INLINE fromRecursive #-}  -- | See 'Data.Stream.concatS'.

@@ -1,13 +1,16 @@+{-# LANGUAGE RankNTypes #-}+ module Data.Stream.Recursive where  -- base import Control.Applicative (Alternative (..))+import Data.Function ((&))+import Data.Functor ((<&>))  -- mmorph import Control.Monad.Morph (MFunctor (..))  -- automaton-import Data.Stream (StreamT (..), stepStream) import Data.Stream.Result  {- | A stream transformer in recursive encoding.@@ -16,30 +19,17 @@ -} newtype Recursive m a = Recursive {getRecursive :: m (Result (Recursive m a) a)} -{- | Translate a coalgebraically encoded stream into a recursive one.--This is usually a performance penalty.--}-toRecursive :: (Functor m) => StreamT m a -> Recursive m a-toRecursive automaton = Recursive $ mapResultState toRecursive <$> stepStream automaton-{-# INLINE toRecursive #-}+instance MFunctor Recursive where+  hoist = hoist' -{- | Translate a recursive stream into a coalgebraically encoded one.+{- | Hoist a stream along a monad morphism, by applying said morphism to the step function. -The internal state is the stream itself.+This is like @mmorph@'s 'hoist', but it doesn't require a 'Monad' constraint on @m2@. -}-fromRecursive :: Recursive m a -> StreamT m a-fromRecursive coalgebraic =-  StreamT-    { state = coalgebraic-    , step = getRecursive-    }-{-# INLINE fromRecursive #-}--instance MFunctor Recursive where-  hoist morph = go-    where-      go Recursive {getRecursive} = Recursive $ morph $ mapResultState go <$> getRecursive+hoist' :: (Functor f) => (forall x. f x -> g x) -> Recursive f a -> Recursive g a+hoist' morph = go+  where+    go Recursive {getRecursive} = Recursive $ morph $ mapResultState go <$> getRecursive  instance (Functor m) => Functor (Recursive m) where   fmap f Recursive {getRecursive} = Recursive $ fmap f . mapResultState (fmap f) <$> getRecursive@@ -61,3 +51,18 @@   empty = constM empty    Recursive ma1 <|> Recursive ma2 = Recursive $ ma1 <|> ma2++instance (Foldable m) => Foldable (Recursive m) where+  foldMap f Recursive {getRecursive} = foldMap (\(Result recursive a) -> f a <> foldMap f recursive) getRecursive++instance (Traversable m) => Traversable (Recursive m) where+  traverse f = go+    where+      go Recursive {getRecursive} = (getRecursive & traverse (\(Result cont a) -> flip Result <$> f a <*> go cont)) <&> Recursive++-- | Like 'fmap' or 'rmap', but the postcomposed function may have an effect in @m@.+mmap :: (Monad m) => (a -> m b) -> Recursive m a -> Recursive m b+mmap f Recursive {getRecursive} = Recursive $ do+  Result recursive a <- getRecursive+  b <- f a+  pure $ Result (mmap f recursive) b

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE StrictData #-}  module Data.Stream.Result where@@ -15,7 +15,7 @@ The new state should always be strict to avoid space leaks. -} data Result s a = Result {resultState :: s, output :: ~a}-  deriving (Functor)+  deriving (Functor, Foldable, Traversable)  instance Bifunctor Result where   second = fmap@@ -42,3 +42,7 @@     Result s' f <- mf s     Result s'' a <- ma s'     pure (Result s'' (f a))++-- | Like 'unzip'.+unzipResult :: (Functor f) => f (Result s a) -> Result (f s) (f a)+unzipResult results = Result (resultState <$> results) (output <$> results)

@@ -28,7 +28,9 @@  -- automaton import Automaton.Except+import Automaton.Filter import Automaton.Trans.Accum+import Automaton.Trans.Changeset import Data.Automaton import Data.Automaton.Recursive import Data.Automaton.Trans.Maybe@@ -69,9 +71,15 @@     , 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]+    , testGroup+        "lastS"+        [ testCase "Remembers a Just value" $ runIdentity (embed (lastS 0) [Nothing, Just 10]) @?= [0, 10]+        , testCase "Remembers the last of several Just values" $ runIdentity (embed (lastS 0) [Nothing, Nothing, Just 1, Nothing, Just 2, Just 10]) @?= [0, 0, 1, 1, 2, 10]+        ]     , Automaton.Except.tests+    , Automaton.Filter.tests     , Automaton.Trans.Accum.tests+    , Automaton.Trans.Changeset.tests     ]  inMaybe :: Automaton Maybe (Maybe a) a@@ -92,4 +100,4 @@ char c = do   c' <- aChar   guard $ c == c'-  return c+  pure c

@@ -0,0 +1,38 @@+module Automaton.Filter where++-- base+import Control.Arrow+import Data.Functor.Identity (runIdentity)++-- tasty+import Test.Tasty++-- tasty-hunit+import Test.Tasty.HUnit++-- rhine++import Data.Automaton (embed)+import Data.Automaton.Filter++tests :: TestTree+tests =+  testGroup+    "Filter"+    [ testCase "Fizz Buzz" $ do+        let automaton3 = getFilterAutomaton $ filterS (\i -> i `mod` 3 == 0)+            automaton5 = getFilterAutomaton $ filterS (\i -> i `mod` 5 == 0)+            result = runIdentity $ embed (automaton3 &&& automaton5) [1 .. 10]+        result+          @?= [ (Nothing, Nothing)+              , (Nothing, Nothing)+              , (Just 3, Nothing)+              , (Nothing, Nothing)+              , (Nothing, Just 5)+              , (Just 6, Nothing)+              , (Nothing, Nothing)+              , (Nothing, Nothing)+              , (Just 9, Nothing)+              , (Nothing, Just 10)+              ]+    ]

@@ -0,0 +1,24 @@+module Automaton.Trans.Changeset where++-- base+import Control.Monad.Identity (Identity (runIdentity))+import Data.Monoid (Sum (..))++-- transformers+import Control.Monad.Changeset.Class (change, current)++-- tasty+import Test.Tasty (testGroup)++-- tasty-hunit+import Test.Tasty.HUnit (testCase, (@?=))++-- automaton+import Data.Automaton+import Data.Automaton.Trans.Changeset (runChangesetS)+import Data.Monoid.RightAction (RightAction (actRight))++tests = testGroup "Trans.Changeset" [testCase "runChangesetS" $ runIdentity (embed (runChangesetS (Sum (0 :: Int)) (constM (change (Sum (1 :: Int)) >> current))) (replicate 5 ())) @?= (\n -> (n, n)) <$> [1, 2, 3, 4, 5]]++instance (Num a) => RightAction (Sum a) (Sum a) where+  a1 `actRight` a2 = a1 <> a2

@@ -1,8 +1,13 @@ module Stream where  -- base+import Control.Monad (when) import Control.Monad.Identity (Identity (..)) +-- transformers+import Control.Monad.Trans.Except (throwE)+import Control.Monad.Trans.Writer.Lazy (runWriter, tell)+ -- selective import Control.Selective @@ -14,7 +19,7 @@  -- automaton import Automaton-import Data.Stream (streamToList, unfold)+import Data.Stream (StreamT, constM, handleExceptT, handleWriterT, mmap, snapshot, streamToList, unfold, unfold_) import Data.Stream.Result  tests =@@ -32,4 +37,28 @@                 automaton2 = unfold 1 (\n -> Result (n + 2) (* n))              in take 10 (runIdentity (streamToList (automaton1 <*? automaton2))) @?= [0, 1, 2, 9, 4, 25, 6, 49, 8, 81]         ]+    , testGroup+        "snapshot"+        [ testCase "Shows the current effect in the output" $+            let stream = snapshot $ constM $ tell [()]+             in take 3 (fmap runWriter $ fst $ runWriter $ streamToList stream) @?= [((), [()]), ((), [()]), ((), [()])]+        ]+    , testGroup+        "handleEffect"+        [ testGroup+            "handleExceptT"+            [ testCase "Switches to constantly Left after exception has been triggered" $+                let stream = mmap (\i -> when (i > 2) (throwE ())) nats+                 in take 5 (runIdentity $ streamToList $ handleExceptT stream) @?= [Right (), Right (), Left (), Left (), Left ()]+            ]+        , testGroup+            "handleWriterT"+            [ testCase "Returns the current log on the output" $+                let stream = mmap (tell . pure) nats+                 in take 3 (fmap fst $ runIdentity $ streamToList $ handleWriterT stream) @?= [[1], [1, 2], [1, 2, 3]]+            ]+        ]     ]++nats :: (Applicative m) => StreamT m Int+nats = unfold_ 0 (+ 1)