diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ + +2.0.1 +------------ +* Support free-4.12 + 2.0.0 ------------ * Relocate files diff --git a/machinecell.cabal b/machinecell.cabal --- a/machinecell.cabal +++ b/machinecell.cabal @@ -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 diff --git a/src/Control/Arrow/Machine.hs b/src/Control/Arrow/Machine.hs --- a/src/Control/Arrow/Machine.hs +++ b/src/Control/Arrow/Machine.hs @@ -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. + diff --git a/src/Control/Arrow/Machine/Types.hs b/src/Control/Arrow/Machine/Types.hs --- a/src/Control/Arrow/Machine/Types.hs +++ b/src/Control/Arrow/Machine/Types.hs @@ -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) -> diff --git a/test/spec.hs b/test/spec.hs --- a/test/spec.hs +++ b/test/spec.hs @@ -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