automaton 1.6.1 → 1.7
raw patch · 10 files changed
+201/−26 lines, 10 filesdep ~changesetPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: changeset
API changes (from Hackage documentation)
+ Data.Automaton: initial :: forall (m :: Type -> Type) a. Applicative m => Automaton m a a
+ Data.Automaton.Trans.Except: foreverE :: forall (m :: Type -> Type) e a b. Monad m => e -> AutomatonExcept a b (ReaderT e m) e -> Automaton m a b
+ Data.Stream: foreverExceptE :: forall (m :: Type -> Type) e a. (Functor m, Monad m) => e -> StreamT (ExceptT e (ReaderT e m)) a -> StreamT m a
+ Data.Stream.Except: foreverE :: forall (m :: Type -> Type) e a. Monad m => e -> StreamExcept a (ReaderT e m) e -> OptimizedStreamT m a
Files
- CHANGELOG.md +6/−0
- automaton.cabal +14/−2
- src/Data/Automaton.hs +9/−2
- src/Data/Automaton/Filter.hs +3/−2
- src/Data/Automaton/Trans/Except.hs +48/−0
- src/Data/Stream.hs +27/−9
- src/Data/Stream/Except.hs +43/−4
- src/Data/Stream/Filter.hs +3/−2
- test/Automaton.hs +4/−0
- test/Stream.hs +44/−5
CHANGELOG.md view
@@ -1,5 +1,11 @@ # Revision history for automaton +## 1.7++* Add `safely`, `forever` and `foreverE` exception handling functions for streams+* Use `TimeDomain Seconds` extensively+* Add `|-|` and `||-||` resampling buffer utilities+ ## 1.6 * Fix `lastS`. Thanks to Sebastian Wålinder for reporting.
automaton.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: automaton-version: 1.6.1+version: 1.7 synopsis: Effectful streams and automata in coalgebraic encoding description: Effectful streams have an internal state and a step function.@@ -30,7 +30,7 @@ build-depends: MonadRandom >=0.5, base >=4.16 && <4.22,- changeset ^>=0.1.1,+ changeset ^>=0.2, mmorph ^>=1.2, mtl >=2.2 && <2.4, profunctors ^>=5.6,@@ -47,14 +47,26 @@ -W default-extensions:+ ApplicativeDo Arrows DataKinds+ DerivingStrategies+ DerivingVia+ ExistentialQuantification FlexibleContexts FlexibleInstances+ GADTs+ GeneralizedNewtypeDeriving ImportQualifiedPost+ InstanceSigs+ LambdaCase MultiParamTypeClasses NamedFieldPuns NoStarIsType+ NumericUnderscores+ RankNTypes+ ScopedTypeVariables+ StandaloneDeriving TupleSections TypeApplications TypeFamilies
src/Data/Automaton.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-} module Data.Automaton where@@ -78,6 +77,7 @@ 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@@ -88,6 +88,7 @@ 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. @@ -475,7 +476,7 @@ {- | 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.+ 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.@@ -650,6 +651,12 @@ lastS :: (Monad m) => a -> Automaton m (Maybe a) a lastS a = arr Last >>> mappendFromR mempty >>> arr (getLast >>> fromMaybe a) {-# INLINE lastS #-}++-- | Indefinitely outputs the first input value+initial :: (Applicative m) => Automaton m a a+initial = unfold Nothing $ \aInput -> \case+ Nothing -> Result (Just aInput) aInput+ s@(Just a) -> Result s a -- | Call the monadic action once on the first tick and provide its result indefinitely. initialised :: (Monad m) => (a -> m b) -> Automaton m a b
src/Data/Automaton/Filter.hs view
@@ -56,8 +56,9 @@ -} 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'.+ {- ^ 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
src/Data/Automaton/Trans/Except.hs view
@@ -59,6 +59,7 @@ if cond a then throwS -< e else returnA -< a+{-# INLINEABLE throwOnCond #-} {- | Throws the exception when the input is 'True'. @@ -70,10 +71,12 @@ if b then throwS -< e else returnA -< a+{-# INLINEABLE throwOnCondM #-} -- | Throw the exception when the input is 'True'. throwOn :: (Monad m) => e -> Automaton (ExceptT e m) Bool () throwOn e = proc b -> throwOn' -< (b, e)+{-# INLINEABLE throwOn #-} -- | Variant of 'throwOn', where the exception may change every tick. throwOn' :: (Monad m) => Automaton (ExceptT e m) (Bool, e) ()@@ -81,12 +84,14 @@ if b then throwS -< e else returnA -< ()+{-# INLINEABLE throwOn' #-} -- | When the predicate evaluates to @Just e@, throw the exception @e@, otherwise forward the input. throwOnMaybe :: (Monad m) => (a -> Maybe e) -> Automaton (ExceptT e m) a a throwOnMaybe f = proc a -> do throwMaybe -< f a returnA -< a+{-# INLINEABLE throwOnMaybe #-} {- | When the input is @Just e@, throw the exception @e@. @@ -94,6 +99,7 @@ -} throwMaybe :: (Monad m) => Automaton (ExceptT e m) (Maybe e) (Maybe void) throwMaybe = mapMaybeS throwS+{-# INLINEABLE throwMaybe #-} {- | Immediately throw the incoming exception. @@ -102,14 +108,17 @@ -} throwS :: (Monad m) => Automaton (ExceptT e m) e a throwS = arrM throwE+{-# INLINEABLE throwS #-} -- | Immediately throw the given exception. throw :: (Monad m) => e -> Automaton (ExceptT e m) a b throw = constM . throwE+{-# INLINEABLE throw #-} -- | Do not throw an exception. pass :: (Monad m) => Automaton (ExceptT e m) a a pass = Category.id+{-# INLINEABLE pass #-} {- | Converts an 'Automaton' in 'MaybeT' to an 'Automaton' in 'ExceptT'. @@ -120,6 +129,7 @@ Automaton (MaybeT m) a b -> Automaton (ExceptT () m) a b maybeToExceptS = hoistS (ExceptT . (maybe (Left ()) Right <$>) . runMaybeT)+{-# INLINEABLE maybeToExceptS #-} -- * Catching exceptions @@ -134,6 +144,7 @@ catchS automaton f = safely $ do e <- try automaton safe $ f e+{-# INLINEABLE catchS #-} -- | Similar to Yampa's delayed switching. Loses a @b@ in case of an exception. untilE ::@@ -145,6 +156,7 @@ b <- liftS automaton -< a me <- liftS automatone -< b inExceptT -< ExceptT $ return $ maybe (Right b) Left me+{-# INLINEABLE untilE #-} {- | Escape an 'ExceptT' layer by outputting the exception whenever it occurs. @@ -152,6 +164,7 @@ -} exceptS :: (Functor m, Monad m) => Automaton (ExceptT e m) a b -> Automaton m a (Either e b) exceptS = Automaton . StreamOptimized.exceptS . mapOptimizedStreamT commuteReader . getAutomaton+{-# INLINEABLE exceptS #-} {- | Embed an 'ExceptT' value inside the 'Automaton'. @@ -159,12 +172,14 @@ -} inExceptT :: (Monad m) => Automaton (ExceptT e m) (ExceptT e m a) a inExceptT = arrM id+{-# INLINEABLE inExceptT #-} {- | 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)+{-# INLINEABLE tagged #-} -- * Monad interface for Exception Automatons @@ -183,6 +198,7 @@ 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@@ -271,12 +287,15 @@ instance MonadTrans (AutomatonExcept a b) where lift = AutomatonExcept . lift . lift+ {-# INLINEABLE lift #-} instance MFunctor (AutomatonExcept a b) where hoist morph = AutomatonExcept . hoist (mapReaderT morph) . getAutomatonExcept+ {-# INLINEABLE hoist #-} runAutomatonExcept :: (Monad m) => AutomatonExcept a b m e -> Automaton (ExceptT e m) a b runAutomatonExcept = Automaton . hoist commuteReaderBack . runStreamExcept . getAutomatonExcept+{-# INLINE runAutomatonExcept #-} {- | Execute an 'Automaton' in 'ExceptT' until it raises an exception. @@ -284,6 +303,7 @@ -} try :: (Monad m) => Automaton (ExceptT e m) a b -> AutomatonExcept a b m e try = AutomatonExcept . CoalgebraicExcept . hoist commuteReader . getAutomaton+{-# INLINEABLE try #-} {- | Immediately throw the current input as an exception. @@ -292,6 +312,7 @@ -} currentInput :: (Monad m) => AutomatonExcept e b m e currentInput = try throwS+{-# INLINEABLE currentInput #-} {- | If no exception can occur, the 'Automaton' can be executed without the 'ExceptT' layer.@@ -307,6 +328,7 @@ -} safely :: (Monad m) => AutomatonExcept a b m Void -> Automaton m a b safely = Automaton . StreamExcept.safely . getAutomatonExcept+{-# INLINEABLE safely #-} {- | An 'Automaton' without an 'ExceptT' layer never throws an exception, and can thus have an arbitrary exception type.@@ -316,19 +338,37 @@ -} safe :: (Monad m) => Automaton m a b -> AutomatonExcept a b m e safe = try . liftS+{-# INLINEABLE safe #-} +-- | Run the automaton until the exception is thrown, then restart, continuing this cycle forever. forever :: (Monad m) => AutomatonExcept a b m e -> Automaton m a b forever = Automaton . StreamExcept.forever . getAutomatonExcept+{-# INLINEABLE forever #-} +{- | Like 'forever', but keep the last thrown exception.++Before any exception was thrown, an initialisation value is given.+-}+foreverE ::+ (Monad m) =>+ -- | The initial value that is supplied to the 'ReaderT' context before the first exception is thrown+ e ->+ AutomatonExcept a b (ReaderT e m) e ->+ Automaton m a b+foreverE e = Automaton . StreamExcept.foreverE e . hoist (\rae -> ReaderT $ \e -> ReaderT $ \a -> runReaderT (runReaderT rae a) e) . getAutomatonExcept+{-# INLINEABLE foreverE #-}+ {- | 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 $ CoalgebraicExcept $ StreamOptimized.constM $ ExceptT $ ReaderT $ fmap Left <$> f+{-# INLINEABLE once #-} -- | Variant of 'once' without input. once_ :: (Monad m) => m e -> AutomatonExcept a b m e once_ = once . const+{-# INLINEABLE once_ #-} -- | 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@@ -337,16 +377,19 @@ (b, e) <- arrM (lift . f) -< a _ <- throwOn' -< (n > (1 :: Int), e) returnA -< b+{-# INLINEABLE step #-} -- | Advances a single tick outputting the value, and then throws '()'. step_ :: (Monad m) => b -> AutomatonExcept a b m () step_ b = step $ const $ return (b, ())+{-# INLINEABLE step_ #-} {- | 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_+{-# INLINEABLE listToAutomatonExcept #-} -- * Utilities definable in terms of 'AutomatonExcept' @@ -359,14 +402,17 @@ performOnFirstSample mAutomaton = safely $ do automaton <- once_ mAutomaton safe automaton+{-# INLINEABLE performOnFirstSample #-} -- | '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+{-# INLINEABLE reactimateExcept #-} -- | 'reactimate's an 'Automaton' until it returns 'True'. reactimateB :: (Monad m) => Automaton m () Bool -> m () reactimateB ae = reactimateExcept $ try $ liftS ae >>> throwOn ()+{-# INLINEABLE reactimateB #-} {- | 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@.@@ -380,6 +426,7 @@ (b, me) <- liftS automaton -< a throwMaybe -< me returnA -< b+{-# INLINEABLE switch #-} {- | 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).@@ -392,3 +439,4 @@ dSwitch sf = catchS $ feedback Nothing $ proc (a, me) -> do throwMaybe -< me liftS sf -< a+{-# INLINEABLE dSwitch #-}
src/Data/Stream.hs view
@@ -1,8 +1,3 @@-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} module Data.Stream where@@ -21,6 +16,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Except (ExceptT (..), except, runExceptT, throwE, withExceptT) import Control.Monad.Trans.Maybe (MaybeT (..))+import Control.Monad.Trans.Reader (ReaderT (..)) import Control.Monad.Trans.Writer (WriterT (runWriterT), writer) -- mmorph@@ -69,9 +65,11 @@ 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.@@ -87,10 +85,11 @@ { 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@+ {- ^ 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.@@ -356,6 +355,23 @@ Left _ -> stepNew state Right result -> pure result +{- | Like 'foreverExcept', but keep the last thrown exception.++Before any exception was thrown, an initialisation value is given.+-}+foreverExceptE :: (Functor m, Monad m) => e -> StreamT (ExceptT e (ReaderT e m)) a -> StreamT m a+foreverExceptE e StreamT {state, step} =+ StreamT+ { state = JointState e state+ , step = stepNew+ }+ where+ stepNew (JointState e s) = do+ resultOrException <- runReaderT (runExceptT (step s)) e+ case resultOrException of+ Left e -> stepNew $! JointState e state+ Right result -> pure $! mapResultState (JointState e) 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) exceptS StreamT {state, step} =@@ -422,10 +438,12 @@ 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.
src/Data/Stream/Except.hs view
@@ -4,6 +4,7 @@ import Control.Category ((>>>)) import Control.Monad (ap) import Data.Bifunctor (bimap)+import Data.Bitraversable (bisequenceA) import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Void@@ -11,6 +12,7 @@ -- transformers import Control.Monad.Trans.Class import Control.Monad.Trans.Except+import Control.Monad.Trans.Reader (ReaderT (..)) -- mmorph import Control.Monad.Morph (MFunctor, hoist)@@ -19,7 +21,8 @@ import Control.Selective -- automaton-import Data.Stream (foreverExcept)+import Data.Stream (foreverExcept, foreverExceptE)+import Data.Stream qualified as StreamT import Data.Stream.Optimized as OptimizedStreamT (OptimizedStreamT, applyExcept, constM, hoist', selectExcept) import Data.Stream.Optimized qualified as StreamOptimized import Data.Stream.Recursive (Recursive (..))@@ -66,42 +69,61 @@ traverseRecursive = getRecursive >>> runExceptT- >>> fmap (bimap f (mapResultState traverseRecursive >>> (\Result {resultState, output} -> (Result <$> resultState) <&> ($ output))) >>> bitraverseEither)+ >>> fmap (bimap f (mapResultState traverseRecursive >>> (\Result {resultState, output} -> (Result <$> resultState) <&> ($ output))) >>> bisequenceA) >>> 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+ {-# INLINEABLE fmap #-} instance (Monad m) => Applicative (StreamExcept a m) where pure = CoalgebraicExcept . constM . throwE+ {-# INLINEABLE pure #-} CoalgebraicExcept f <*> CoalgebraicExcept a = CoalgebraicExcept $ applyExcept f a f <*> a = ap f a+ {-# INLINEABLE (<*>) #-} instance (Monad m) => Selective (StreamExcept a m) where select (CoalgebraicExcept e) (CoalgebraicExcept f) = CoalgebraicExcept $ selectExcept e f select e f = selectM e f+ {-# INLINEABLE select #-} -- | 'return'/'pure' throw exceptions, '(>>=)' uses the last thrown exception as input for an exception handler. instance (Monad m) => Monad (StreamExcept a m) where (>>) = (*>)+ {-# INLINE (>>) #-} -- FIXME this doesn't inline properly. Because of polymorphism? ae >>= f = RecursiveExcept $ handleExceptT (toRecursive ae) (toRecursive . f) instance MonadTrans (StreamExcept a) where lift = CoalgebraicExcept . constM . ExceptT . fmap Left+ {-# INLINEABLE lift #-} instance MFunctor (StreamExcept a) where hoist morph (RecursiveExcept recursive) = RecursiveExcept $ hoist (mapExceptT morph) recursive hoist morph (CoalgebraicExcept coalgebraic) = CoalgebraicExcept $ hoist (mapExceptT morph) coalgebraic+ {-# INLINEABLE hoist #-} +{- | If no exception can occur, the stream can be executed without the 'ExceptT'+layer.++Used to exit the 'StreamExcept' context, often in combination with 'safe'.+-} safely :: (Monad m) => StreamExcept a m Void -> OptimizedStreamT m a safely = hoist (fmap (either absurd id) . runExceptT) . runStreamExcept+{-# INLINEABLE safely #-}++{- | A stream 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 a 'StreamExcept' @do@-block.+See 'safely' for an example.+-} safe :: (Monad m) => OptimizedStreamT m a -> StreamExcept a m void safe = CoalgebraicExcept . hoist lift +-- | Run the stream until the exception is thrown, then restart, continuing this cycle forever. forever :: (Monad m) => StreamExcept a m e -> OptimizedStreamT m a forever recursive@(RecursiveExcept _) = safely go where@@ -110,3 +132,20 @@ forever (CoalgebraicExcept (StreamOptimized.Stateless f)) = StreamOptimized.Stateless go where go = runExceptT f >>= either (const go) pure++{- | Like 'forever', but keep the last thrown exception.++Before any exception was thrown, an initialisation value is given.+-}+foreverE ::+ (Monad m) =>+ -- | The initial value that is supplied to the 'ReaderT' context before the first exception is thrown+ e ->+ StreamExcept a (ReaderT e m) e ->+ OptimizedStreamT m a+foreverE e = \case+ (RecursiveExcept recursive) -> StreamOptimized.Stateful $ foreverExceptE e $ StreamT.fromRecursive recursive+ (CoalgebraicExcept (StreamOptimized.Stateful stream)) -> StreamOptimized.Stateful $ foreverExceptE e stream+ (CoalgebraicExcept (StreamOptimized.Stateless f)) -> StreamOptimized.Stateless $ go e+ where+ go e = runReaderT (runExceptT f) e >>= either go pure
src/Data/Stream/Filter.hs view
@@ -31,8 +31,9 @@ -} 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'.+ {- ^ 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
test/Automaton.hs view
@@ -76,6 +76,10 @@ [ 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] ]+ , testGroup+ "initial"+ [ testCase "Remembers first value" $ runIdentity (embed initial [1, 2, 3]) @?= [1, 1, 1]+ ] , Automaton.Except.tests , Automaton.Filter.tests , Automaton.Trans.Accum.tests
test/Stream.hs view
@@ -5,7 +5,9 @@ import Control.Monad.Identity (Identity (..)) -- transformers-import Control.Monad.Trans.Except (throwE)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT (..), throwE)+import Control.Monad.Trans.Reader (ReaderT (..), ask) import Control.Monad.Trans.Writer.Lazy (runWriter, tell) -- selective@@ -18,15 +20,15 @@ import Test.Tasty.HUnit (testCase, (@?=)) -- automaton-import Automaton-import Data.Stream (StreamT, constM, handleExceptT, handleWriterT, mmap, snapshot, streamToList, unfold, unfold_)+import Data.Stream (StreamT (..), constM, foreverExceptE, handleExceptT, handleWriterT, mmap, snapshot, streamToList, unfold, unfold_)+import Data.Stream.Except qualified as StreamExcept+import Data.Stream.Optimized qualified as StreamOptimized import Data.Stream.Result tests = testGroup "Stream"- [ Automaton.tests- , testGroup+ [ 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))@@ -58,7 +60,44 @@ in take 3 (fmap fst $ runIdentity $ streamToList $ handleWriterT stream) @?= [[1], [1, 2], [1, 2, 3]] ] ]+ , testGroup+ "foreverExceptE"+ [ testCase "Uses initial ReaderT value, stores exceptions, and resets state" $+ take 5 (runIdentity $ streamToList $ foreverExceptE 0 throwsNext)+ @?= [0, 1, 2, 3, 4]+ , testCase "StreamExcept.foreverE behaves the same for stateful streams" $+ let streamExcept = StreamExcept.CoalgebraicExcept $ StreamOptimized.Stateful throwsNext+ in take 5 (runIdentity $ streamToList $ StreamOptimized.toStreamT $ StreamExcept.foreverE 0 streamExcept)+ @?= [0, 1, 2, 3, 4]+ , testCase "StreamExcept.foreverE handles stateless streams" $+ let stateless =+ StreamExcept.CoalgebraicExcept $+ StreamOptimized.Stateless $ do+ ExceptT $ ReaderT $ \e -> if e > 10 then pure $ Right e else pure $ Left $ e + 1+ in take 4 (runIdentity $ streamToList $ StreamOptimized.toStreamT $ StreamExcept.foreverE 0 stateless)+ @?= [11, 11, 11, 11]+ , testCase "StreamExcept.foreverE handles RecursiveExcept via bind" $+ let recursive = StreamExcept.RecursiveExcept $+ StreamOptimized.toRecursive $+ StreamOptimized.Stateful $+ StreamT 0 $ \n -> ExceptT $ ReaderT $ \lastE ->+ if n < lastE+ then pure $ Right $ Result (n + 1) n+ else pure $ Left $ lastE + 1+ in take 10 (runIdentity $ streamToList $ StreamOptimized.toStreamT $ StreamExcept.foreverE 0 recursive)+ @?= [0, 0, 1, 0, 1, 2, 0, 1, 2, 3]+ ] ] nats :: (Applicative m) => StreamT m Int nats = unfold_ 0 (+ 1)++-- | Emit the current ReaderT value when 'shouldThrow' is False; otherwise throw its successor.+throwsNext :: StreamT (ExceptT Int (ReaderT Int Identity)) Int+throwsNext = StreamT False $ \shouldThrow ->+ do+ exceptionValue <- lift ask+ if shouldThrow+ then throwE (exceptionValue + 1)+ else+ pure $ Result True exceptionValue