machinecell 1.3.1 → 2.0.0

raw patch · 17 files changed

+1835/−1481 lines, 17 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• machinecell.cabal +13/−6
• src/Control/Arrow/Machine.hs +292/−15
• src/Control/Arrow/Machine/Core.hs +0/−40
• src/Control/Arrow/Machine/Event.hs +0/−21
• src/Control/Arrow/Machine/Event/Internal.hs +0/−204
• src/Control/Arrow/Machine/Exception.hs +0/−98
• src/Control/Arrow/Machine/Misc/Discrete.hs +152/−0
• src/Control/Arrow/Machine/Misc/Exception.hs +76/−0
• src/Control/Arrow/Machine/Misc/Pump.hs +1/−1
• src/Control/Arrow/Machine/Plan.hs +0/−144
• src/Control/Arrow/Machine/Plan/Internal.hs +0/−23
• src/Control/Arrow/Machine/Running.hs +0/−296
• src/Control/Arrow/Machine/Types.hs +1167/−217
• src/Control/Arrow/Machine/Utils.hs +99/−332
• test/RandomProc.hs +10/−12
• test/spec.hs +13/−72

@@ -1,3 +1,15 @@+2.0.0+------------+* Relocate files+    * `catch` and its families are moved to Misc.Exception+* Performance improve+* Added primitives: `fitEx`, `unsafeSteady`, `unsafeExhaust`+* Added: `condEvent`, `filterEvent`, `muted`+* Added to Misc: `Discrete`, `Pump.asUpdater`, `Pump.Alg`+* Deleted deprecated: `hEv`, `hEv'`, `evMaybe`, `fromEvent`, `split`,+  `join`, `split2`, `join2`, `feedback`, `feedback1`, `isNoEvent`, `isOccasional`, `isEnd`+* Deleted `Foldable` and `Traversable` instance of `Event`.+* Added `Occasional'` by splitting some members from `Occasional`  1.3.1 ------------

@@ -1,5 +1,5 @@ name:                machinecell-version:             1.3.1+version:             2.0.0 synopsis:            Arrow based stream transducers license:             BSD3 license-file:        LICENSE@@ -21,10 +21,17 @@ 	AFRP-like utilities are also available.  library-  exposed-modules:     Control.Arrow.Machine, Control.Arrow.Machine.Event, Control.Arrow.Machine.Plan, Control.Arrow.Machine.Types, Control.Arrow.Machine.Utils, Control.Arrow.Machine.Running, Control.Arrow.Machine.ArrowUtil, Control.Arrow.Machine.Exception, Control.Arrow.Machine.Core, Control.Arrow.Machine.Misc.Pump-  other-modules:         Control.Arrow.Machine.Event.Internal, Control.Arrow.Machine.Plan.Internal+  exposed-modules:+        Control.Arrow.Machine,+        Control.Arrow.Machine.Types,+        Control.Arrow.Machine.Utils,+        Control.Arrow.Machine.ArrowUtil,+        Control.Arrow.Machine.Misc.Exception,+        Control.Arrow.Machine.Misc.Pump,+        Control.Arrow.Machine.Misc.Discrete   other-extensions:    FlexibleInstances, Arrows, RankNTypes, TypeSynonymInstances, MultiParamTypeClasses, GADTs, FlexibleContexts, NoMonomorphismRestriction, RecursiveDo-  build-depends:       base >=4.0 && <5.0, mtl >=2.0.1.1, free >=4.5, profunctors >=4.0, arrows >=0.4.1.2, semigroups >=0.8.3.1+  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   hs-source-dirs:      src   default-language:    Haskell2010 @@ -34,7 +41,7 @@   hs-source-dirs:      test   main-is:             spec.hs   other-modules:       RandomProc, LoopUtil-  Build-depends:       base >=4.0 && <5.0, mtl >=2.0.1.1, profunctors >=4.0, QuickCheck >=1.0, hspec >=0.2.0, machinecell -any+  Build-depends:       base >=4.0 && <5.0, mtl >=2.0.1.1, profunctors >=4.0, QuickCheck >=1.0, hspec >=0.2.0, arrows >=0.4.1.2, semigroups >=0.8.3.1, machinecell -any  source-repository head   type:		git@@ -44,4 +51,4 @@ source-repository this   type:		git   location:	https://github.com/as-capabl/machinecell.git-  tag:		release-1.3.1+  tag:		release-2.0.0

@@ -4,29 +4,306 @@ {-# 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
-        module Control.Arrow.Machine.Event, 
-        module Control.Arrow.Machine.Utils,
-        module Control.Arrow.Machine.Plan,
-        module Control.Arrow.Machine.Exception,
-        module Control.Arrow.Machine.Running,
+        -- | "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,
-
-        -- * The transducer arrow
-        ProcessA(), 
-        fit
+        module Control.Arrow.Machine.Types,
+        module Control.Arrow.Machine.Utils
        )
 where
 
-import Control.Arrow.Machine.Event
-import Control.Arrow.Machine.Utils
-import Control.Arrow.Machine.Plan
-import Control.Arrow.Machine.Exception
-import Control.Arrow.Machine.Running
 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.
+--
 
-import Control.Arrow.Machine.Types
+
+
+-- $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.
+       

@@ -1,40 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Arrows #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GADTs #-}---{-|-Extracted stuff to be used unqualified from ../Machine.hs.--}-module-    Control.Arrow.Machine.Core-      (-        -- * Modules-        module Control.Arrow.Machine.Event, ---        module Control.Arrow.Machine.Utils,-        module Control.Arrow.Machine.Plan,---        module Control.Arrow.Machine.Exception,-        module Control.Arrow.Machine.Running,---        module Control.Arrow.Machine.ArrowUtil,--        -- * The transducer arrow-        ProcessA(), -        fit,-       )-where--import Control.Arrow.Machine.Event--- import Control.Arrow.Machine.Utils-import Control.Arrow.Machine.Plan--- import Control.Arrow.Machine.Exception-import Control.Arrow.Machine.Running-import qualified Control.Arrow.Machine.Running as Running--- import Control.Arrow.Machine.ArrowUtil--import Control.Arrow.Machine.Types-import Control.Arrow--

@@ -1,21 +0,0 @@-module-    Control.Arrow.Machine.Event -      (-        Occasional (..),-        Event (),--        -- * Deprecated-        -- |They should be used only for internal use.-        hEv, -        hEv', -        evMaybe,-        fromEvent,-        evMap,-        split,-        join,-        split2,-        join2-      )-where--import Control.Arrow.Machine.Event.Internal

@@ -1,204 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Arrows #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GADTs #-}--module-    Control.Arrow.Machine.Event.Internal-where--import Control.Arrow-import Control.Applicative-import Data.Foldable-import Data.Traversable-import Data.Monoid (Monoid, mappend, mconcat, mempty)-import Data.Semigroup (Semigroup, (<>))-import Control.Monad (liftM, MonadPlus(..))-    -data Event a = Event a | NoEvent | End deriving (Eq, Show)---instance -    Functor Event -  where-    fmap f NoEvent = NoEvent-    fmap f End = End-    fmap f (Event x) = Event (f x)--{--instance -    Applicative Event -  where-    pure = Event--    (Event f) <*> (Event x) = Event $ f x-    End <*> _ = End-    _ <*> End = End-    _ <*> _ = NoEvent--}--instance-    Foldable Event-  where-    foldMap f (Event x) = f x-    foldMap _ NoEvent = mempty-    foldMap _ End = mempty---instance-    Traversable Event-  where-    traverse f (Event x) = Event <$> f x-    traverse f NoEvent = pure NoEvent-    traverse f End = pure End--instance-    Semigroup a => Monoid (Event a)-  where-    mempty = End-    Event x `mappend` Event y = Event (x <> y)-    Event x `mappend` _ = Event x-    _ `mappend` Event y = Event y-    NoEvent `mappend` _ = NoEvent-    _ `mappend` NoEvent = NoEvent-    _ `mappend` _ = End--{--instance-    Monad Event-  where-    return = Event--    Event x >>= f = f x-    NoEvent >>= _ = NoEvent-    End >>= _ = End--    _ >> End = End-    l >> r = l >>= const r-    -    fail _ = End---instance-    MonadPlus Event-  where-    mzero = End--    Event x `mplus` _ = Event x-    _ `mplus` Event x = Event x-    End `mplus` r = r-    l `mplus` End = l-    _ `mplus` _ = NoEvent--}-----class -    Occasional a-  where-    noEvent :: a-    end :: a-    isNoEvent :: a -> Bool-    isEnd :: a -> Bool-    isOccasion :: a -> Bool-    isOccasion x = not (isNoEvent x) && not (isEnd x)--instance-    (Occasional a, Occasional b) => Occasional (a, b)-  where-    noEvent = (noEvent, noEvent)-    end = (end, end)-    isOccasion xy@(x, y) = -        (isOccasion x || isOccasion y) && not (isEnd xy)-    isNoEvent xy = -        not (isOccasion xy) && not (isEnd xy)-    isEnd (x, y) = isEnd x && isEnd y-----instance -    Occasional (Event a)-  where-    noEvent = NoEvent-    end = End-    isNoEvent NoEvent = True-    isNoEvent _ = False-    isEnd End = True-    isEnd _ = False--hEv :: ArrowApply a => a (e,b) c -> a e c -> a (e, Event b) c-hEv f1 f2 = proc (e, ev) ->-    helper ev -<< e-  where-    helper (Event x) = proc e -> f1 -< (e, x)-    helper NoEvent = f2-    helper End = f2--hEv' :: ArrowApply a => a (e,b) c -> a e c -> a e c -> a (e, Event b) c-hEv' f1 f2 f3 = proc (e, ev) ->-    helper ev -<< e-  where-    helper (Event x) = proc e -> f1 -< (e, x)-    helper NoEvent = f2-    helper End = f3-----evMaybe :: Arrow a => c -> (b->c) -> a (Event b) c-evMaybe r f = arr (go r f)-  where-    go _ f (Event x) = f x-    go r _ NoEvent = r-    go r _ End = r---fromEvent :: Arrow a => b -> a (Event b) b-fromEvent x = evMaybe x id----- TODO: テスト-condEvent :: Bool -> Event a -> Event a-condEvent _ End = End-condEvent True ev = ev-condEvent False ev = NoEvent----- TODO: テスト-filterEvent :: (a -> Bool) -> Event a -> Event a-filterEvent cond ev@(Event x) = condEvent (cond x) ev-filterEvent _ ev = ev---evMap ::  Arrow a => (b->c) -> a (Event b) (Event c)-evMap = arr . fmap----- TODO: テスト-split :: (Arrow a, Occasional b) => a (Event b) b-split = arr go-  where-    go (Event x) = x-    go NoEvent = noEvent-    go End = end---join :: (Arrow a, Occasional b) => a b (Event b)-join = arr go-  where-    go x -       | isEnd x = End-       | isNoEvent x = NoEvent-       | otherwise = Event x---split2 :: Event (Event a, Event b) -> (Event a, Event b)-split2 = split---join2 :: (Event a, Event b) -> Event (Event a, Event b)-join2 = join

@@ -1,98 +0,0 @@---module-    Control.Arrow.Machine.Exception-      (-        catch,-        handle,-        bracket,-        bracket_,-        bracketOnError,-        finally,-        onException-       )-where--import qualified Control.Monad.Trans.Free as F-import qualified Control.Monad.Trans.Free.Church as F--import Data.Functor ((<$>))--import Control.Arrow.Machine.Types-import Control.Arrow.Machine.Event-import Control.Arrow.Machine.Event.Internal (Event(..))--import Control.Arrow.Machine.Plan.Internal-import Control.Arrow.Machine.Plan--import Debug.Trace---catch :: Monad m =>-    PlanT i o m a -> PlanT i o m a -> PlanT i o m a--catch pl cont = -    F.toFT $ catch' (F.fromFT pl) (F.fromFT cont)--catch' (F.FreeT mf) cont@(F.FreeT mcont) = -    F.FreeT $ mf >>= go-  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--handle :: Monad m =>-    PlanT i o m a -> PlanT i o m a -> PlanT i o m a--handle = flip catch---bracket :: Monad m =>-    PlanT i o m a -> (a -> PlanT i o m b)-> (a -> PlanT i o m c) -> PlanT i o m c-bracket before after thing =-  do-    a <- before-    r <- thing a `catch` (after a >> stop)-    _ <- after a-    return r---bracket_ :: Monad m =>-    PlanT i o m a -> PlanT i o m b-> PlanT i o m c -> PlanT i o m c-bracket_ before after thing =-  do-    before-    r <- thing `catch` (after >> stop)-    _ <- after-    return r---bracketOnError :: Monad m =>-    PlanT i o m a -> (a -> PlanT i o m b)-> (a -> PlanT i o m c) -> PlanT i o m c-bracketOnError before after thing =-  do-    a <- before-    r <- thing a `catch` (after a >> stop)-    return r---finally :: Monad m =>-    PlanT i o m a -> PlanT i o m b-> PlanT i o m a-finally thing after =-  do-    r <- thing `catch` (after >> stop)-    _ <- after-    return r---onException :: Monad m =>-    PlanT i o m a -> PlanT i o m b-> PlanT i o m a-onException thing after =-  do-    thing `catch` (after >> stop)-    -

@@ -0,0 +1,152 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module+    Control.Arrow.Machine.Misc.Discrete+      (+        -- *Discrete+        -- | This module should be imported manually.+        T(),+        updates,+        value,+        +        arr,+        arr2,+        arr3,+        arr4,+        arr5,++        constant,+        hold,+        accum,+        fromEq,+        +        edge,+        asUpdater,+        Alg+      )+where++import Prelude hiding (id, (.))+import Control.Category+import Control.Arrow hiding (arr)+import Control.Applicative+import qualified Control.Arrow as Arr+import qualified Control.Arrow.Machine as P+import Data.Monoid (mconcat, mappend)++data T a = T {+    updates :: (P.Event ()),+    value :: a+  }++makeT ::+    ArrowApply a =>+    P.ProcessA a (P.Event (), b) (T b)+makeT = Arr.arr $ uncurry T++arr ::+    ArrowApply a =>+    (b->c) ->+    P.ProcessA a (T b) (T c)+arr f =+    Arr.arr $ \(T ev x) ->+        T ev (f x)++arr2 ::+    ArrowApply a =>+    (b1->b2->c) ->+    P.ProcessA a (T b1, T b2) (T c)+arr2 f =+    Arr.arr $ \(T ev1 x1, T ev2 x2) ->+        T (mconcat [ev1, ev2]) (f x1 x2)++arr3 ::+    ArrowApply a =>+    (b1->b2->b3->c) ->+    P.ProcessA a (T b1, T b2, T b3) (T c)+arr3 f =+    Arr.arr $ \(T ev1 x1, T ev2 x2, T ev3 x3) ->+        T (mconcat [ev1, ev2, ev3]) (f x1 x2 x3)++arr4 ::+    ArrowApply a =>+    (b1->b2->b3->b4->c) ->+    P.ProcessA a (T b1, T b2, T b3, T b4) (T c)+arr4 f =+    Arr.arr $ \(T ev1 x1, T ev2 x2, T ev3 x3, T ev4 x4) ->+        T (mconcat [ev1, ev2, ev3, ev4]) (f x1 x2 x3 x4)++arr5 ::+    ArrowApply a =>+    (b1->b2->b3->b4->b5->c) ->+    P.ProcessA a (T b1, T b2, T b3, T b4, T b5) (T c)+arr5 f =+    Arr.arr $ \(T ev1 x1, T ev2 x2, T ev3 x3, T ev4 x4, T ev5 x5) ->+        T (mconcat [ev1, ev2, ev3, ev4, ev5]) (f x1 x2 x3 x4 x5)++constant::+    ArrowApply a =>+    c ->+    P.ProcessA a b (T c)+constant x =+    (P.now &&& Arr.arr (const x)) >>> makeT++onUpdate ::+    ArrowApply a =>+    P.ProcessA a (P.Event b) (P.Event ())+onUpdate = proc ev ->+  do+    n <- P.now -< ()+    returnA -< n `mappend` P.collapse ev++hold ::+    ArrowApply a =>+    b ->+    P.ProcessA a (P.Event b) (T b)+hold i =+    (onUpdate &&& P.hold i) >>> makeT++accum ::+    ArrowApply a =>+    b ->+    P.ProcessA a (P.Event (b->b)) (T b)+accum i =+    (onUpdate &&& P.accum i) >>> makeT++fromEq ::+    (ArrowApply a, Eq b) =>+    P.ProcessA a b (T b)+fromEq = proc x ->+  do+    ev <- P.edge -< x+    returnA -< T (P.collapse ev) x++edge ::+    ArrowApply a =>+    P.ProcessA a (T b) (P.Event b)+edge = Arr.arr $ \(T ev x) -> x <$ ev++asUpdater ::+    ArrowApply a =>+    a b c ->+    P.ProcessA a (T b) (P.Event c)+asUpdater ar = edge >>> P.anytime ar++++newtype Alg a i o = Alg { eval :: P.ProcessA a i (T o) }++instance+    ArrowApply a => Functor (Alg a i)+  where+    fmap f alg = Alg $ eval alg >>> arr f++instance+    ArrowApply a => Applicative (Alg a i)+  where+    pure = Alg . constant+    af <*> aa = Alg $ (eval af &&& eval aa) >>> arr2 ($)

@@ -0,0 +1,76 @@+++module+    Control.Arrow.Machine.Misc.Exception+      (+        catch,+        handle,+        bracket,+        bracket_,+        bracketOnError,+        finally,+        onException+       )+where+++import Control.Arrow.Machine.Types+++catch :: Monad m =>+    PlanT i o m a -> PlanT i o m a -> PlanT i o m a++catch = catchP+++handle :: Monad m =>+    PlanT i o m a -> PlanT i o m a -> PlanT i o m a++handle = flip catch+++bracket :: Monad m =>+    PlanT i o m a -> (a -> PlanT i o m b)-> (a -> PlanT i o m c) -> PlanT i o m c+bracket before after thing =+  do+    a <- before+    r <- thing a `catch` (after a >> stop)+    _ <- after a+    return r+++bracket_ :: Monad m =>+    PlanT i o m a -> PlanT i o m b-> PlanT i o m c -> PlanT i o m c+bracket_ before after thing =+  do+    _ <- before+    r <- thing `catch` (after >> stop)+    _ <- after+    return r+++bracketOnError :: Monad m =>+    PlanT i o m a -> (a -> PlanT i o m b)-> (a -> PlanT i o m c) -> PlanT i o m c+bracketOnError before after thing =+  do+    a <- before+    r <- thing a `catch` (after a >> stop)+    return r+++finally :: Monad m =>+    PlanT i o m a -> PlanT i o m b-> PlanT i o m a+finally thing after =+  do+    r <- thing `catch` (after >> stop)+    _ <- after+    return r+++onException :: Monad m =>+    PlanT i o m a -> PlanT i o m b-> PlanT i o m a+onException thing after =+  do+    thing `catch` (after >> stop)+    +

@@ -30,7 +30,7 @@ import qualified Control.Arrow.Machine as P import Data.Monoid (Endo(Endo), mappend, appEndo) -newtype Duct a = Duct { unDuct :: Endo [a] }+newtype Duct a = Duct (Endo [a])  oneMore ::     ArrowApply a =>

@@ -1,144 +0,0 @@-{-# LANGUAGE Arrows #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--{-|-A coroutine monad, inspired by machines library.--}-module-    Control.Arrow.Machine.Plan-      (-        -- * Types and Primitives-        PlanT,-        Plan,--        await,-        yield,-        stop,--        stopped,--        -- * Constructing machines-        constructT,-        repeatedlyT,--        construct,-        repeatedly-       )-where--import qualified Control.Category as Cat-import qualified Control.Monad.Trans.Free as F-import qualified Control.Monad.Trans.Free.Church as F--import Data.Monoid (mappend)-import Data.Functor ((<$>))-import Control.Monad-import Control.Arrow-import Control.Monad.Trans-import Debug.Trace--import Control.Arrow.Machine.ArrowUtil-import Control.Arrow.Machine.Types-import Control.Arrow.Machine.Event-import Control.Arrow.Machine.Event.Internal (Event(..))--import Control.Arrow.Machine.Plan.Internal--stopped :: -    (ArrowApply a, Occasional c) => ProcessA a b c-stopped = arr (const end)------yield :: o -> Plan i o ()-yield x = F.liftF $ YieldPF x ()--await :: Plan i o i-await = F.FT $ \pure free -> free (AwaitPF pure (free StopPF))--stop :: Plan i o a-stop = F.liftF $ StopPF-------constructT :: (Monad m, ArrowApply a) => -              (forall b. m b -> a () b) ->-              PlanT i o m r -> -              ProcessA a (Event i) (Event o)--constructT fit pl = ProcessA $ fit' $ F.runFT pl pure free-  where-    fit' ma = proc arg -> do { (evx, pa) <- fit 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, _) -> -        case ph of-          Suspend -> -              (ph `mappend` Suspend,-               if isEnd evx then End else NoEvent,-               ProcessA $ retArrow ph' evx cont)-          _ -> -              (ph `mappend` ph', evx, cont)--    pure _ = return $ (End, retArrow Suspend End stopped)--    free (AwaitPF f ff) =-      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)---    awaitIt f _ Feed (Event x) = proc _ ->-      do-        (evy, stp) <- fit (f x) -< ()-        returnA -< (Feed, evy, ProcessA stp)--    awaitIt _ ff Feed End = proc _ ->-      do-        (evy, stp) <- fit ff -< ()-        returnA -< (Feed, evy, ProcessA stp)--    awaitIt _ ff Sweep End = proc _ ->-      do-        (evy, stp) <- fit ff -< ()-        returnA -< (if not $ isNoEvent evy then Feed else Suspend, evy, ProcessA stp)--    awaitIt f ff ph evx = proc _ ->-        returnA -< (ph `mappend` Suspend, NoEvent, -                    ProcessA $ arr (uncurry (awaitIt f ff)) >>> proc pc -> pc -<< ())---repeatedlyT :: (Monad m, ArrowApply a) => -              (forall b. m b -> a () b) ->-              PlanT i o m r -> -              ProcessA a (Event i) (Event o)--repeatedlyT f pl = constructT f $ forever pl----- for pure-construct :: ArrowApply a =>-             Plan i o t -> -             ProcessA a (Event i) (Event o)-construct pl = constructT (ary0 unArrowMonad) pl--repeatedly :: ArrowApply a =>-              Plan i o t -> -              ProcessA a (Event i) (Event o)-repeatedly pl = construct $ forever pl

@@ -1,23 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs #-}--module-    Control.Arrow.Machine.Plan.Internal-where--import qualified Control.Monad.Trans.Free as F-import qualified Control.Monad.Trans.Free.Church as F--data PlanF i o a where-  AwaitPF :: (i->a) -> a -> PlanF i o a-  YieldPF :: o -> a -> PlanF i o a-  StopPF :: PlanF i o a--instance (Functor (PlanF i o)) where-  fmap g (AwaitPF f ff) = AwaitPF (g . f) (g ff)-  fmap g (YieldPF x r) = YieldPF x (g r)-  fmap g StopPF = StopPF---type PlanT i o m a = F.FT (PlanF i o) m a-type Plan i o a = forall m. Monad m => PlanT i o m a

@@ -1,296 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Arrows #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE MultiWayIf #-}--module-    Control.Arrow.Machine.Running-      (-        -- * Run at once.-        run,-        runOn,-        run_,-        -- * Run step-by-step.-        ExecInfo(..),-        stepRun,-        stepYield-      )-where--import Control.Arrow-import Control.Applicative (Alternative (..))-import Control.Monad.State-import Control.Monad.Writer-import Data.Monoid (Monoid (..), Endo(..), appEndo)-import Data.Maybe (fromMaybe)--import Control.Arrow.Machine.ArrowUtil-import Control.Arrow.Machine.Types-import Control.Arrow.Machine.Event-import Control.Arrow.Machine.Event.Internal (Event(..))-------- Utilities----while_ ::-    Monad m =>-    m Bool -> m a -> m ()-while_ cond body =-  do-    b <- cond-    if b-        then body >> while_ cond body-        else return ()---- | Monoid wrapper-data WithEnd r = WithEnd { -    getRWE :: r,-    getContWE :: Bool-  }--instance-    Monoid r => Monoid (WithEnd r)-  where-    mempty = WithEnd mempty True-    WithEnd x True `mappend` WithEnd y b = WithEnd (x `mappend` y) b-    mx@(WithEnd x False) `mappend` _ = mx-------- Running Monad (To be exported)----data RunInfo a i o m = RunInfo {-    freezeRI :: ProcessA a i o,-    getInputRI :: i,-    getPaddingRI :: i,-    getPhaseRI :: Phase,-    getFitRI :: forall p q. a p q -> p -> m q-}--type RM a i o m = StateT (RunInfo a i o m) m--runRM ::-    (Monad m, ArrowApply a) =>-    (forall p q. a p q -> p -> m q) ->-    ProcessA a (Event i) o ->-    RM a (Event i) o m x ->-    m x-runRM f pa mx = -    evalStateT mx $ -        RunInfo {-            freezeRI = pa,-            getInputRI = NoEvent,-            getPaddingRI = NoEvent,-            getPhaseRI = Sweep,-            getFitRI = f-          }----feed_ :: -    Monad m => -    i -> i -> RM a i o m Bool-feed_ input padding =-  do-    ph <- gets getPhaseRI-    if ph == Suspend-        then-          do-            ri <- get-            put $ ri {-                getInputRI = input,-                getPaddingRI = padding,-                getPhaseRI = Feed-              }-            return True-        else-            return False--feed :: -    Monad m => -    i -> RM a (Event i) o m Bool-feed x = feed_ (Event x) NoEvent---finalizeE :: -    Monad m => -    RM a (Event i) o m Bool-finalizeE = feed_ End End---freeze ::-    Monad m =>-    RM a i o m (ProcessA a i o)-freeze = gets freezeRI-    --sweep :: -    Monad m =>-    RM a i o m o-sweep =-  do-    pa <- freeze-    fit <- gets getFitRI-    ph <- gets getPhaseRI-    x <- if ph == Feed-        then gets getInputRI-        else gets getPaddingRI-    -    (ph', y, pa') <- lift $ fit (step pa) (ph, x)-    -    ri <- get-    put $ ri {-        freezeRI = -            pa',-        getPhaseRI = -            if ph' == Feed then Sweep else ph'-      }--    return y---sweepAll :: -    (ArrowApply a, Monoid r, Monad m) =>-    (o->r) ->-    WriterT (WithEnd r) (RM a i (Event o) m) ()-sweepAll outpre = -        while_ -            ((not . (== Suspend)) `liftM` lift (gets getPhaseRI)) $-          do-            evx <- lift sweep-            case evx-              of-                Event x ->-                    tell (WithEnd (outpre x) True)-                NoEvent ->-                    return ()-                End ->-                    tell (WithEnd mempty False)----- | Run a machine with results concatenated in terms of a monoid.-runOn ::-    (ArrowApply a, Monoid r) =>-    (c -> r) ->-    ProcessA a (Event b) (Event c) ->-    a [b] r-runOn outpre pa0 = unArrowMonad $ \xs ->-  do-    wer <- runRM arrowMonad pa0 $ execWriterT $ -      do-        go xs-        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) =-      do-        lift $ feed x-        go xs----- | Run a machine.-run :: -    ArrowApply a => -    ProcessA a (Event b) (Event c) -> -    a [b] [c]-run pa = -    runOn (\x -> Endo (x:)) pa >>>-    arr (appEndo `flip` [])---- | Run a machine discarding all results.-run_ :: -    ArrowApply a => -    ProcessA a (Event b) (Event c) -> -    a [b] ()-run_ pa = -    runOn (const ()) pa----- | Represents return values and informations of step executions.-data ExecInfo fa =-    ExecInfo-      {-        yields :: fa, -- [a] or Maybe a-        hasConsumed :: Bool,-        hasStopped :: Bool-      }-    deriving (Eq, Show)--instance-    Alternative f => Monoid (ExecInfo (f a))-  where-    mempty = ExecInfo empty False False-    ExecInfo y1 c1 s1 `mappend` ExecInfo y2 c2 s2 = -        ExecInfo (y1 <|> y2) (c1 || c2) (s1 || s2)----- | Execute until an input consumed and the machine suspended.-stepRun :: -    ArrowApply a =>-    ProcessA a (Event b) (Event c) ->-    a b (ExecInfo [c], ProcessA a (Event b) (Event c))--stepRun pa0 = unArrowMonad $ \x ->-  do-    (pa, wer)  <- runRM arrowMonad pa0 $ runWriterT $ -      do-        sweepAll singleton-        lift $ feed x-        sweepAll singleton-        lift $ freeze-    return $ (retval wer, pa)--  where-    singleton x = Endo (x:)--    retval WithEnd {..} = ExecInfo {-        yields = appEndo getRWE [], -        hasConsumed = True, -        hasStopped = not getContWE-      }---- | Execute until an output produced.-stepYield :: -    ArrowApply a =>-    ProcessA a (Event b) (Event c) ->-    a b (ExecInfo (Maybe c), ProcessA a (Event b) (Event c))--stepYield pa0 = unArrowMonad $ \x -> runRM arrowMonad pa0 $ evalStateT `flip` mempty $-  do-    go x-    r <- get-    pa <- lift freeze-    return (r, pa)--  where -    go x =-      do-        csmd <- lift $ feed x-        modify $ \ri -> ri { hasConsumed = csmd }-                             -        evo <- lift sweep-        -        case evo-          of-            Event y ->-              do-                modify $ \ri -> ri { yields = Just y }-    -            NoEvent ->-              do-                csmd <- gets hasConsumed-                if csmd then return () else go x--            End ->-                modify $ \ri -> ri { hasStopped = True }

@@ -1,221 +1,1171 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}--module-    Control.Arrow.Machine.Types-    -- This file includes internals. Export definitions is at ../Machine.hs-where--import qualified Control.Category as Cat-import Data.Monoid (Monoid(..))-import Data.Profunctor (Profunctor, dimap)-import Control.Arrow.Operations (ArrowReader(..))-import Control.Arrow.Transformer.Reader (runReader, ArrowAddReader(..))-import Control.Arrow----- | To get multiple outputs by one input, the `Phase` parameter is introduced.------ Once a value `Feed`ed, the machine is `Sweep`ed until it `Suspend`s.-data Phase = Feed | Sweep | Suspend deriving (Eq, Show)--instance -    Monoid Phase -  where-    mempty = Sweep--    mappend Feed _ = Feed-    mappend _ Feed = Feed-    mappend Suspend _ = Suspend-    mappend _ Suspend = Suspend-    mappend Sweep Sweep = Sweep---type StepType a b c = a (Phase, b) (Phase, c, ProcessA a b c) ---- | The stream transducer arrow.------ To construct `ProcessA` instances, use `Control.Arrow.Machine.Plan.Plan`,--- `arr`, functions declared in `Control.Arrow.Machine.Utils`,--- or arrow combinations of them.------ May use `ArrowChoice` and `ArrowLoop` instance too.--- but there is a limitation that `loop` cannot propagate `Event`s to upstream.--- In such case, use `Control.Arrow.Machine.Utils.feedback` instead.-data ProcessA a b c = ProcessA { -      step :: StepType a b c-    }--fit :: (Arrow a, Arrow a') => -       (forall p q. a p q -> a' p q) -> -       ProcessA a b c -> ProcessA a' b c-fit f (ProcessA af) = ProcessA $ f af >>> arr mod-  where-    mod (ph, y, next) = (ph, y, fit f next)---instance-    Arrow a => Profunctor (ProcessA a)-  where-    dimap f g pa = ProcessA $ dimapStep f g (step pa)-    {-# INLINE dimap #-}--dimapStep :: Arrow a => -             (b->c)->(d->e)->-             StepType a c d -> StepType a b e-dimapStep f g stp = proc (ph, x) ->-  do-    (ph', y, pa') <- stp -< (ph, f x)-    returnA -< (ph', g y, dimap f g pa')-{-# INLINE [1] dimapStep #-}---instance-    ArrowApply a => Cat.Category (ProcessA a)-  where-    id = ProcessA (arrStep id)-    {-# INLINE id #-}-    g . f = ProcessA $ compositeStep (step f) (step g)-    {-# INLINE (.) #-}---instance -    ArrowApply a => Arrow (ProcessA a)-  where-    arr = ProcessA . arrStep-    {-# INLINE arr #-}--    first pa = ProcessA $ proc (ph, (x, d)) ->-      do-        (ph', y, pa') <- step pa -< (ph, x)-        returnA -< (ph' `mappend` Suspend, (y, d), first pa')-    {-# INLINE first #-}--    pa *** pb = ProcessA $ parStep (step pa) (step pb)-    {-# INLINE (***) #-}---parStep f g = proc (ph, (x1, x2)) ->-  do-    (ph1, y1, pa') <- f -< (ph, x1)-    (ph2, y2, pb') <- g -< (ph, x2)-    returnA -< (ph1 `mappend` ph2, (y1, y2), pa' *** pb')-{-# INLINE [1] parStep #-}--arrStep :: ArrowApply a => (b->c) -> StepType a b c-arrStep f = proc (ph, x) ->-    returnA -< (ph `mappend` Suspend, f x, ProcessA $ arrStep f)-{-# INLINE [1] arrStep #-}----- |Composition is proceeded by the backtracking strategy.-compositeStep :: ArrowApply a => -              StepType a b d -> StepType a d c -> StepType a b c-compositeStep f g = proc (ph, x) -> compositeStep' ph f g -<< (ph, x)-{-# INLINE [1] compositeStep #-}--compositeStep' :: ArrowApply a => -              Phase -> -              StepType a b d -> StepType a d c -> StepType a b c-             -compositeStep' Sweep f g = proc (_, x) ->-  do-    (ph1, r1, pa') <- f -< (Suspend, x)-    (ph2, r2, pb') <- g -<< (Sweep, r1)-    cont ph2 x -<< (r2, pa', pb')-  where-    cont Feed x = arr $ \(r, pa, pb) -> (Feed, r, pa >>> pb)-    cont Sweep x = arr $ \(r, pa, pb) -> (Sweep, r, pa >>> pb)-    cont Suspend x = proc (_, pa, pb) ->-      do-        (ph1, r1, pa') <- step pa -<< (Sweep, x)-        (ph2, r2, pb') <- step pb -<< (ph1, r1)-        returnA -< (ph2, r2, pa' >>> pb')--compositeStep' ph f g = proc (_, x) ->-  do-    (ph1, r1, pa') <- f -< (ph, x)-    (ph2, r2, pb') <- g -<< (ph1, r1)-    returnA -< (ph2, r2, pa' >>> pb')---- rules-{-# RULES-"ProcessA: concat/concat" -    forall f g h. compositeStep (compositeStep f g) h = compositeStep f (compositeStep g h)-"ProcessA: arr/arr"-    forall f g. compositeStep (arrStep f) (arrStep g) = arrStep (g . f)-"ProcessA: arr/*"-    forall f g. compositeStep (arrStep f) g = dimapStep f id g-"ProcessA: */arr"-    forall f g. compositeStep f (arrStep g) = dimapStep id g f-"ProcessA: dimap/dimap"-    forall f g h i j. dimapStep f j (dimapStep g i h)  = dimapStep (g . f) (j . i) h-"ProcessA: dimap/arr"-    forall f g h. dimapStep f h (arrStep g) = arrStep (h . g . f)-"ProcessA: par/par"-    forall f1 f2 g1 g2 h. compositeStep (parStep f1 f2) (compositeStep (parStep g1 g2) h) =-        compositeStep (parStep (compositeStep f1 g1) (compositeStep f2 g2)) h-"ProcessA: par/par-2"-    forall f1 f2 g1 g2. compositeStep (parStep f1 f2) (parStep g1 g2) =-        parStep (compositeStep f1 g1) (compositeStep f2 g2)-  #-}----instance-    ArrowApply a => ArrowChoice (ProcessA a)-  where-    left pa@(ProcessA a) = ProcessA $ proc (ph, eth) -> go ph eth -<< ()-      where-        go ph (Left x) = proc _ -> -          do-            (ph', y, pa') <- a -< (ph, x)-            returnA -< (ph', Left y, left pa')-        go ph (Right d) = proc _ -> -            returnA -< (ph `mappend` Suspend, Right d, left pa)--instance-    (ArrowApply a, ArrowLoop a) => ArrowLoop (ProcessA a)-  where-    loop pa = ProcessA $ proc (ph, x) -> loop $ go ph -<< x-      where-        go ph = proc (x, d) ->-          do -            (ph', (y, d'), pa') <- step pa -< (ph, (x, d))-            returnA -< ((ph', y, loop pa'), d')---instance-    (ArrowApply a, ArrowReader r a) => -    ArrowReader r (ProcessA a)-  where-    readState = ProcessA $ proc (ph, dm) ->-      do-        r <- readState -< dm-        returnA -< (ph `mappend` Suspend, r, readState)--    newReader pa = ProcessA $ proc (ph, (e, r)) ->-      do-        (ph', y, pa') <- newReader (step pa) -< ((ph, e), r)-        returnA -< (ph', y, newReader pa')--instance-    (ArrowApply a, ArrowApply a', ArrowAddReader r a a') =>-    ArrowAddReader r (ProcessA a) (ProcessA a')-  where-    liftReader pa = ProcessA $ proc (ph, x) ->-      do-        (ph', y, pa') <- (| liftReader (step pa -< (ph, x)) |)-        returnA -< (ph', y, liftReader pa)--    elimReader pra = -        ProcessA $ arr pre >>> elimReader (step pra) >>> arr post-      where-        pre (ph, (x, r)) = ((ph, x), r)-        post (ph, x, pra') = (ph, x, elimReader pra')+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}++module+    Control.Arrow.Machine.Types+      (+        -- * Basic types+        ProcessA(),++        Occasional' (..),+        Occasional (..),+        Event (),+        condEvent,+        filterEvent,+        evMap,+        +        -- * Plan monads+        PlanT,+        Plan,++        await,+        yield,+        stop,+        catchP,++        stopped,+        muted,++        -- * Constructing machines from plans+        constructT,+        repeatedlyT,++        construct,+        repeatedly,++        -- * Running machines (at once)+        run,+        runOn,+        run_,+        +        -- * Running machines (step-by-step)+        ExecInfo(..),+        stepRun,+        stepYield,++        -- * Primitive machines - switches+        -- | Switches inspired by Yampa library.+        -- Signature is almost same, but collection requirement is  not only 'Functor', +        -- but 'Tv.Traversable'. This is because of side effects.+        switch,+        dSwitch,+        rSwitch,+        drSwitch,+        kSwitch,+        dkSwitch,+        pSwitch,+        pSwitchB,+        rpSwitch,+        rpSwitchB,+        par,+        parB,++        +        -- * Primitive machines - other safe primitives+        fit,+        loop',+        +        -- * Primitive machines - unsafe+        fitEx,+        unsafeSteady,+        unsafeExhaust,+      )+where++import qualified Control.Category as Cat+import Data.Profunctor (Profunctor, dimap, rmap)+import Control.Arrow.Operations (ArrowReader(..))+import Control.Arrow.Transformer.Reader (ArrowAddReader(..))+import Control.Arrow+import Control.Monad hiding (join)+import Control.Monad.Trans+import Control.Monad.State hiding (join)+import Control.Monad.Writer hiding ((<>), join)+import Control.Applicative hiding (pure)+import qualified Control.Applicative as Ap+import Data.Foldable as Fd+import Data.Traversable as Tv+import Data.Semigroup (Semigroup, (<>))+import qualified Control.Monad.Trans.Free as F+import qualified Control.Monad.Trans.Free.Church as F+import Control.Arrow.Machine.ArrowUtil+import GHC.Exts (build)+++-- | To get multiple outputs by one input, the `Phase` parameter is introduced.+--+-- Once a value `Feed`ed, the machine is `Sweep`ed until it `Suspend`s.+data Phase = Feed | Sweep | Suspend deriving (Eq, Show)++instance +    Monoid Phase +  where+    mempty = Sweep++    mappend Feed _ = Feed+    mappend _ Feed = Feed+    mappend Suspend _ = Suspend+    mappend _ Suspend = Suspend+    mappend Sweep Sweep = Sweep+++type StepType a b c = a (Phase, b) (Phase, c, ProcessA a b c) ++-- | The stream transducer arrow.+--+-- To construct `ProcessA` instances, use `Control.Arrow.Machine.Plan.Plan`,+-- `arr`, functions declared in `Control.Arrow.Machine.Utils`,+-- or arrow combinations of them.+newtype ProcessA a b c = ProcessA { +      step :: StepType a b c+    }+++fitEx :: (Arrow a, Arrow a') =>+    (forall p q. a (p, b) (q, c) -> a' (p, b') (q, c')) ->+    ProcessA a b c ->+    ProcessA a' b' c'+fitEx f k = ProcessA $ proc (ph, x) ->+  do+    ((ph', k'), y) <- f (step k >>> arr (\(ph', y, k') -> ((ph', k'), y))) -< (ph, x)+    returnA -< (ph', y, fitEx f k')+++fit :: (Arrow a, Arrow a') => +       (forall p q. a p q -> a' p q) -> +       ProcessA a b c -> ProcessA a' b c+fit f = fitEx f+++loop' :: ArrowApply a =>+    d ->+    ProcessA a (b, d) (c, d) ->+    ProcessA a b c+loop' i pa = ProcessA $ proc (ph, x) ->+  do+    (ph', (y, n), pa') <- step pa -< (ph, (x, i))+    returnA -< (ph', y, loop' n pa')++instance+    Arrow a => Profunctor (ProcessA a)+  where+    dimap f g pa = ProcessA $ dimapStep f g (step pa)+    {-# INLINE dimap #-}++dimapStep :: Arrow a => +             (b->c)->(d->e)->+             StepType a c d -> StepType a b e+dimapStep f g stp = proc (ph, x) ->+  do+    (ph', y, pa') <- stp -< (ph, f x)+    returnA -< (ph', g y, dimap f g pa')+{-# NOINLINE dimapStep #-}++instance+    Arrow a => Functor (ProcessA a i)+  where+    fmap = rmap++instance+    ArrowApply a => Applicative (ProcessA a i)+  where+    pure = arr . const+    pf <*> px = (pf &&& px) >>> arr (uncurry ($))++      +instance+    ArrowApply a => Cat.Category (ProcessA a)+  where+    id = ProcessA idStep+    {-# INLINE id #-}+    g . f = ProcessA $ compositeStep (step f) (step g)+    {-# INLINE (.) #-}+++instance +    ArrowApply a => Arrow (ProcessA a)+  where+    arr = ProcessA . arrStep+    {-# INLINE arr #-}++    first pa = ProcessA $ parStep (step pa) idStep+    {-# INLINE first #-}++    second pa = ProcessA $ parStep idStep (step pa)+    {-# INLINE second #-}++    pa *** pb = ProcessA $ parStep (step pa) (step pb)+    {-# INLINE (***) #-}+++parStep :: ArrowApply a =>+    StepType a b c ->+    StepType a d e ->+    StepType a (b, d) (c, e)+parStep f g = proc (ph, (x1, x2)) ->+  do+    (ph1, y1, pa') <- f -< (ph, x1)+    (ph2, y2, pb') <- g -< (ph, x2)+    returnA -< (ph1 `mappend` ph2, (y1, y2), pa' *** pb')+{-# NOINLINE parStep #-}++idStep :: ArrowApply a => StepType a b b+idStep = proc (ph, x) ->+    returnA -< (ph `mappend` Suspend, x, ProcessA $ idStep)+{-# NOINLINE idStep #-}++arrStep :: ArrowApply a => (b->c) -> StepType a b c+arrStep f = proc (ph, x) ->+    returnA -< (ph `mappend` Suspend, f x, ProcessA $ arrStep f)+{-# NOINLINE arrStep #-}+++-- |Composition is proceeded by the backtracking strategy.+compositeStep :: ArrowApply a => +              StepType a b d -> StepType a d c -> StepType a b c+compositeStep f g = proc (ph, x) -> compositeStep' ph f g -<< (ph, x)+{-# NOINLINE compositeStep #-}++compositeStep' :: ArrowApply a => +              Phase -> +              StepType a b d -> StepType a d c -> StepType a b c+             +compositeStep' Sweep f g = proc (_, x) ->+  do+    (_, r1, pa') <- f -< (Suspend, x)+    (ph2, r2, pb') <- g -<< (Sweep, r1)+    cont ph2 -<< (r2, pa', pb', x)+  where+    cont Feed = arr $ \(r, pa, pb, _) -> (Feed, r, pa >>> pb)+    cont Sweep = arr $ \(r, pa, pb, _) -> (Sweep, r, pa >>> pb)+    cont Suspend = proc (r, pa, pb, x) ->+      do+        (ph1, r1, pa') <- step pa -<< (Sweep, x)+        (ph2, r2, pb') <-+            (if ph1 == Feed+                then+                  step pb+                else+                  arr $ const (Suspend, r, pb))+                      -<< (ph1, r1)+        returnA -< (ph2, r2, pa' >>> pb')++compositeStep' ph f g = proc (_, x) ->+  do+    (ph1, r1, pa') <- f -< (ph, x)+    (ph2, r2, pb') <- g -<< (ph1, r1)+    returnA -< (ph2, r2, pa' >>> pb')++-- rules+{-# RULES+"ProcessA: id/*"+    forall g. compositeStep idStep g = g+"ProcessA: */id"+    forall f. compositeStep f idStep = f++"ProcessA: concat/concat" +    forall f g h. compositeStep (compositeStep f g) h = compositeStep f (compositeStep g h)++"ProcessA: dimap/dimap"+    forall f g h i j. dimapStep f j (dimapStep g i h)  = dimapStep (g . f) (j . i) h+"ProcessA: dimap/arr"+    forall f g h. dimapStep f h (arrStep g) = arrStep (h . g . f)++"ProcessA: arr***/par"+    forall f1 f2 g1 g2 h. compositeStep (parStep f1 (arrStep f2)) (compositeStep (parStep g1 g2) h) =+        compositeStep (parStep (compositeStep f1 g1) (dimapStep f2 id g2)) h+"ProcessA: arr***/par-2"+    forall f1 f2 g1 g2. compositeStep (parStep f1 (arrStep f2)) (parStep g1 g2) =+        parStep (compositeStep f1 g1) (dimapStep f2 id g2)+"ProcessA: par/***arr"+    forall f1 f2 g1 g2 h. compositeStep (parStep f1 f2) (compositeStep (parStep (arrStep g1) g2) h) =+        compositeStep (parStep (dimapStep id g1 f1) (compositeStep f2 g2)) h+"ProcessA: par/***arr-2"+    forall f1 f2 g1 g2. compositeStep (parStep f1 f2) (parStep (arrStep g1) g2) =+        parStep (dimapStep id g1 f1) (compositeStep f2 g2)++"ProcessA: first/par"+    forall f1 g1 g2 h. compositeStep (parStep f1 idStep) (compositeStep (parStep g1 g2) h) =+        compositeStep (parStep (compositeStep f1 g1) g2) h+"ProcessA: first/par-2"+    forall f1 g1 g2. compositeStep (parStep f1 idStep) (parStep g1 g2) =+        parStep (compositeStep f1 g1) g2+"ProcessA: par/second"+    forall f1 f2 g2 h. compositeStep (parStep f1 f2) (compositeStep (parStep idStep g2) h) =+        compositeStep (parStep f1 (compositeStep f2 g2)) h+"ProcessA: par/second-2"+    forall f1 f2 g2. compositeStep (parStep f1 f2) (parStep idStep g2) =+        parStep f1 (compositeStep f2 g2)++"ProcessA: arr/arr"+    forall f g h. compositeStep (arrStep f) (compositeStep (arrStep g) h) =+        compositeStep (arrStep (g . f)) h+"ProcessA: arr/arr-2"+    forall f g. compositeStep (arrStep f) (arrStep g) = arrStep (g . f)+"ProcessA: arr/*" [1]+    forall f g. compositeStep (arrStep f) g = dimapStep f id g+"ProcessA: */arr" [1]+    forall f g. compositeStep f (arrStep g) = dimapStep id g f+"ProcessA: arr***arr" [0]+    forall f g. parStep (arrStep f) (arrStep g) = arrStep (f *** g)+  #-}++instance+    ArrowApply a => ArrowChoice (ProcessA a)+  where+    left pa@(ProcessA a) = ProcessA $ proc (ph, eth) -> go ph eth -<< ()+      where+        go ph (Left x) = proc _ -> +          do+            (ph', y, pa') <- a -< (ph, x)+            returnA -< (ph', Left y, left pa')+        go ph (Right d) = proc _ -> +            returnA -< (ph `mappend` Suspend, Right d, left pa)++instance+    (ArrowApply a, ArrowLoop a) => ArrowLoop (ProcessA a)+  where+    loop = fitEx (\f -> loop (lp f))+      where+        lp f = proc ((p, x), d) ->+          do+            (q, (y, d')) <- f -< (p, (x, d))+            returnA -< ((q, y), d')+++instance+    (ArrowApply a, ArrowReader r a) => +    ArrowReader r (ProcessA a)+  where+    readState = ProcessA $ proc (ph, dm) ->+      do+        r <- readState -< dm+        returnA -< (ph `mappend` Suspend, r, readState)++    newReader = fitEx nr+      where+        nr f = proc (p, (x, r)) -> newReader f -< ((p, x), r)++instance+    (ArrowApply a, ArrowApply a', ArrowAddReader r a a') =>+    ArrowAddReader r (ProcessA a) (ProcessA a')+  where+    liftReader pa = ProcessA $ proc (ph, x) ->+      do+        (ph', y, pa') <- (| liftReader (step pa -< (ph, x)) |)+        returnA -< (ph', y, liftReader pa')++    elimReader pra = +        ProcessA $ arr pre >>> elimReader (step pra) >>> arr post+      where+        pre (ph, (x, r)) = ((ph, x), r)+        post (ph, x, pra') = (ph, x, elimReader pra')+++    +data Event a = Event a | NoEvent | End deriving (Eq, Show)+++instance +    Functor Event +  where+    fmap _ NoEvent = NoEvent+    fmap _ End = End+    fmap f (Event x) = Event (f x)+++instance+    Semigroup a => Monoid (Event a)+  where+    mempty = End+    Event x `mappend` Event y = Event (x <> y)+    Event x `mappend` _ = Event x+    _ `mappend` Event y = Event y+    NoEvent `mappend` _ = NoEvent+    _ `mappend` NoEvent = NoEvent+    _ `mappend` _ = End++++-- | Signals that can be absent(`NoEvent`) or end.+-- For composite structure, `collapse` can be defined as monoidal sum of all member occasionals.+class +    Occasional' a+  where+    collapse :: a -> Event ()++-- | Occasional signals with creation methods.+class+    Occasional' a => Occasional a+  where+    noEvent :: a+    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+    collapse (x, y) = collapse x `mappend` collapse y++instance+    (Occasional a, Occasional b) => Occasional (a, b)+  where+    noEvent = (noEvent, noEvent)+    end = (end, end)++instance +    Occasional' (Event a)+  where+    collapse = (() <$)++instance +    Occasional (Event a)+  where+    noEvent = NoEvent+    end = End++++-- TODO: テスト+condEvent :: Bool -> Event a -> Event a+condEvent _ End = End+condEvent True ev = ev+condEvent False _ = NoEvent++-- TODO: テスト+filterEvent :: (a -> Bool) -> Event a -> Event a+filterEvent cond ev@(Event x) = condEvent (cond x) ev+filterEvent _ ev = ev++-- | Alias of "arr . fmap"+--+-- While "ProcessA a (Event b) (Event c)" means a transducer from b to c,+-- function b->c can be lifted into a transducer by fhis function.+-- +-- But in most cases you needn't call this function in proc-do notations,+-- because `arr`s are completed automatically while desugaring.+--+-- For example,+--+-- @+-- proc x -> returnA -\< f \<$\> x+-- @+--+-- is equivalent to+--+-- @+-- evMap f+-- @            +evMap ::  Arrow a => (b->c) -> a (Event b) (Event c)+evMap = arr . fmap+++stopped :: +    (ArrowApply a, Occasional c) => ProcessA a b c+stopped = arr (const end)+++muted ::+    (ArrowApply a, Occasional' b, Occasional c) => ProcessA a b c+muted = proc x ->+  do+    rSwitch (arr $ const noEvent) -< ((), stopped <$ collapse x)++++data PlanF i o a where+  AwaitPF :: (i->a) -> a -> PlanF i o a+  YieldPF :: o -> a -> PlanF i o a+  StopPF :: PlanF i o a++instance (Functor (PlanF i o)) where+  fmap g (AwaitPF f ff) = AwaitPF (g . f) (g ff)+  fmap g (YieldPF x r) = YieldPF x (g r)+  fmap _ StopPF = StopPF+++type PlanT i o m a = F.FT (PlanF i o) m a+type Plan i o a = forall m. Monad m => PlanT i o m a+++yield :: o -> Plan i o ()+yield x = F.liftF $ YieldPF x ()++await :: Plan i o i+await = F.FT $ \pure free -> free (AwaitPF pure (free StopPF))++stop :: Plan i o a+stop = F.liftF $ StopPF+++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+  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+++++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+  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, _) -> +        case ph of+          Suspend -> +              (ph `mappend` Suspend,+               if isEnd evx then End else NoEvent,+               ProcessA $ retArrow ph' evx cont)+          _ -> +              (ph `mappend` ph', evx, cont)++    pure _ = return $ (End, retArrow Suspend End stopped)++    free (AwaitPF f ff) =+      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)+++    awaitIt f _ Feed (Event x) = proc _ ->+      do+        (evy, stp) <- fit0 (f x) -< ()+        returnA -< (Feed, evy, ProcessA stp)++    awaitIt _ ff Feed End = proc _ ->+      do+        (evy, stp) <- fit0 ff -< ()+        returnA -< (Feed, evy, ProcessA stp)++    awaitIt _ ff Sweep End = proc _ ->+      do+        (evy, stp) <- fit0 ff -< ()+        returnA -< (if not $ isNoEvent evy then Feed else Suspend, evy, ProcessA stp)++    awaitIt f ff ph _ = proc _ ->+        returnA -< (ph `mappend` Suspend, NoEvent, +                    ProcessA $ arr (uncurry (awaitIt f ff)) >>> proc pc -> pc -<< ())+++repeatedlyT :: (Monad m, ArrowApply a) => +              (forall b. m b -> a () b) ->+              PlanT i o m r -> +              ProcessA a (Event i) (Event o)++repeatedlyT f pl = constructT f $ forever pl+++-- for pure+construct :: ArrowApply a =>+             Plan i o t -> +             ProcessA a (Event i) (Event o)+construct pl = constructT (ary0 unArrowMonad) pl++repeatedly :: ArrowApply a =>+              Plan i o t -> +              ProcessA a (Event i) (Event o)+repeatedly pl = construct $ forever pl+++--+-- Switches+--+evMaybePh :: b -> (a->b) -> (Phase, Event a) -> b+evMaybePh _ f (Feed, Event x) = f x+evMaybePh _ f (Sweep, Event x) = f x+evMaybePh d _ _ = d+++{-+type KSwitchLike a b c t =+    ProcessA a b c ->+    ProcessA a (b, ) (Event t) ->+    (ProcessA a b c -> t -> ProcessA a b c) ->+    ProcessA a b c++switchCore ::+    ArrowApply a =>+    KSwitchLike a b c t ->+    ProcessA a b (c, Event t) -> +    (t -> ProcessA a b c) ->+    ProcessA a b c+-}+switchCore ::+    (Arrow cat, Arrow a2, Arrow cat1, Occasional t3) =>+    (t4+     -> a2 (t5, (t6, c1)) c1+     -> (t -> t1 -> cat a (t2, t3))+     -> cat1 a1 (c, b))+     -> t4 -> (t1 -> cat a t2) -> cat1 a1 c++switchCore sw cur cont = sw cur (arr test) cont' >>> arr fst+  where+    test (_, (_, evt)) = evt+    cont' _ t = cont t >>> arr (\y -> (y, noEvent))++switch :: +    ArrowApply a => +    ProcessA a b (c, Event t) -> +    (t -> ProcessA a b c) ->+    ProcessA a b c++switch = switchCore kSwitch+++dSwitch :: +    ArrowApply a => +    ProcessA a b (c, Event t) -> +    (t -> ProcessA a b c) ->+    ProcessA a b c++dSwitch = switchCore dkSwitch+++rSwitch :: +    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)+++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)))++kSwitch ::+    ArrowApply a => +    ProcessA a b c ->+    ProcessA a (b, c) (Event t) ->+    (ProcessA a b c -> t -> ProcessA a b c) ->+    ProcessA a b c++kSwitch sf test k = ProcessA $ proc (ph, x) ->+  do+    (ph', y, sf') <- step sf -< (ph, x)+    (phT, evt, test') <- step test -< (ph', (x, y))++    evMaybePh +        (arr $ const (phT, y, kSwitch sf' test' k)) +        (step . (k sf'))+        (phT, evt)+            -<< (phT, x)+++dkSwitch ::+    ArrowApply a => +    ProcessA a b c ->+    ProcessA a (b, c) (Event t) ->+    (ProcessA a b c -> t -> ProcessA a b c) ->+    ProcessA a b c++dkSwitch sf test k = ProcessA $ proc (ph, x) ->+  do+    (ph', y, sf') <- step sf -< (ph, x)+    (phT, evt, test') <- step test -< (ph', (x, y))+    +    let+        nextA t = k sf' t+        nextB = dkSwitch sf' test' k++    returnA -< (phT, y, evMaybePh nextB nextA (ph, evt))+++broadcast :: +    Functor col =>+    b -> col sf -> col (b, sf)++broadcast x sfs = fmap (\sf -> (x, sf)) sfs+++par ::+    (ArrowApply a, Tv.Traversable col) =>+    (forall sf. (b -> col sf -> col (ext, sf))) ->+    col (ProcessA a ext c) ->+    ProcessA a b (col c)++par r sfs = ProcessA $ parCore r sfs >>> arr cont+  where+    cont (ph, ys, sfs') = (ph, ys, par r sfs')++parB ::+    (ArrowApply a, Tv.Traversable col) =>+    col (ProcessA a b c) ->+    ProcessA a b (col c)++parB = par broadcast++parCore ::+    (ArrowApply a, Tv.Traversable col) =>+    (forall sf. (b -> col sf -> col (ext, sf))) ->+    col (ProcessA a ext c) ->+    a (Phase, b) (Phase, col c, col (ProcessA a ext c))++parCore r sfs = proc (ph, x) ->+  do+    let input = r x sfs++    ret <- unwrapArrow (Tv.sequenceA (fmap (WrapArrow . appPh) input)) -<< ph++    let ph' = Fd.foldMap getPh ret+        zs = fmap getZ ret+        sfs' = fmap getSf ret++    returnA -< (ph', zs, sfs')++  where+    appPh (y, sf) = proc ph -> step sf -< (ph, y)++    getPh (ph, _, _) = ph+    getZ (_, z, _) = z+    getSf (_, _, sf) = sf+++pSwitch ::+    (ArrowApply a, Tv.Traversable col) =>+    (forall sf. (b -> col sf -> col (ext, sf))) ->+    col (ProcessA a ext c) ->+    ProcessA a (b, col c) (Event mng) ->+    (col (ProcessA a ext c) -> mng -> ProcessA a b (col c)) ->+    ProcessA a b (col c)++pSwitch r sfs test k = ProcessA $ proc (ph, x) ->+  do+    (ph', zs, sfs') <- parCore r sfs -<< (ph, x)+    (phT, evt, test') <- step test -< (ph', (x, zs))++    evMaybePh+        (arr $ const (ph' `mappend` phT, zs, pSwitch r sfs' test' k))+        (step . (k sfs') )+        (phT, evt)+            -<< (ph, x)++pSwitchB ::+    (ArrowApply a, Tv.Traversable col) =>+    col (ProcessA a b c) ->+    ProcessA a (b, col c) (Event mng) ->+    (col (ProcessA a b c) -> mng -> ProcessA a b (col c)) ->+    ProcessA a b (col c)++pSwitchB = pSwitch broadcast+++rpSwitch ::+    (ArrowApply a, Tv.Traversable col) =>+    (forall sf. (b -> col sf -> col (ext, sf))) ->+    col (ProcessA a ext c) ->+    ProcessA a (b, Event (col (ProcessA a ext c) -> col (ProcessA a ext c)))+        (col c)++rpSwitch r sfs = ProcessA $ proc (ph, (x, evCont)) ->+  do+    let sfsNew = evMaybePh sfs ($sfs) (ph, evCont)+    (ph', ws, sfs') <- parCore r sfsNew -<< (ph, x)+    returnA -< (ph' `mappend` Suspend, ws, rpSwitch r sfs')+++rpSwitchB ::+    (ArrowApply a, Tv.Traversable col) =>+    col (ProcessA a b c) ->+    ProcessA a (b, Event (col (ProcessA a b c) -> col (ProcessA a b c)))+        (col c)++rpSwitchB = rpSwitch broadcast++-- `dpSwitch` and `drpSwitch` are not implemented.+++--+-- Unsafe primitives+--++-- | Repeatedly call `p`.+--+-- How many times `p` is called is indefinite.+-- So `p` must satisfy the equation below;+--+-- @p &&& p === p >>> (id &&& id)@+unsafeSteady ::+    ArrowApply a =>+    a b c ->+    ProcessA a b c+unsafeSteady f =+    fitEx+        (\id' ->+            arr (\(p, x)->((p, ()), x)) >>>+            (id' *** f) >>>+            arr (\((q, ()), y)->(q, y)))+        Cat.id+      +    +-- | Repeatedly call `p`.+--    +-- How many times `p` is called is indefinite.+-- So `p` must satisfy the equation below;+--+-- @p &&& (p >>> arr null) === p &&& arr (const True)@+--+-- where+--+-- @null = getAll . foldMap (\_ -> All False)@+unsafeExhaust ::+    (ArrowApply a, Fd.Foldable f) =>+    a b (f c) ->+    ProcessA a b (Event c)+unsafeExhaust p =+    go >>> fork+  where+    go = ProcessA $ proc (ph, x) -> handle ph -<< x+    +    handle Suspend =+        arr $ const (Suspend, NoEvent, go)++    handle ph = proc x ->+      do+        ys <- p -< x+        let ph' = if nullFd ys then Suspend else Feed+        returnA -< (ph `mappend` ph', Event ys, go)++    fork = repeatedly $ await >>= Fd.mapM_ yield++    nullFd = getAll . Fd.foldMap (\_ -> All False)++++--+-- Running+--+--+-- Utilities+--+while_ ::+    Monad m =>+    m Bool -> m a -> m ()+while_ cond body =+  do+    b <- cond+    if b+        then body >> while_ cond body+        else return ()++-- | Monoid wrapper+data WithEnd r = WithEnd { +    getRWE :: r,+    getContWE :: Bool+  }++instance+    Monoid r => Monoid (WithEnd r)+  where+    mempty = WithEnd mempty True+    WithEnd x True `mappend` WithEnd y b = WithEnd (x `mappend` y) b+    mx@(WithEnd _ False) `mappend` _ = mx+++--+-- Running Monad (To be exported)+--+data RunInfo a i o m = RunInfo {+    freezeRI :: ProcessA a i o,+    getInputRI :: i,+    getPaddingRI :: i,+    getPhaseRI :: Phase,+    getFitRI :: forall p q. a p q -> p -> m q+  }++type RM a i o m = StateT (RunInfo a i o m) m++runRM ::+    (Monad m, ArrowApply a) =>+    (forall p q. a p q -> p -> m q) ->+    ProcessA a (Event i) o ->+    RM a (Event i) o m x ->+    m x+runRM f pa mx = +    evalStateT mx $ +        RunInfo {+            freezeRI = pa,+            getInputRI = NoEvent,+            getPaddingRI = NoEvent,+            getPhaseRI = Sweep,+            getFitRI = f+          }++++feed_ :: +    Monad m => +    i -> i -> RM a i o m Bool+feed_ input padding =+  do+    ph <- gets getPhaseRI+    if ph == Suspend+        then+          do+            ri <- get+            put $ ri {+                getInputRI = input,+                getPaddingRI = padding,+                getPhaseRI = Feed+              }+            return True+        else+            return False++feed :: +    Monad m => +    i -> RM a (Event i) o m Bool+feed x = feed_ (Event x) NoEvent+++{-+finalizeE :: +    Monad m => +    RM a (Event i) o m Bool+finalizeE = feed_ End End+-}++freeze ::+    Monad m =>+    RM a i o m (ProcessA a i o)+freeze = gets freezeRI+    ++sweep :: +    Monad m =>+    RM a i o m o+sweep =+  do+    pa <- freeze+    fit0 <- gets getFitRI+    ph <- gets getPhaseRI+    x <- if ph == Feed+        then gets getInputRI+        else gets getPaddingRI+    +    (ph', y, pa') <- lift $ fit0 (step pa) (ph, x)+    +    ri <- get+    put $ ri {+        freezeRI = +            pa',+        getPhaseRI = +            if ph' == Feed then Sweep else ph'+      }++    return y+++sweepAll :: +    (ArrowApply a, Monoid r, Monad m) =>+    (o->r) ->+    WriterT (WithEnd r) (RM a i (Event o) m) ()+sweepAll outpre = +        while_ +            ((not . (== Suspend)) `liftM` lift (gets getPhaseRI)) $+          do+            evx <- lift sweep+            case evx+              of+                Event x ->+                    tell (WithEnd (outpre x) True)+                NoEvent ->+                    return ()+                End ->+                    tell (WithEnd mempty False)+++-- | Run a machine with results concatenated in terms of a monoid.+runOn ::+    (ArrowApply a, Monoid r) =>+    (c -> r) ->+    ProcessA a (Event b) (Event c) ->+    a [b] r+runOn outpre pa0 = unArrowMonad $ \xs ->+  do+    wer <- runRM arrowMonad pa0 $ execWriterT $ +      do+        go xs+        _ <- 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) =+      do+        _ <- lift $ feed x+        go xs+++-- | Run a machine.+newtype Builder a = Builder {+    unBuilder :: forall b. (a -> b -> b) -> b -> b+  }+instance+    Monoid (Builder a)+  where+    mempty = Builder $ \_ e -> e+    Builder g `mappend` Builder f =+        Builder $ \c e -> g c (f c e)++run :: +    ArrowApply a => +    ProcessA a (Event b) (Event c) -> +    a [b] [c]+run pa = +    runOn (\x -> Builder $ \c e -> c x e) pa >>>+    arr (\b -> build (unBuilder b))++-- | Run a machine discarding all results.+run_ :: +    ArrowApply a => +    ProcessA a (Event b) (Event c) -> +    a [b] ()+run_ pa = +    runOn (const ()) pa+++-- | Represents return values and informations of step executions.+data ExecInfo fa =+    ExecInfo+      {+        yields :: fa, -- [a] or Maybe a+        hasConsumed :: Bool,+        hasStopped :: Bool+      }+    deriving (Eq, Show)++instance+    Alternative f => Monoid (ExecInfo (f a))+  where+    mempty = ExecInfo empty False False+    ExecInfo y1 c1 s1 `mappend` ExecInfo y2 c2 s2 = +        ExecInfo (y1 <|> y2) (c1 || c2) (s1 || s2)+++-- | Execute until an input consumed and the machine suspended.+stepRun :: +    ArrowApply a =>+    ProcessA a (Event b) (Event c) ->+    a b (ExecInfo [c], ProcessA a (Event b) (Event c))++stepRun pa0 = unArrowMonad $ \x ->+  do+    (pa, wer)  <- runRM arrowMonad pa0 $ runWriterT $ +      do+        sweepAll singleton+        _ <- lift $ feed x+        sweepAll singleton+        lift $ freeze+    return $ (retval wer, pa)++  where+    singleton x = Endo (x:)++    retval WithEnd {..} = ExecInfo {+        yields = appEndo getRWE [], +        hasConsumed = True, +        hasStopped = not getContWE+      }++-- | Execute until an output produced.+stepYield :: +    ArrowApply a =>+    ProcessA a (Event b) (Event c) ->+    a b (ExecInfo (Maybe c), ProcessA a (Event b) (Event c))++stepYield pa0 = unArrowMonad $ \x -> runRM arrowMonad pa0 $ evalStateT `flip` mempty $+  do+    go x+    r <- get+    pa <- lift freeze+    return (r, pa)++  where +    go x =+      do+        csmd <- lift $ feed x+        modify $ \ri -> ri { hasConsumed = csmd }+                             +        evo <- lift sweep+        +        case evo+          of+            Event y ->+              do+                modify $ \ri -> ri { yields = Just y }+    +            NoEvent ->+              do+                csmd' <- gets hasConsumed+                if csmd' then return () else go x++            End ->+                modify $ \ri -> ri { hasStopped = True }  

@@ -2,20 +2,18 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}  module     Control.Arrow.Machine.Utils       (         -- * AFRP-like utilities-        delay,         hold,         accum,         edge,         passRecent,         withRecent,-        feedback1,-        feedback,          -- * Switches         -- | Switches inspired by Yampa library.@@ -47,6 +45,7 @@         anytime,         par,         parB,+        now,         onEnd,         cycleDelay        )@@ -54,43 +53,24 @@  import Prelude hiding (filter) -import Data.Monoid (mappend, mconcat)-import Data.Tuple (swap)+import Data.Maybe (fromMaybe) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Foldable as Fd-import qualified Data.Traversable as Tv import qualified Control.Category as Cat-import Control.Monad.Reader (ask)-import Control.Monad (liftM, forever) import Control.Monad.Trans+import Control.Monad.State import Control.Arrow import Control.Arrow.Operations (ArrowState(..))-import Control.Arrow.Transformer.State (ArrowAddState(..))+import Control.Arrow.Transformer.State (ArrowAddState(..), StateArrow()) import Control.Applicative-import Debug.Trace -import Control.Arrow.Machine.Types-import Control.Arrow.Machine.Event-import Control.Arrow.Machine.Event.Internal (Event(..)) import Control.Arrow.Machine.ArrowUtil+import Control.Arrow.Machine.Types -import qualified Control.Arrow.Machine.Plan as Pl-import Control.Arrow.Machine.Exception   -delay ::-    (ArrowApply a, Occasional b) => ProcessA a b b -delay = join >>> delayImpl >>> split-  where-    delayImpl = Pl.repeatedly $-      do-        mx <- liftM Just Pl.await `catch` return Nothing-        Pl.yield noEvent-        maybe Pl.stop Pl.yield mx-- hold ::      ArrowApply a => b -> ProcessA a (Event b) b {-@@ -101,34 +81,36 @@ -} hold old = proc evx ->    do-    rSwitch (arr $ const old) -< ((), arr . const <$> evx)+    rSwitch (pure old) -< ((), pure <$> evx)  accum ::     ArrowApply a => b -> ProcessA a (Event (b->b)) b-accum old = ProcessA $ proc (ph, evf) ->-  do-    let new = fromEvent id evf old-    returnA -< (ph `mappend` Suspend, new, accum new)+accum x = switch (pure x &&& arr (($x)<$>)) accum'+  where+    accum' y = dSwitch (pure y &&& Cat.id) (const (accum y))+    edge ::      (ArrowApply a, Eq b) =>     ProcessA a b (Event b) -edge = ProcessA $ impl Nothing +edge = encloseState (unsafeExhaust impl) Nothing   where-    impl mvx = proc (ph, x) -> +    impl ::+        (ArrowApply a, Eq b) =>+        StateArrow (Maybe b) a b (Maybe b)+    impl = proc x ->       do-        let equals = maybe False (==x) mvx-            isActive = not $ ph == Suspend-        returnA -< if (not equals) && isActive-          then -            (Feed, Event x, ProcessA $ impl (Just x))-          else-            (ph `mappend` Suspend, NoEvent, ProcessA $ impl mvx)+        mprv <- fetch -< ()+        store -< Just x+        returnA -<+            case mprv+              of+                Just prv -> if prv == x then Nothing else Just x+                Nothing -> Just x  {-# DEPRECATED passRecent, withRecent "Use `hold` instead" #-} infixr 9 `passRecent`-infixr 9 `feedback`  passRecent ::      (ArrowApply a, Occasional o) =>@@ -156,316 +138,75 @@       _ -> returnA -< noEvent  -{-# DEPRECATED feedback1, feedback "Use Pump instead" #-}--- |Event version of loop (member of `ArrowLoop`).             --- Yielding an event to feedback output always creates a new process cycle.--- So be careful to make an infinite loop.-feedback1 ::-    (ArrowApply a, Occasional d) =>-    ProcessA a (e, AS d) (c, d) ->-    ProcessA a (AS e) c-feedback1 pa = ProcessA $ proc (ph, ase) ->-  do-    (ph', (y, d), pa') <- step pa -< (ph, (fromAS ase, toAS noEvent))-    returnA -< (ph', y, cont ph' d pa')-  where-    cont phPrev d paC -        | isOccasion d = ProcessA $ proc (ph, ase) ->-          do-            let -              (dIn, dOut, phPv2, phCur) = -                if ph == Suspend-                  then-                    (noEvent, const d, const phPrev, Suspend)-                  else-                    (d, id, id, ph `mappend` Feed) -            (ph', (y, d'), pa') <- step paC -< (phCur, (fromAS ase, toAS dIn))-            returnA -< (ph', y, cont (phPv2 ph') (dOut d') pa') -        | isEnd d && phPrev == Feed = ProcessA $ proc (ph, ase) ->-          do-            (ph', (y, _), pa') <- step paC -< (ph, (fromAS ase, toAS end))-            returnA -< (ph', y, proc asx -> arr fst <<< pa' -< (fromAS asx, toAS end)) -        | otherwise = feedback1 paC ---- |Artificially split into two arrow to use binary operator notation--- rather than banana brackets.-feedback ::-    (ArrowApply a, Occasional d) =>-    ProcessA a (e, AS d) b ->-    ProcessA a (e, AS b) (c, d) ->-    ProcessA a (AS e) c-feedback pa pb = -    feedback1 $ proc (ase, x) -> -      do -        y <- pa -< (ase, x)-        pb -< (ase, toAS y)-- ----- Switches----evMaybePh :: b -> (a->b) -> (Phase, Event a) -> b-evMaybePh _ f (Feed, Event x) = f x-evMaybePh _ f (Sweep, Event x) = f x-evMaybePh d _ _ = d---switchCore sw cur cont = sw cur (arr test) cont' >>> arr fst-  where-    test (_, (_, evt)) = evt-    cont' _ t = cont t >>> arr (\y -> (y, noEvent))--switch :: -    ArrowApply a => -    ProcessA a b (c, Event t) -> -    (t -> ProcessA a b c) ->-    ProcessA a b c--switch = switchCore kSwitch---dSwitch :: -    ArrowApply a => -    ProcessA a b (c, Event t) -> -    (t -> ProcessA a b c) ->-    ProcessA a b c--dSwitch = switchCore dkSwitch---rSwitch :: -    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)---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, next new eva)--  where-    next _ (Event af) = drSwitch af-    next af _ = drSwitch af---kSwitch ::-    ArrowApply a => -    ProcessA a b c ->-    ProcessA a (b, c) (Event t) ->-    (ProcessA a b c -> t -> ProcessA a b c) ->-    ProcessA a b c--kSwitch sf test k = ProcessA $ proc (ph, x) ->-  do-    (ph', y, sf') <- step sf -< (ph, x)-    (phT, evt, test') <- step test -< (ph', (x, y))--    evMaybePh -        (arr $ const (phT, y, kSwitch sf' test' k)) -        (step . (k sf'))-        (phT, evt)-            -<< (phT, x)---dkSwitch ::-    ArrowApply a => -    ProcessA a b c ->-    ProcessA a (b, c) (Event t) ->-    (ProcessA a b c -> t -> ProcessA a b c) ->-    ProcessA a b c--dkSwitch sf test k = ProcessA $ proc (ph, x) ->-  do-    (ph', y, sf') <- step sf -< (ph, x)-    (phT, evt, test') <- step test -< (ph', (x, y))-    -    let-        nextA t = k sf' t-        nextB = dkSwitch sf' test' k--    returnA -< (phT, y, evMaybe nextB nextA evt)---broadcast :: -    Functor col =>-    b -> col sf -> col (b, sf)--broadcast x sfs = fmap (\sf -> (x, sf)) sfs---par ::-    (ArrowApply a, Tv.Traversable col) =>-    (forall sf. (b -> col sf -> col (ext, sf))) ->-    col (ProcessA a ext c) ->-    ProcessA a b (col c)--par r sfs = ProcessA $ parCore r sfs >>> arr cont-  where-    cont (ph, ys, sfs') = (ph, ys, par r sfs')--parB ::-    (ArrowApply a, Tv.Traversable col) =>-    col (ProcessA a b c) ->-    ProcessA a b (col c)--parB = par broadcast--parCore ::-    (ArrowApply a, Tv.Traversable col) =>-    (forall sf. (b -> col sf -> col (ext, sf))) ->-    col (ProcessA a ext c) ->-    a (Phase, b) (Phase, col c, col (ProcessA a ext c))--parCore r sfs = proc (ph, x) ->-  do-    let input = r x sfs--    ret <- unwrapArrow (Tv.sequenceA (fmap (WrapArrow . appPh) input)) -<< ph--    let ph' = Fd.foldMap getPh ret-        zs = fmap getZ ret-        sfs' = fmap getSf ret--    returnA -< (ph', zs, sfs')--  where-    appPh (y, sf) = proc ph -> step sf -< (ph, y)--    getPh (ph, _, _) = ph-    getZ (_, z, _) = z-    getSf (_, _, sf) = sf---pSwitch ::-    (ArrowApply a, Tv.Traversable col) =>-    (forall sf. (b -> col sf -> col (ext, sf))) ->-    col (ProcessA a ext c) ->-    ProcessA a (b, col c) (Event mng) ->-    (col (ProcessA a ext c) -> mng -> ProcessA a b (col c)) ->-    ProcessA a b (col c)--pSwitch r sfs test k = ProcessA $ proc (ph, x) ->-  do-    (ph', zs, sfs') <- parCore r sfs -<< (ph, x)-    (phT, evt, test') <- step test -< (ph', (x, zs))--    evMaybePh-        (arr $ const (ph' `mappend` phT, zs, pSwitch r sfs' test' k))-        (step . (k sfs') )-        (phT, evt)-            -<< (ph, x)--pSwitchB ::-    (ArrowApply a, Tv.Traversable col) =>-    col (ProcessA a b c) ->-    ProcessA a (b, col c) (Event mng) ->-    (col (ProcessA a b c) -> mng -> ProcessA a b (col c)) ->-    ProcessA a b (col c)--pSwitchB = pSwitch broadcast---rpSwitch ::-    (ArrowApply a, Tv.Traversable col) =>-    (forall sf. (b -> col sf -> col (ext, sf))) ->-    col (ProcessA a ext c) ->-    ProcessA a (b, Event (col (ProcessA a ext c) -> col (ProcessA a ext c)))-        (col c)--rpSwitch r sfs = ProcessA $ proc (ph, (x, evCont)) ->-  do-    let sfsNew = evMaybePh sfs ($sfs) (ph, evCont)-    (ph', ws, sfs') <- parCore r sfsNew -<< (ph, x)-    returnA -< (ph' `mappend` Suspend, ws, rpSwitch r sfs')---rpSwitchB ::-    (ArrowApply a, Tv.Traversable col) =>-    col (ProcessA a b c) ->-    ProcessA a (b, Event (col (ProcessA a b c) -> col (ProcessA a b c)))-        (col c)--rpSwitchB = rpSwitch broadcast---- `dpSwitch` and `drpSwitch` are not implemented.----- -- State arrow -- peekState ::     (ArrowApply a, ArrowState s a) =>     ProcessA a e s-peekState = ProcessA $ proc (ph, dm) ->-  do-    s <- fetch -< dm-    returnA -< (ph `mappend` Suspend, s, peekState)+peekState = unsafeSteady fetch +-- Should be exported?+exposeState ::+    (ArrowApply a, ArrowApply a', ArrowAddState s a a') =>+    ProcessA a b c ->+    ProcessA a' (b, s) (c, s)+exposeState = fitEx es+  where+    es f = proc (p, (x, s)) ->+      do+        ((q, y), s') <- elimState f -< ((p, x), s)+        returnA -< (q, (y, s'))+ encloseState ::-    (ArrowApply a, ArrowAddState s a a') =>+    (ArrowApply a, ArrowApply a', ArrowAddState s a a') =>     ProcessA a b c ->     s ->     ProcessA a' b c-encloseState pa s = ProcessA $ proc (ph, x) ->-  do-    ((ph', y, pa'), s') <- elimState (step pa) -< ((ph, x), s)-    returnA -< (ph', y, encloseState pa' s')+encloseState pa s = loop' s (exposeState pa)  -- -- other utility arrow  -- |Make two event streams into one. -- Actually `gather` is more general and convenient;--- @---   ... <- tee -< (e1, e2)--- @+-- +-- @... \<- tee -\< (e1, e2)@+--  -- is equivalent to--- @---   ... <- gather -< [Left <$> e1, Right <$> e2]--- @+-- +-- @... \<- gather -\< [Left \<$\> e1, Right \<$\> e2]@+--  tee ::     ArrowApply a => ProcessA a (Event b1, Event b2) (Event (Either b1 b2))-tee = join >>> go-  where-    go = Pl.repeatedly $ -      do-        (evx, evy) <- Pl.await-        evMaybe (return ()) (Pl.yield . Left) evx-        evMaybe (return ()) (Pl.yield . Right) evy+tee = proc (e1, e2) -> gather -< [Left <$> e1, Right <$> e2]  + sample ::     ArrowApply a =>     ProcessA a (Event b1, Event b2) [b1]-sample = join >>> Pl.construct (go id) >>> hold []+{-+sample = join >>> construct (go id) >>> hold []   where     go l =        do-        (evx, evy) <- Pl.await `catch` return (NoEvent, End)+        (evx, evy) <- await `catch` return (NoEvent, End)         let l2 = evMaybe l (\x -> l . (x:)) evx         if isEnd evy           then           do-            Pl.yield $ l2 []-            Pl.stop+            yield $ l2 []+            stop           else             return ()-        evMaybe (go l2) (\_ -> Pl.yield (l2 []) >> go id) evy+        evMaybe (go l2) (\_ -> yield (l2 []) >> go id) evy+-}+sample = undefined  -- |Make multiple event channels into one. -- If simultaneous events are given, lefter one is emitted earlier.@@ -477,28 +218,31 @@     singleton x = x NonEmpty.:| []  -- | Provides a source event stream.--- A dummy input event stream is needed. +-- A dummy input event stream is needed.+--    -- @ --   run af [...] -- @+--    -- is equivalent to+-- -- @ --   run (source [...] >>> af) (repeat ()) -- @ source ::     (ArrowApply a, Fd.Foldable f) =>     f c -> ProcessA a (Event b) (Event c)-source l = Pl.construct $ Fd.mapM_ yd l+source l = construct $ Fd.mapM_ yd l   where-    yd x = Pl.await >> Pl.yield x+    yd x = await >> yield x  -- |Given an array-valued event and emit it's values as inidvidual events. fork ::     (ArrowApply a, Fd.Foldable f) =>     ProcessA a (Event (f b)) (Event b) -fork = Pl.repeatedly $ -    Pl.await >>= Fd.mapM_ Pl.yield+fork = repeatedly $ +    await >>= Fd.mapM_ yield  -- |Executes an action once per an input event is provided. anytime :: @@ -506,18 +250,22 @@     a b c ->     ProcessA a (Event b) (Event c) -anytime action = Pl.repeatedlyT (ary0 unArrowMonad) $+anytime action = repeatedlyT (ary0 unArrowMonad) $   do-    x <- Pl.await+    x <- await     ret <- lift $ arrowMonad action x-    Pl.yield ret+    yield ret  -filter cond = Pl.repeatedlyT (ary0 unArrowMonad) $+filter ::+    ArrowApply a =>+    a b Bool ->+    ProcessA a (Event b) (Event b)+filter cond = repeatedlyT (ary0 unArrowMonad) $   do-    x <- Pl.await+    x <- await     b <- lift $ arrowMonad cond x-    if b then Pl.yield x else return ()+    if b then yield x else return ()   echo :: @@ -526,23 +274,42 @@  echo = filter (arr (const True)) +now ::+    ArrowApply a =>+    ProcessA a b (Event ())+now = arr (const noEvent) >>> go+  where+    go = construct $+        yield () >> forever await  onEnd ::-    (ArrowApply a, Occasional b) =>+    (ArrowApply a, Occasional' b) =>     ProcessA a b (Event ())-onEnd = join >>> go+onEnd = arr collapse >>> go   where-    go = Pl.repeatedly $-        Pl.await `catch` (Pl.yield () >> Pl.stop)+    go = repeatedly $+        await `catchP` (yield () >> stop)      -- |Observe a previous value of a signal. -- Tipically used with rec statement. cycleDelay ::     ArrowApply a => ProcessA a b b-cycleDelay = ProcessA $ arr begin+cycleDelay =+    encloseState impl (Nothing, Nothing)   where-    begin (ph, x) = (ph `mappend` Suspend, x, ProcessA $ arr (go x))-    go cur (Sweep, x) = (Suspend, cur, ProcessA $ arr (go x))-    go cur (ph, _) = (ph, cur, ProcessA $ arr (go cur))+    impl :: ArrowApply a => ProcessA (StateArrow (Maybe b, Maybe b) a) b b+    impl = proc x ->+      do+        -- Load stored value when backtracking reaches here.+        (_, stored) <- peekState -< ()+        unsafeExhaust (app >>> arr (const Nothing)) -< appStore stored +        -- Repeat current value.+        (current, _) <- peekState -< ()+        let x0 = fromMaybe x current+        unsafeSteady store -< (Just x0, Just x)+        returnA -< x0++    appStore (Just x) = (proc _ -> store -< (Just x, Nothing), ())+    appStore _ = (Cat.id, ())     

@@ -16,6 +16,8 @@ import Control.Monad.State import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized) import Data.Maybe (fromJust)+import Data.Monoid (Sum(..), getSum, mappend)+import Data.Foldable (foldMap)   data ProcJoin = PjFst ProcGen | PjSnd ProcGen | PjSum ProcGen@@ -104,9 +106,8 @@  mkProcJ (PjFst pg) = arr fst mkProcJ (PjSnd pg) = arr snd-mkProcJ (PjSum pg) = arr go-  where-    go (evx, evy) = (+ fromEvent 0 evy) <$> evx+mkProcJ (PjSum pg) = proc (evx, evy) ->+    returnA -< getSum <$> foldMap (Sum <$>) [evx, evy]   stateProc :: MyProcT (Event a) (Event b) -> [a] -> ([b], [Int])@@ -159,13 +160,11 @@ instance     (TestOut a, TestOut b) => TestOut (a, b)   where-    output = output *** output >>> P.join >>> mc >>> P.split-      where-        mc = repeatedly $-          do-            (x, y) <- await-            yield x-            yield y+    output = proc (x1, x2) ->+      do+        y1 <- output -< x1+        y2 <- output -< x2+        gather -< [y1, y2]  instance     (TestIn a, TestIn b) => @@ -174,7 +173,7 @@     input = proc evx ->       do         -- 一個前の値で分岐してみる-        b <- hold True <<< delay -< +        b <- cycleDelay <<< hold True -<                 (\x -> x `mod` 2 == 0) <$> evx          if b@@ -182,7 +181,6 @@             arr Left <<< input -< evx           else             arr Right <<< input -< evx-  instance     (TestOut a, TestOut b) => TestOut (Either a b)

@@ -4,6 +4,8 @@ {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE FlexibleContexts #-}
+
 module
     Main
 where
@@ -37,7 +39,6 @@     plans
     utility
     switches
-    operator
     execution
     loopUtil
 
@@ -220,14 +221,16 @@       do
         it "can be used with rec statement(pure)" $
           let
-              a = proc x ->
+              a = proc ev ->
                 do
-                  rec l <- returnA -< evMaybe [] (:l) x
-                  returnA -< l <$ x
+                  x <- hold 0 -< ev
+                  rec l <- returnA -< x:l
+                  returnA -< l <$ ev
               result = fst $ stateProc a [2, 5]
             in
               take 3 (result!!1) `shouldBe` [5, 5, 5]
 
+{-
         it "can be used with rec statement(macninery)" $
           let
               mc = anytime Cat.id
@@ -254,6 +257,7 @@                         z <- hold 0 <<< delay -< y
                     returnA -< y
             run pa [1, 10] `shouldBe` [1, 2, 12, 24]
+-}
 
     describe "Rules for ArrowLoop" $
       do
@@ -340,7 +344,7 @@       do
         let pl2 =
               do
-                x <- await `catch` (yield 1 >> stop)
+                x <- await `catchP` (yield 1 >> stop)
                 yield x
                 y <- await 
                 yield y
@@ -351,12 +355,12 @@ 
 utility =
   do
-    describe "delay" $
+    describe "edge" $
       do
-        it "delays input" $
+        it "detects edges of input behaviour" $
           do
-            run (arr (\x->(x,x)) >>> first delay >>> arr fst) [0, 1, 2] `shouldBe` [0, 1, 2]
-            run (arr (\x->(x,x)) >>> first delay >>> arr snd) [0, 1, 2] `shouldBe` [0, 1, 2]
+            run (hold 0 >>> edge) [1, 1, 2, 2, 2, 3] `shouldBe` [0, 1, 2, 3]
+            run (hold 0 >>> edge) [0, 1, 1, 2, 2, 2, 3] `shouldBe` [0, 1, 2, 3]
 
     describe "accum" $
       do
@@ -382,29 +386,6 @@                     returnA -< x <$ ed
             run pa [1..4] `shouldBe` [4]
 
-    describe "sample" $
-      do
-        it "samples events in terms of the 2nd input." $
-          do
-            let
-                pa = proc evx ->
-                  do
-                    evy <- fork -< (\x -> [x, x]) <$> evx
-                    ys <- sample -< (evy, evx)
-                    ed <- onEnd -< evy
-                    outEv <- gather -< [() <$ evx, ed]
-                    returnA -< ys <$ outEv
-            Control.Monad.join (run pa [1..3]) `shouldBe` [1, 1, 2, 2, 3, 3]
-
-        it "correctly pushes simultaneous events into the same time." $
-          do
-            let 
-                pa = proc evx ->
-                  do
-                    l <- sample -< (evx, evx)
-                    returnA -< l <$ evx
-            run pa [1..3] `shouldBe` [[1], [2], [3]]
-
     describe "gather" $
       do
         it "correctly handles the end" $
@@ -470,46 +451,6 @@             ret `shouldBe` [7, 2, 6, 18, 21]
             retD `shouldBe` [7, 3, 6, 12, 21]
 
-
-operator = describe "Operators on ProcessA"$
-  do
-    describe "feedback" $
-      do
-        it "acts like local variable with hold." $
-          do
-            let 
-                pa = proc evx ->
-                  do
-                    (\evy -> hold 10 -< evy)
-                      `feedback` \y ->
-                      do
-                        returnA -< ((+y) <$> evx, (y+1) <$ evx)
-            run pa [1, 2, 3] `shouldBe` [11, 13, 15]
-
-        it "correctly handles stream end." $
-          do
-            let 
-                pa = proc x -> 
-                    (\asx -> returnA -< asx)
-                  `feedback` 
-                    (\asy -> returnA -< (asy::Event Int, x))
-                comp = mkProc (PgPush PgStop) >>> pa
-            stateProc comp [0, 0] `shouldBe` ([], [0])
-
-        it "correctly handles stream end.(2)" $
-          do
-            pendingWith "now many utilities behave incorrectly at the end of stream."
-{-
-            let pa = proc x -> (| feedback1 (\y -> returnA -< (y::Event Int, x)) |)
-            let comp = mkProc (PgPush PgStop) >>> pa >>> mkProc (PgDouble PgNop)
-            stateProc comp [0, 0] `shouldBe` ([], [0])
-
-        prop "delays the feedback input." $ \cond ->
-            let 
-                equiv = mkEquivTest cond
-              in
-                delay `equiv` proc x -> (| feedback1 (\y -> returnA -< (y::Event Int, x)) |)
--}
 
 execution = describe "Execution of ProcessA" $
     do