machinecell 2.0.0 → 2.0.1
raw patch · 5 files changed
+423/−410 lines, 5 filesdep ~freePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: free
API changes (from Hackage documentation)
- Control.Arrow.Machine.Types: runOn :: (ArrowApply a, Monoid r) => (c -> r) -> ProcessA a (Event b) (Event c) -> a [b] r
+ Control.Arrow.Machine.Types: runOn :: (ArrowApply a, Monoid r, Foldable f) => (c -> r) -> ProcessA a (Event b) (Event c) -> a (f b) r
Files
- CHANGELOG.md +5/−0
- machinecell.cabal +3/−3
- src/Control/Arrow/Machine.hs +309/−309
- src/Control/Arrow/Machine/Types.hs +95/−91
- test/spec.hs +11/−7
CHANGELOG.md view
@@ -1,3 +1,8 @@++2.0.1+------------+* Support free-4.12+ 2.0.0 ------------ * Relocate files
machinecell.cabal view
@@ -1,5 +1,5 @@ name: machinecell-version: 2.0.0+version: 2.0.1 synopsis: Arrow based stream transducers license: BSD3 license-file: LICENSE@@ -31,7 +31,7 @@ Control.Arrow.Machine.Misc.Discrete other-extensions: FlexibleInstances, Arrows, RankNTypes, TypeSynonymInstances, MultiParamTypeClasses, GADTs, FlexibleContexts, NoMonomorphismRestriction, RecursiveDo ghc-options: -Wall- build-depends: base >=4.0 && <5.0, mtl >=2.0.1.1, free >=4.5 && < 4.12, profunctors >=4.0, arrows >=0.4.1.2, semigroups >=0.8.3.1+ build-depends: base >=4.0 && <5.0, mtl >=2.0.1.1, free >=4.12 && < 5.0, profunctors >=4.0, arrows >=0.4.1.2, semigroups >=0.8.3.1 hs-source-dirs: src default-language: Haskell2010 @@ -51,4 +51,4 @@ source-repository this type: git location: https://github.com/as-capabl/machinecell.git- tag: release-2.0.0+ tag: release-2.0.1
src/Control/Arrow/Machine.hs view
@@ -1,309 +1,309 @@-{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Arrows #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GADTs #-} - -{-| -Module: Control.Arrow.Machine -Description: Contains the main documentation and module imports. --} -module - Control.Arrow.Machine - ( - -- * Quick introduction - -- $introduction - - -- * Note - -- $note - - -- * Modules - -- | "Control.Arrow.Machine" is good to import qualified, because no operators are exported. - -- - -- Alternatively, you can import libraries below individually, - -- with only "Control.Arrow.Machine.Utils" qualified or identifier specified. - -- - -- Control.Arrow.Machine.Misc.* are not included by default. - -- They are all designed to import qualified. - module Control.Arrow.Machine.ArrowUtil, - module Control.Arrow.Machine.Types, - module Control.Arrow.Machine.Utils - ) -where - -import Control.Arrow.Machine.ArrowUtil -import Control.Arrow.Machine.Types -import Control.Arrow.Machine.Utils - --- $introduction --- As other iteratee or pipe libraries, machinecell abstracts general iteration processes. --- --- Here is an example that is a simple iteration over a list. --- --- \>\>\> run (evMap (+1)) [1, 2, 3] --- [2, 3, 4] --- --- In above statement, "`evMap` (+1)" has a type "ProcessA (-\>) (Event Int) (Event Int)", --- which denotes "A stream transducer that takes a series of Int as input, --- gives a series of Int as output, run on base arrow (-\>)." --- --- `ProcessA` is the transducer type of machinecell library. --- --- = Side effects --- --- In general, `Arrow` types other than (-\>) may have side effects. --- For example any monadic side effects can be performed by wrapping the monad with `Kleisli`. --- --- ProcessA can run the effects as following. --- --- \>\>\> runKleisli (run_ $ anytime (Kleisli print)) [1, 2, 3] --- 1 --- 2 --- 3 --- --- Where `anytime` makes a transducer that executes side effects for each input. --- `run_` is almost same as `run` but discards transducer's output. --- --- That is useful in the case rather side effects are main concern. --- --- = ProcessA as pipes --- --- "ProcessA a (Event b) (Event c)" transducers are actually one-directional composable pipes. --- --- They can be constructed from `Plan` monads. --- In `Plan` monad context, `await` and `yield` can be used to get and emit values. --- And actions of base monads can be `lift`ed to the context. --- --- Then, resulting processes are composed as `Category` using `(\>\>\>)` operator. --- --- @ --- source :: ProcessA (Kleisli IO) (Event ()) (Event String) --- source = repeatedlyT kleisli0 $ --- do --- _ \<- await --- x \<- lift getLine --- yield x --- --- pipe :: ArrowApply a =\> ProcessA a (Event String) (Event String) --- pipe = construct $ --- do --- s1 \<- await --- s2 \<- await --- yield (s1 ++ s2) --- --- sink :: ProcessA (Kleisli IO) (Event String) (Event Void) --- sink = repeatedlyT kleisli0 --- do --- x \<- await --- lift $ putStrLn x --- @ --- --- \>\>\> runKleisli (run_ $ source \>\>\> pipe \>\>\> sink) (repeat ()) --- --- The above code reads two lines from stdin, puts a concatenated line to stdout and finishes. --- --- Unlike other pipe libraries, even a source must call `await`. --- --- The source awaits dummy input, namely "(repeat ())", and discard input values. --- Even the input is an infinite list, this program stops when the "pipe" transducer stops. --- --- == More details on finalizing --- --- Finalizing behavior of transducers obey the following scenario. --- --- 1. Signals of type `Event` can carry /end signs/. --- 2. Most transducers stop when they get an end sign. --- (Some exceptions can be made by `onEnd` or `catchP`) --- 3. If `run` function detects an end sign as an output of a running transducer, --- it stops feeding input values and alternatively feeds end signs. --- 4. Continue iteration until no more events can be occurred. --- --- So "await \`catchP\` some_cleanup" can handle any stop of both upstream and downstream. --- --- On the other hand, a plan never gets end sign without calling await. --- That's why even sources must call await. --- --- = Arrow composition --- --- One of the most attractive feature of machinecell is the /arrow composition/. --- --- In addition to `Category`, ProcessA has `Arrow` instance declaration, --- which allows parallel compositions. --- --- If a type has an `Arrow` instance, it can be wrote by ghc extended proc-do notation as following. --- --- @ --- f :: ProcessA (Kleisli IO) (Event Int) (Event ()) --- f = proc x -\> --- do --- -- Process odd integers. --- odds \<- filter $ arr odd -\< x --- anytime $ Kleisli (putStrLn . ("Odd: " ++)) -\< show \<$\> odds --- --- -- Process even integers. --- evens \<- filter $ arr even -\< x --- anytime $ Kleisli (putStrLn . ("Even: " ++)) -\< show \<$\> evens --- @ --- --- \>\>\> P.runKleisli (run f) [1..10] --- Odd: 1 --- Even: 2 --- Odd: 3 --- Even: 4 --- ... --- --- The result implies that two statements that inputs x and their downstreams are --- executed in parallel. --- --- = Behaviours --- --- The transducers we have already seen are all have input and output type wrapped by `Event`. --- We have not taken care of them so far because all of them are cancelled each other. --- --- But several built-in transducers provides non-event values like below. --- --- @ --- hold :: ArrowApply a =\> b -\> ProcessA a (Event b) b --- accum :: ArrowApply a =\> b -\> ProcessA a (Event (b-\>b)) b --- @ --- --- `hold` keeps the last input until a new value is provided. --- --- `accum` updates its outputting by applying every input function. --- --- According to a knowledge from arrowized FRP(functional reactive programming), --- values that appear naked in arrow notations are /behaviour/, --- that means /coutinuous/ time-varying values, --- whereas /event/ values are /discrete/. --- --- Note that all values that can be input, output, or taken effects must be discrete. --- --- To use continuous values anyhow interacting the real world, --- they must be encoded to discrete values. --- --- That's done by functor calculations between any existing events. --- --- An example is below. --- --- @ --- f :: ArrowApply a =\> ProcessA a (Event Int) (Event Int) --- f = proc x -\> --- do --- y \<- accum 0 -\< (+) \<$\> x --- returnA -\< y \<$ x --- @ --- --- \>\>\> run f [1, 2, 3] --- [1, 3, 6] --- --- `(\<$)` operator discards the value of rhs and only uses that's container structure --- e.g. 1 \<$ Just "a" =\> Just 1, 1 \<$ Nothing =\> Nothing, --- 1 \<$ [True, False, undefined] =\> [1, 1, 1]. --- --- In this case, the value of y are outputed according to the timing of x. --- - - - --- $note --- = Purity of `ProcessA (-\>)` --- Since `a` of `ProcessA a b c` represents base monad(ArrowApply), `ProcessA (-\>)` is expected to be pure. --- --- In other words, the following arrow results the same result for arbitrary `f`. --- --- @ --- proc x -\> --- do --- _ \<- fit arr f -\< x --- g -\< x --- @ --- --- Which is desugared to `f &&& g \>\>\> arr snd`. At least if `Event` constructor is exported, --- the proposition is falsible. --- When `f` is "arr (replicate k) \>\>\> fork" for some integer k and `g` is "arr (const $ Event ())", --- g yields ()s for k times. That is because, the result value of arrow "f &&& g" is --- nothing but "(Event x, Event ())" and its number of yields is k because "Event x" must --- be yielded k times. --- --- That's because `Event` constructor is hidden. --- Using primitives exported by this module, it works almost correctly. --- Event number is conserved by inserting an appropriate number of `NoEvent`s. --- But there is still a loophole. --- --- Under the current implementation, the arrow below behaves like "arr (const $ Event x)". --- --- @ --- proc x -\> hold noEvent -\< ev \<$ ev --- @ --- --- I have an idea to correct this, such that the above arrow always be `NoEvent`. --- But in the result `Event` is no longer a functor in the meaning of haskell type class. --- --- For now, if you never make value of nested event type like "ev \<$ ev", --- the problem will be avoided. --- --- = Looping --- --- Although `ProcessA` is an instance of `ArrowLoop`, --- to send values to upstream, there is a little difficulties. --- --- In example below, result is [0, 1, 1, 1], not [0, 1, 2, 3]. --- --- @ --- f = proc x -\> --- do --- rec --- b \<- dHold 0 -\< y --- y \<- fork -\< (\xx -\> [xx, xx+1, xx+2, xx+3]) \<$\> x --- returnA -\< b \<$ y --- --- dHold i = proc x -\> drSwitch (pure i) -\< ((), pure \<$\> x) --- @ --- --- \>\>\> run f [1] --- [0, 1, 1, 1] --- --- This is because of machinecell's execution strategy. --- It's much similar to Prolog's backtracking stategy. --- At the time backtracking reaches `fork` three values are --- found and backtracking go and back three times between fork and returnA, --- but not reaches to dHold until all outputs are done. --- --- In general, `Event` values should not be refered at upstream. --- --- Rather, they should be encoded to behaviours and send to upstream in --- rec statement and delayed by `cycleDelay`. --- --- Another way to send values to upstream is `encloseState`. --- --- = Unsafe primitives --- --- In the code below, `edge` does not fire. --- --- @ --- encloseState False (sta \>\>\> peekState) \>\>\> edge --- @ --- --- where --- --- @ --- sta = constructT (ary0 $ statefully unArrowMonad) (put True \>\> await \>\> put False) --- @ --- --- That is because, when "put True" is executing, the backtracking is going up and never hits `edge` --- until "put False" is executed. --- --- The same occurs for "proc b -> if b then (now -< ()) else (returnA -< noEvent)" instead of `edge`. --- --- Even worse, it again breaks the purity of `ProcessA`. --- `await` gets `NoEvent` if some "arr (replicate k) \>\>\> fork" is inserted somewhere in upstream. --- Then `edge` may fire because "put False" execution is delayed. --- --- This means that, `encloseState`, `peekState`, `edge`, and `ArrowChoice` instance for `ProcessA` --- should never be existed simultaneously. --- --- Moreover, their primitives `unsafeSteady`, `unsafeExhaust`, `fitEx` are so. --- --- But I hope some of them can be rescued. So for now, this library contains them all. - +{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}++{-|+Module: Control.Arrow.Machine+Description: Contains the main documentation and module imports.+-}+module+ Control.Arrow.Machine+ (+ -- * Quick introduction+ -- $introduction+ + -- * Note+ -- $note++ -- * Modules+ -- | "Control.Arrow.Machine" is good to import qualified, because no operators are exported.+ --+ -- Alternatively, you can import libraries below individually,+ -- with only "Control.Arrow.Machine.Utils" qualified or identifier specified.+ --+ -- Control.Arrow.Machine.Misc.* are not included by default.+ -- They are all designed to import qualified.+ module Control.Arrow.Machine.ArrowUtil,+ module Control.Arrow.Machine.Types,+ module Control.Arrow.Machine.Utils+ )+where++import Control.Arrow.Machine.ArrowUtil+import Control.Arrow.Machine.Types+import Control.Arrow.Machine.Utils++-- $introduction+-- As other iteratee or pipe libraries, machinecell abstracts general iteration processes.+--+-- Here is an example that is a simple iteration over a list.+--+-- >>> run (evMap (+1)) [1, 2, 3]+-- [2, 3, 4]+--+-- In above statement, "`evMap` (+1)" has a type "ProcessA (-\>) (Event Int) (Event Int)",+-- which denotes "A stream transducer that takes a series of Int as input,+-- gives a series of Int as output, run on base arrow (-\>)."+--+-- `ProcessA` is the transducer type of machinecell library.+--+-- = Side effects+--+-- In general, `Arrow` types other than (-\>) may have side effects.+-- For example any monadic side effects can be performed by wrapping the monad with `Kleisli`.+--+-- ProcessA can run the effects as following.+--+-- >>> runKleisli (run_ $ anytime (Kleisli print)) [1, 2, 3]+-- 1+-- 2+-- 3+--+-- Where `anytime` makes a transducer that executes side effects for each input.+-- `run_` is almost same as `run` but discards transducer's output.+--+-- That is useful in the case rather side effects are main concern.+--+-- = ProcessA as pipes+--+-- "ProcessA a (Event b) (Event c)" transducers are actually one-directional composable pipes.+--+-- They can be constructed from `Plan` monads.+-- In `Plan` monad context, `await` and `yield` can be used to get and emit values.+-- And actions of base monads can be `lift`ed to the context.+--+-- Then, resulting processes are composed as `Category` using `(\>\>\>)` operator.+--+-- @+-- source :: ProcessA (Kleisli IO) (Event ()) (Event String) +-- source = repeatedlyT kleisli0 $+-- do+-- _ \<- await+-- x \<- lift getLine+-- yield x+--+-- pipe :: ArrowApply a =\> ProcessA a (Event String) (Event String)+-- pipe = construct $+-- do+-- s1 \<- await+-- s2 \<- await+-- yield (s1 ++ s2)+--+-- sink :: ProcessA (Kleisli IO) (Event String) (Event Void)+-- sink = repeatedlyT kleisli0+-- do+-- x \<- await+-- lift $ putStrLn x+-- @+--+-- >>> runKleisli (run_ $ source \>\>\> pipe \>\>\> sink) (repeat ())+--+-- The above code reads two lines from stdin, puts a concatenated line to stdout and finishes.+--+-- Unlike other pipe libraries, even a source must call `await`.+--+-- The source awaits dummy input, namely "(repeat ())", and discard input values.+-- Even the input is an infinite list, this program stops when the "pipe" transducer stops.+--+-- == More details on finalizing+--+-- Finalizing behavior of transducers obey the following scenario.+-- +-- 1. Signals of type `Event` can carry /end signs/.+-- 2. Most transducers stop when they get an end sign.+-- (Some exceptions can be made by `onEnd` or `catchP`)+-- 3. If `run` function detects an end sign as an output of a running transducer,+-- it stops feeding input values and alternatively feeds end signs.+-- 4. Continue iteration until no more events can be occurred.+-- +-- So "await \`catchP\` some_cleanup" can handle any stop of both upstream and downstream.+--+-- On the other hand, a plan never gets end sign without calling await.+-- That's why even sources must call await.+--+-- = Arrow composition+--+-- One of the most attractive feature of machinecell is the /arrow composition/.+--+-- In addition to `Category`, ProcessA has `Arrow` instance declaration,+-- which allows parallel compositions.+--+-- If a type has an `Arrow` instance, it can be wrote by ghc extended proc-do notation as following.+--+-- @+-- f :: ProcessA (Kleisli IO) (Event Int) (Event ())+-- f = proc x -\>+-- do+-- -- Process odd integers.+-- odds \<- filter $ arr odd -\< x+-- anytime $ Kleisli (putStrLn . ("Odd: " ++)) -\< show \<$\> odds+--+-- -- Process even integers.+-- evens \<- filter $ arr even -\< x+-- anytime $ Kleisli (putStrLn . ("Even: " ++)) -\< show \<$\> evens+-- @+--+-- >>> P.runKleisli (run f) [1..10]+-- Odd: 1+-- Even: 2+-- Odd: 3+-- Even: 4+-- ...+--+-- The result implies that two statements that inputs x and their downstreams are+-- executed in parallel.+--+-- = Behaviours+--+-- The transducers we have already seen are all have input and output type wrapped by `Event`.+-- We have not taken care of them so far because all of them are cancelled each other.+--+-- But several built-in transducers provides non-event values like below.+--+-- @+-- hold :: ArrowApply a =\> b -\> ProcessA a (Event b) b+-- accum :: ArrowApply a =\> b -\> ProcessA a (Event (b-\>b)) b+-- @+--+-- `hold` keeps the last input until a new value is provided.+--+-- `accum` updates its outputting by applying every input function.+--+-- According to a knowledge from arrowized FRP(functional reactive programming),+-- values that appear naked in arrow notations are /behaviour/,+-- that means /coutinuous/ time-varying values,+-- whereas /event/ values are /discrete/.+-- +-- Note that all values that can be input, output, or taken effects must be discrete.+--+-- To use continuous values anyhow interacting the real world,+-- they must be encoded to discrete values.+--+-- That's done by functor calculations between any existing events.+--+-- An example is below.+--+-- @+-- f :: ArrowApply a =\> ProcessA a (Event Int) (Event Int)+-- f = proc x -\>+-- do+-- y \<- accum 0 -\< (+) \<$\> x+-- returnA -\< y \<$ x+-- @+--+-- >>> run f [1, 2, 3]+-- [1, 3, 6]+--+-- `(\<$)` operator discards the value of rhs and only uses that's container structure+-- e.g. 1 \<$ Just "a" =\> Just 1, 1 \<$ Nothing =\> Nothing,+-- 1 \<$ [True, False, undefined] =\> [1, 1, 1].+--+-- In this case, the value of y are outputed according to the timing of x.+--++++-- $note+-- = Purity of `ProcessA (-\>)`+-- Since `a` of `ProcessA a b c` represents base monad(ArrowApply), `ProcessA (-\>)` is expected to be pure.+--+-- In other words, the following arrow results the same result for arbitrary `f`.+--+-- @+-- proc x -\>+-- do+-- _ \<- fit arr f -\< x+-- g -\< x+-- @+-- +-- Which is desugared to `f &&& g \>\>\> arr snd`. At least if `Event` constructor is exported,+-- the proposition is falsible.+-- When `f` is "arr (replicate k) \>\>\> fork" for some integer k and `g` is "arr (const $ Event ())",+-- g yields ()s for k times. That is because, the result value of arrow "f &&& g" is+-- nothing but "(Event x, Event ())" and its number of yields is k because "Event x" must+-- be yielded k times. +--+-- That's because `Event` constructor is hidden.+-- Using primitives exported by this module, it works almost correctly.+-- Event number is conserved by inserting an appropriate number of `NoEvent`s.+-- But there is still a loophole.+--+-- Under the current implementation, the arrow below behaves like "arr (const $ Event x)".+--+-- @+-- proc x -\> hold noEvent -\< ev \<$ ev+-- @+--+-- I have an idea to correct this, such that the above arrow always be `NoEvent`.+-- But in the result `Event` is no longer a functor in the meaning of haskell type class.+--+-- For now, if you never make value of nested event type like "ev \<$ ev",+-- the problem will be avoided.+--+-- = Looping+-- +-- Although `ProcessA` is an instance of `ArrowLoop`,+-- to send values to upstream, there is a little difficulties.+-- +-- In example below, result is [0, 1, 1, 1], not [0, 1, 2, 3].+--+-- @+-- f = proc x -\>+-- do+-- rec+-- b \<- dHold 0 -\< y+-- y \<- fork -\< (\xx -\> [xx, xx+1, xx+2, xx+3]) \<$\> x+-- returnA -\< b \<$ y+--+-- dHold i = proc x -\> drSwitch (pure i) -\< ((), pure \<$\> x)+-- @+--+-- >>> run f [1]+-- [0, 1, 1, 1]+--+-- This is because of machinecell's execution strategy.+-- It's much similar to Prolog's backtracking stategy.+-- At the time backtracking reaches `fork` three values are+-- found and backtracking go and back three times between fork and returnA,+-- but not reaches to dHold until all outputs are done.+--+-- In general, `Event` values should not be refered at upstream.+--+-- Rather, they should be encoded to behaviours and send to upstream in+-- rec statement and delayed by `cycleDelay`.+--+-- Another way to send values to upstream is `encloseState`.+--+-- = Unsafe primitives+--+-- In the code below, `edge` does not fire.+--+-- @+-- encloseState False (sta \>\>\> peekState) \>\>\> edge+-- @+--+-- where+--+-- @+-- sta = constructT (ary0 $ statefully unArrowMonad) (put True \>\> await \>\> put False)+-- @+--+-- That is because, when "put True" is executing, the backtracking is going up and never hits `edge`+-- until "put False" is executed.+--+-- The same occurs for "proc b -> if b then (now -< ()) else (returnA -< noEvent)" instead of `edge`.+--+-- Even worse, it again breaks the purity of `ProcessA`.+-- `await` gets `NoEvent` if some "arr (replicate k) \>\>\> fork" is inserted somewhere in upstream.+-- Then `edge` may fire because "put False" execution is delayed.+--+-- This means that, `encloseState`, `peekState`, `edge`, and `ArrowChoice` instance for `ProcessA`+-- should never be existed simultaneously.+--+-- Moreover, their primitives `unsafeSteady`, `unsafeExhaust`, `fitEx` are so.+--+-- But I hope some of them can be rescued. So for now, this library contains them all.+
src/Control/Arrow/Machine/Types.hs view
@@ -410,17 +410,6 @@ end :: a -isNoEvent :: Occasional' a => a -> Bool-isNoEvent = collapse >>> \case { NoEvent -> True; _ -> False }--isEnd :: Occasional' a => a -> Bool-isEnd = collapse >>> \case { End -> True; _ -> False }--{--isOccasion :: Occasional' a => a -> Bool-isOccasion = collapse >>> \case { Event () -> True; _ -> False }--}- instance (Occasional' a, Occasional' b) => Occasional' (a, b) where@@ -511,7 +500,7 @@ yield x = F.liftF $ YieldPF x () await :: Plan i o i-await = F.FT $ \pure free -> free (AwaitPF pure (free StopPF))+await = F.FT $ \pure free -> free id (AwaitPF pure (free pure StopPF)) stop :: Plan i o a stop = F.liftF $ StopPF@@ -520,81 +509,88 @@ catchP:: Monad m => PlanT i o m a -> PlanT i o m a -> PlanT i o m a -catchP pl cont = - F.toFT $ catch' (F.fromFT pl) (F.fromFT cont)--catch' ::- Monad m =>- F.FreeT (PlanF t o) m a ->- F.FreeT (PlanF t o) m a ->- F.FreeT (PlanF t o) m a--catch' (F.FreeT mf) cont@(F.FreeT mcont) = - F.FreeT $ mf >>= go+catchP pl cont0 = + F.FT $ \pure free ->+ F.runFT+ pl+ (pure' pure)+ (free' cont0 pure free) where- go (F.Pure a) = return $ F.Pure a- go (F.Free StopPF) = mcont- go (F.Free (AwaitPF f ff)) = - return $ F.Free $ - AwaitPF (\i -> f i `catch'` cont) (ff `catch'` cont)- go (F.Free fft) = - return $ F.Free $ (`catch'` cont) <$> fft+ pure' pure = pure + free' ::+ Monad m =>+ PlanT i o m a ->+ (a -> m r) ->+ (forall x. (x -> m r) -> PlanF i o x -> m r) ->+ (y -> m r) ->+ (PlanF i o y) ->+ m r+ free' cont pure free _ StopPF =+ F.runFT cont pure free+ free' cont pure free r (AwaitPF f ff) =+ free+ (either (\_ -> F.runFT cont pure free) r)+ (AwaitPF (Right . f) (Left ff))+ free' _ _ free r pf =+ free r pf + constructT :: (Monad m, ArrowApply a) => (forall b. m b -> a () b) -> PlanT i o m r -> ProcessA a (Event i) (Event o) -constructT fit0 pl = ProcessA $ fit' $ F.runFT pl pure free+constructT fit0 pl0 = ProcessA $ stepOf fit0 $ F.runFT pl0 pure (free fit0) where- fit' ma = proc arg -> do { (evx, pa) <- fit0 ma -< (); modFit evx pa -<< arg }- - modFit :: ArrowApply a => Event c -> StepType a b (Event c) -> StepType a b (Event c)- modFit (Event x) stp = retArrow Feed (Event x) (ProcessA stp)- modFit End stp = retArrow Feed End (ProcessA stp)- modFit _ stp = stp-- retArrow ph' evx cont = arr $ \(ph, _) -> + stepOf fit' ma = proc arg ->+ do+ (evy, stp) <- fit' ma -< ()+ prependStep evy stp -<< arg+ + prependStep (Event y) stp = arr $ \(ph, _) -> case ph of Suspend -> - (ph `mappend` Suspend,- if isEnd evx then End else NoEvent,- ProcessA $ retArrow ph' evx cont)+ (Suspend, NoEvent, ProcessA $ prependStep (Event y) stp) _ -> - (ph `mappend` ph', evx, cont)-- pure _ = return $ (End, retArrow Suspend End stopped)+ (Feed, Event y, ProcessA stp)+ prependStep End _ = step stopped+ prependStep NoEvent stp = stp - free (AwaitPF f ff) =+ stepOfAw fit' fma = proc arg@(ph, _) -> do- return $ (NoEvent, arr (uncurry (awaitIt f ff)) >>> proc pc -> pc -<< ())-- free (YieldPF y fc) = return $ (Event y, fit' fc)-- free StopPF = return $ (End, retArrow Suspend End stopped)+ (evy, stp) <- fit' $ go arg -<< ()+ let ph' = case evy of {NoEvent -> Suspend; _ -> Feed}+ returnA -< (ph `mappend` ph', evy, ProcessA stp)+ where+ go (Feed, evx) = fma evx+ go (Sweep, End) = fma End+ go _ = return (NoEvent, stepOfAw fit' fma) + pure _ =+ return $ (End, step stopped) - awaitIt f _ Feed (Event x) = proc _ ->+ free ::+ (ArrowApply a, Monad m) =>+ (forall t. m t -> a () t) ->+ (x -> m (Event o, StepType a (Event i) (Event o)))+ -> PlanF i o x -> m (Event o, StepType a (Event i) (Event o))+ free fit' r pl@(AwaitPF f ff) = do- (evy, stp) <- fit0 (f x) -< ()- returnA -< (Feed, evy, ProcessA stp)+ return $ (NoEvent, stepOfAw fit' fma)+ where+ fma (Event x) = r (f x)+ fma NoEvent = free fit' r pl+ fma End = r ff - awaitIt _ ff Feed End = proc _ ->- do- (evy, stp) <- fit0 ff -< ()- returnA -< (Feed, evy, ProcessA stp)+ free fit' r (YieldPF y fc) =+ return $ (Event y, stepOf fit' (r fc)) - awaitIt _ ff Sweep End = proc _ ->- do- (evy, stp) <- fit0 ff -< ()- returnA -< (if not $ isNoEvent evy then Feed else Suspend, evy, ProcessA stp)+ free _ _ StopPF =+ return $ (End, step stopped) - awaitIt f ff ph _ = proc _ ->- returnA -< (ph `mappend` Suspend, NoEvent, - ProcessA $ arr (uncurry (awaitIt f ff)) >>> proc pc -> pc -<< ()) repeatedlyT :: (Monad m, ArrowApply a) => @@ -675,21 +671,20 @@ ArrowApply a => ProcessA a b c -> ProcessA a (b, Event (ProcessA a b c)) c -rSwitch cur = ProcessA $ proc (ph, (x, eva)) -> - do- let now = evMaybePh cur id (ph, eva)- (ph', y, new) <- step now -<< (ph, x)- returnA -< (ph', y, rSwitch new)+rSwitch p = rSwitch' (p *** Cat.id) >>> arr fst+ where+ rSwitch' pid = kSwitch pid test $ \_ p' -> rSwitch'' (p' *** Cat.id)+ rSwitch'' pid = dkSwitch pid test $ \s _ -> rSwitch' s+ test = proc (_, (_, r)) -> returnA -< r drSwitch :: ArrowApply a => ProcessA a b c -> ProcessA a (b, Event (ProcessA a b c)) c -drSwitch cur = ProcessA $ proc (ph, (x, eva)) -> - do- (ph', y, new) <- step cur -< (ph, x)- returnA -< (ph', y, drSwitch (evMaybePh new id (ph, eva)))+drSwitch p = drSwitch' (p *** Cat.id)+ where+ drSwitch' pid = dSwitch pid $ \p' -> drSwitch' (p' *** Cat.id) kSwitch :: ArrowApply a => @@ -703,9 +698,13 @@ (ph', y, sf') <- step sf -< (ph, x) (phT, evt, test') <- step test -< (ph', (x, y)) + let+ nextA t = k sf' t+ nextB = kSwitch sf' test' k+ evMaybePh - (arr $ const (phT, y, kSwitch sf' test' k)) - (step . (k sf'))+ (arr $ const (phT, y, nextB)) + (step . nextA) (phT, evt) -<< (phT, x) @@ -793,7 +792,7 @@ (phT, evt, test') <- step test -< (ph', (x, zs)) evMaybePh- (arr $ const (ph' `mappend` phT, zs, pSwitch r sfs' test' k))+ (arr $ const (phT, zs, pSwitch r sfs' test' k)) (step . (k sfs') ) (phT, evt) -<< (ph, x)@@ -909,7 +908,7 @@ -- | Monoid wrapper data WithEnd r = WithEnd { getRWE :: r,- getContWE :: Bool+ getContWE :: !Bool } instance@@ -1035,34 +1034,38 @@ -- | Run a machine with results concatenated in terms of a monoid. runOn ::- (ArrowApply a, Monoid r) =>+ (ArrowApply a, Monoid r, Fd.Foldable f) => (c -> r) -> ProcessA a (Event b) (Event c) ->- a [b] r+ a (f b) r runOn outpre pa0 = unArrowMonad $ \xs -> do wer <- runRM arrowMonad pa0 $ execWriterT $ do- go xs+ -- Sweep initial events.+ (_, wer) <- listen $ sweepAll outpre++ -- Feed inputs.+ if getContWE wer+ then+ Fd.foldr feedSweep (return ()) xs+ else+ return ()++ -- Terminate. _ <- lift (feed_ End End) sweepAll outpre return $ getRWE wer where- go xs =- do- (_, wer) <- listen $ sweepAll outpre- if getContWE wer then cont xs else return ()-- cont [] = return ()-- cont (x:xs) =+ feedSweep x cont = do _ <- lift $ feed x- go xs+ ((), wer) <- listen $ sweepAll outpre+ if getContWE wer then cont else return ()+ --- | Run a machine. newtype Builder a = Builder { unBuilder :: forall b. (a -> b -> b) -> b -> b }@@ -1073,6 +1076,7 @@ Builder g `mappend` Builder f = Builder $ \c e -> g c (f c e) +-- | Run a machine. run :: ArrowApply a => ProcessA a (Event b) (Event c) ->
test/spec.hs view
@@ -340,18 +340,22 @@ result = run (repeatedly pl) l result `shouldBe` [2, 3, 5, 6, 10, 11, 20, 21, 100, 101] - it "can handle the end with catch." $ + it "can handle the end with catchP." $ do - let pl2 = + let + plCatch = do x <- await `catchP` (yield 1 >> stop) yield x - y <- await + y <- (yield 2 >> await >> yield 3 >> await) `catchP` (yield 4 >> return 5) yield y - - run (construct pl2) [] `shouldBe` [1] - run (construct pl2) [3] `shouldBe` [3] - run (construct pl2) [3, 2] `shouldBe` [3, 2] + y <- (await >>= yield >> stop) `catchP` (yield 6 >> return 7) + yield y + run (construct plCatch) [] `shouldBe` [1] + run (construct plCatch) [100] `shouldBe` [100, 2, 4, 5, 6, 7] + run (construct plCatch) [100, 200] `shouldBe` [100, 2, 3, 4, 5, 6, 7] + run (construct plCatch) [100, 200, 300] `shouldBe` [100, 2, 3, 300, 6, 7] + run (construct plCatch) [100, 200, 300, 400] `shouldBe` [100, 2, 3, 300, 400, 6, 7] utility = do