machinecell 3.3.2 → 4.0.0

raw patch · 23 files changed

+3103/−2534 lines, 23 filesdep +doctestdep ~arrowsdep ~basedep ~freePVP ok

version bump matches the API change (PVP)

Dependencies added: doctest

Dependency ranges changed: arrows, base, free, machinecell, mtl, profunctors, semigroups, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +25/−0
• machinecell.cabal +24/−7
• src/Control/Arrow/Machine.hs +77/−81
• src/Control/Arrow/Machine/Evolution.hs +83/−0
• src/Control/Arrow/Machine/Misc/Discrete.hs +55/−55
• src/Control/Arrow/Machine/Misc/Pump.hs +6/−6
• src/Control/Arrow/Machine/Types.hs +1644/−1442
• src/Control/Arrow/Machine/Utils.hs +148/−66
• test/Common/RandomProc.hs +212/−0
• test/LoopUtil.hs +0/−60
• test/Misc/PumpSpec.hs +45/−0
• test/RandomProc.hs +0/−221
• test/Spec.hs +2/−0
• test/Types/BasicSpec.hs +111/−0
• test/Types/ChoiceSpec.hs +57/−0
• test/Types/LoopSpec.hs +75/−0
• test/Types/PlanSpec.hs +70/−0
• test/Types/RuleSpec.hs +155/−0
• test/Types/StepExecutionSpec.hs +192/−0
• test/Types/SwitchSpec.hs +40/−0
• test/Utils/SourceSpec.hs +74/−0
• test/doctest.hs +8/−0
• test/spec.hs +0/−596

@@ -1,4 +1,29 @@ +4.0.0+----------+### Breaking changes of APIs+* Side-effects are represented by `Monad`s rather than `ArrowApply`ies.+    * Replace the base arrow `ProcessA` with `ProcessT`+    * `ProcessA` is now type alias for compatibility+    * Change the signatures of construction functions+        * `constructT`, `repeatedlyT`+        * `construct`, `repeatedly`+    * Change the signatures of running functions+        * `runT`, `runT_`, `run`, `run_`+        * `stepRun`, `stepYield`+            * Delete `ExecInfo`.+* Change the `Occasional'` type class+    * Add method `burst`+    * Move `noEvent` `end` out of the type class+* Delete `echo`. Use `id` instead.++### Additions+* Add `ZeroEvent`. Change the signatures of blocking sources with it.+* Add `Evolution`+* Add type classes `MonadAwait`, `MonadYield`, `MonadStop`+    * Generalize `await`, `yield`, and `stop` to `Evolution`+* Add `fire`, `fire0`+ 3.3.2 ---------- * Modify again the versions of depending packages.

@@ -1,5 +1,5 @@ name:                machinecell-version:             3.3.2+version:             4.0.0 synopsis:            Arrow based stream transducers license:             BSD3 license-file:        LICENSE@@ -35,27 +35,44 @@         Control.Arrow.Machine,         Control.Arrow.Machine.Types,         Control.Arrow.Machine.Utils,+        Control.Arrow.Machine.Evolution,         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   ghc-options: -Wall-  build-depends:       base >=4.6.0.0 && <5.0, mtl >=2.2 && < 3.0, free >= 4.12 && < 5.0, semigroups >=0.8.3.1 && < 1.0, profunctors >=4.0.4 && <6.0, transformers >= 0.4 && <0.6+  build-depends:       base >=4.7.0.0 && <5.0, mtl >=2.2.1 && <3, free >=4.12.3 && <5, semigroups >=0.18.1 && <1, profunctors >=5.2 && <6, transformers >=0.5.0.0 && <1   hs-source-dirs:      src   default-language:    Haskell2010    if flag(arrow-tr)-    build-depends:    arrows >=0.4.3.0+    build-depends:    arrows >=0.2  Test-suite spec   type:                exitcode-stdio-1.0   default-language:    Haskell2010   hs-source-dirs:      test-  main-is:             spec.hs-  other-modules:       RandomProc, LoopUtil-  Build-depends:       base >=4.0 && <5.0, mtl >=2.2, profunctors >=4.0.4, QuickCheck >=1.0, hspec >=0.2.0, semigroups >=0.8.3.1, machinecell >=1.0.0+  main-is:             Spec.hs+  other-modules:       Common.RandomProc,+                       Types.BasicSpec,+                       Types.ChoiceSpec,+                       Types.LoopSpec,+                       Types.PlanSpec,+                       Types.RuleSpec,+                       Types.SwitchSpec,+                       Types.StepExecutionSpec,+                       Utils.SourceSpec,+                       Misc.PumpSpec+  Build-depends:       base >=4.0 && <5.0, mtl >=2.2.1, profunctors >=5.2, QuickCheck >=1.0, hspec >=0.2.0, semigroups >=0.18.1, machinecell +Test-suite doctest+  type:                exitcode-stdio-1.0+  default-language:    Haskell2010+  hs-source-dirs:      test+  main-is:             doctest.hs+  Build-depends:       base >=4.0 && <5.0, doctest >=0.3.0+ source-repository head   type:		git   location:	https://github.com/as-capabl/machinecell.git@@ -64,4 +81,4 @@ source-repository this   type:		git   location:	https://github.com/as-capabl/machinecell.git-  tag:		release-3.3.2+  tag:		release-4.0.0

@@ -29,80 +29,80 @@         -- They are all designed to import qualified.         module Control.Arrow.Machine.ArrowUtil,         module Control.Arrow.Machine.Types,+        module Control.Arrow.Machine.Evolution,         module Control.Arrow.Machine.Utils        ) where  import Control.Arrow.Machine.ArrowUtil import Control.Arrow.Machine.Types+import Control.Arrow.Machine.Evolution import Control.Arrow.Machine.Utils +-- $setup+-- >>> :set -XArrows+-- >>> import Control.Arrow+-- >>> import Control.Monad.Trans+ -- $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]+-- [2,3,4] ----- In above statement, "`evMap` (+1)" has a type "ProcessA (-\>) (Event Int) (Event Int)",+-- In above statement, "`evMap` (+1)" has a type __"ProcessT Identity (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 (-\>)."+-- gives a series of Int as output, run on base monad `Identity`." ----- `ProcessA` is the transducer type of machinecell library.+-- `ProcessT` 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`.+-- The first type argurment of `ProcessT` is the underlying monad.+-- Transtucers can have side effects of the type. ----- ProcessA can run the effects as following.+-- ProcessT can run the effects as following. ----- >>> runKleisli (run_ $ anytime (Kleisli print)) [1, 2, 3]+-- >>> runT_ (fire 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.+--  Where `fire` makes a transducer that executes side effects for each input.+-- `runT_` 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+-- = ProcessT as pipes ----- "ProcessA a (Event b) (Event c)" transducers are actually one-directional composable pipes.+-- "ProcessT a (Event b) (Event c)" transducers are actually one-directional composable pipes. -- -- They can be constructed from the `Plan` monad. -- 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. ----- @--- 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--- @--- -- Then, resulting processes are composed as `Category` using `(\>\>\>)` operator. ----- > runKleisli (run_ $ source >>> pipe >>> sink) (repeat ())------ This reads two lines from stdin, puts a concatenated line to stdout and finishes.+-- >>> :{+-- let mySource = repeatedly $+--       do+--         _ <- await+--         yield 1+--     myPipe = construct $+--       do+--         s1 <- await+--         s2 <- await+--         yield (s1 + s2)+--     mySink = repeatedlyT $+--       do+--         x <- await+--         lift $ print x+--   in+--     runT_ (mySource >>> myPipe >>> mySink) (repeat ())+-- :}+-- 2 -- -- Unlike other pipe libraries, even the source calls `await`. -- The source awaits dummy input, namely "(repeat ())", and discard input values.@@ -137,25 +137,24 @@ -- -- One of the most attractive feature of machinecell is the /arrow composition/. ----- In addition to `Category`, ProcessA has `Arrow` instance declaration,+-- In addition to `Category`, ProcessT 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]+-- >>> :{+-- let f :: ProcessT IO (Event Int) (Event ())+--     f = proc x ->+--       do+--         -- Process odd integers.+--         odds <- filterEvent odd -< x+--         fire (putStrLn . ("Odd: " ++)) -< show <$> odds+--         -- Process even integers.+--         evens <- filterEvent even -< x+--         fire (putStrLn . ("Even: " ++)) -< show <$> evens+--   in+--     runT_ f [1..10]+-- :} -- Odd: 1 -- Even: 2 -- Odd: 3@@ -173,8 +172,8 @@ -- But several built-in transducers provide 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 :: ArrowApply a =\> b -\> ProcessT a (Event b) b+-- accum :: ArrowApply a =\> b -\> ProcessT a (Event (b-\>b)) b -- @ -- -- `hold` keeps the last input until a new value is provided.@@ -195,16 +194,15 @@ -- -- 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]+-- >>> :{+-- let f = proc x ->+--       do+--         y <- accum 0 -< (+) <$> x+--         returnA -< y <$ x+--   in+--     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,@@ -216,9 +214,9 @@   -- $note--- = Purity of `ProcessA (-\>)`--- Since the 1st type parameter of `ProcessA` represents base monad(ArrowApply),--- "ProcessA (-\>)" is expected to be pure.+-- = Purity of `ProcessT (-\>)`+-- Since the 1st type parameter of `ProcessT` represents base monad(ArrowApply),+-- "ProcessT (-\>)" is expected to be pure. -- -- In other words, the following arrow results the same result for arbitrary f. --@@ -255,26 +253,24 @@ -- -- = Looping ----- Although `ProcessA` is an instance of `ArrowLoop`,+-- Although `ProcessT` is an instance of `ArrowLoop`, -- there is a large limitation. -- -- The limitation is, Events mustn't be looped back to upstream. -- -- In example below, result is [0, 0, 0, 0], not [1, 2, 3, 4]. ----- @--- f = proc x -\>---   do---     rec---         b \<- hold 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, 0, 0, 0]+-- >>> :{+-- let f = proc x ->+--       do+--         rec+--             b <- hold 0 -< y+--             y <- fork -< (\xx -> [xx, xx+1, xx+2, xx+3]) <$> x+--         returnA -< b <$ y+--   in+--     run f [1]+-- :}+-- [0,0,0,0] -- -- In general, `Event` values refered at upstream in rec statements are -- almost always `NoEvent`s.

@@ -0,0 +1,83 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE Arrows #-}++module+    Control.Arrow.Machine.Evolution+      (+        switchAfter,+        dSwitchAfter,+        kSwitchAfter,+        dkSwitchAfter,+        gSwitchAfter,+        dgSwitchAfter,+        finishWith,+        evolve+      )+where++import Prelude hiding (id, (.))+import Data.Void+import Control.Category+import Control.Arrow.Machine.Types+import Control.Monad.Cont (cont, runCont)++{-# INLINE switchAfter #-}+switchAfter ::+    Monad m =>+    ProcessT m i (o, Event r) ->+    Evolution i o m r+switchAfter pf = Evolution $ cont $ switch pf++{-# INLINE dSwitchAfter #-}+dSwitchAfter ::+    Monad m =>+    ProcessT m i (o, Event r) ->+    Evolution i o m r+dSwitchAfter pf = Evolution $ cont $ dSwitch pf++{-# INLINE kSwitchAfter #-}+kSwitchAfter ::+    Monad m =>+    ProcessT m (i, o) (Event r) ->+    ProcessT m i o ->+    Evolution i o m (ProcessT m i o, r)+kSwitchAfter test pf = Evolution $ cont $ kSwitch pf test . curry++{-# INLINE dkSwitchAfter #-}+dkSwitchAfter ::+    Monad m =>+    ProcessT m (i, o) (Event r) ->+    ProcessT m i o ->+    Evolution i o m (ProcessT m i o, r)+dkSwitchAfter test pf = Evolution $ cont $ dkSwitch pf test . curry++{-# INLINE gSwitchAfter #-}+gSwitchAfter ::+    Monad m =>+    ProcessT m i (p, r) ->+    ProcessT m (q, r) (o, Event t) ->+    ProcessT m p q ->+    Evolution i o m (ProcessT m p q, t)+gSwitchAfter pre post pf = Evolution $ cont $ gSwitch pre pf post . curry++{-# INLINE dgSwitchAfter #-}+dgSwitchAfter ::+    Monad m =>+    ProcessT m i (p, r) ->+    ProcessT m (q, r) (o, Event t) ->+    ProcessT m p q ->+    Evolution i o m (ProcessT m p q, t)+dgSwitchAfter pre post pf = Evolution $ cont $ dgSwitch pre pf post . curry++{-# INLINE finishWith #-}+finishWith ::+    Monad m =>+    ProcessT m i o ->+    Evolution i o m r+finishWith pf = Evolution $ cont $ const pf++{-# INLINE evolve #-}+evolve ::+    Evolution i o m Void ->+    ProcessT m i o+evolve ev = runCont (runEvolution ev) absurd

@@ -57,8 +57,8 @@ finite number of changing points.  >>> import qualified Control.Arrow.Machine.Misc.Discrete as D->>> run (D.hold "apple" >>> D.arr reverse >>> D.edge) ["orange", "grape"]-["elppa", "egnaro", "eparg"]+>>> P.run (D.hold "apple" >>> D.arr reverse >>> D.edge) ["orange", "grape"]+["elppa","egnaro","eparg"]  In above example, input data of "reverse" is continuous. But the "D.edge" transducer extracts changing points without calling string comparison.@@ -74,15 +74,15 @@   }  makeT ::-    ArrowApply a =>-    P.ProcessA a (P.Event (), b) (T b)+    Monad m =>+    P.ProcessT m (P.Event (), b) (T b) makeT = Arr.arr $ uncurry T   stimulate ::-    ArrowApply a =>-    P.ProcessA a b (T c) ->-    P.ProcessA a b (T c)+    Monad m =>+    P.ProcessT m b (T c) ->+    P.ProcessT m b (T c) stimulate sf = P.dgSwitch (id &&& id) sf body $ \sf' _ -> sf'   where     body = proc (dy, _) ->@@ -92,117 +92,117 @@         returnA -< (disc, updates disc)  arr ::-    ArrowApply a =>+    Monad m =>     (b->c) ->-    P.ProcessA a (T b) (T c)+    P.ProcessT m (T b) (T c) arr f =     Arr.arr $ \(T ev x) ->         T ev (f x)  arr2 ::-    ArrowApply a =>+    Monad m =>     (b1->b2->c) ->-    P.ProcessA a (T b1, T b2) (T c)+    P.ProcessT m (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 =>+    Monad m =>     (b1->b2->b3->c) ->-    P.ProcessA a (T b1, T b2, T b3) (T c)+    P.ProcessT m (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 =>+    Monad m =>     (b1->b2->b3->b4->c) ->-    P.ProcessA a (T b1, T b2, T b3, T b4) (T c)+    P.ProcessT m (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 =>+    Monad m =>     (b1->b2->b3->b4->b5->c) ->-    P.ProcessA a (T b1, T b2, T b3, T b4, T b5) (T c)+    P.ProcessT m (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 =>+    Monad m =>     c ->-    P.ProcessA a b (T c)+    P.ProcessT m b (T c) constant x =     (P.now &&& Arr.arr (const x)) >>> makeT  -- |Constant without initial notifications. -- Users must manage initialization manually. unsafeConstant::-    ArrowApply a =>+    Monad m =>     c ->-    P.ProcessA a b (T c)+    P.ProcessT m b (T c) unsafeConstant x =     (pure P.noEvent &&& Arr.arr (const x)) >>> makeT  onUpdate ::-    ArrowApply a =>-    P.ProcessA a (P.Event b) (P.Event ())+    Monad m =>+    P.ProcessT m (P.Event b) (P.Event ()) onUpdate = proc ev ->   do     n <- P.now -< ()     returnA -< n `mappend` P.collapse ev  hold ::-    ArrowApply a =>+    Monad m =>     b ->-    P.ProcessA a (P.Event b) (T b)+    P.ProcessT m (P.Event b) (T b) hold i =     (onUpdate &&& P.hold i) >>> makeT  accum ::-    ArrowApply a =>+    Monad m =>     b ->-    P.ProcessA a (P.Event (b->b)) (T b)+    P.ProcessT m (P.Event (b->b)) (T b) accum i =     (onUpdate &&& P.accum i) >>> makeT  fromEq ::-    (ArrowApply a, Eq b) =>-    P.ProcessA a b (T b)+    (Monad m, Eq b) =>+    P.ProcessT m 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)+    Monad m =>+    P.ProcessT m (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+    Monad m =>+    (b -> m c) ->+    P.ProcessT m (T b) (P.Event c)+asUpdater fmx = edge >>> P.fire fmx   kSwitch ::-    ArrowApply a =>-    P.ProcessA a b (T c) ->-    P.ProcessA a (b, T c) (P.Event t) ->-    (P.ProcessA a b (T c) -> t -> P.ProcessA a b (T c)) ->-    P.ProcessA a b (T c)+    Monad m =>+    P.ProcessT m b (T c) ->+    P.ProcessT m (b, T c) (P.Event t) ->+    (P.ProcessT m b (T c) -> t -> P.ProcessT m b (T c)) ->+    P.ProcessT m b (T c) kSwitch sf test k = P.kSwitch sf test (\sf' x -> stimulate (k sf' x))  dkSwitch ::-    ArrowApply a =>-    P.ProcessA a b (T c) ->-    P.ProcessA a (b, T c) (P.Event t) ->-    (P.ProcessA a b (T c) -> t -> P.ProcessA a b (T c)) ->-    P.ProcessA a b (T c)+    Monad m =>+    P.ProcessT m b (T c) ->+    P.ProcessT m (b, T c) (P.Event t) ->+    (P.ProcessT m b (T c) -> t -> P.ProcessT m b (T c)) ->+    P.ProcessT m b (T c) dkSwitch sf test k = P.dkSwitch sf test (\sf' x -> stimulate (k sf' x))  @@ -213,8 +213,8 @@  @ holdAdd ::-    (ArrowApply a, Num b) =>-    ProcessA a (Event b, Event b) (Discrete b)+    (Monad m, Num b) =>+    ProcessT m (Event b, Event b) (Discrete b) holdAdd = proc (evx, evy) ->   do     x <- D.hold 0 -< evx@@ -228,28 +228,28 @@ -}  -- |Discrete algebra type.-newtype Alg a i o =-    Alg { eval :: P.ProcessA a i (T o) }+newtype Alg m i o =+    Alg { eval :: P.ProcessT m i (T o) }  refer ::-    ArrowApply a =>-    (e -> T b) -> Alg a e b+    Monad m =>+    (e -> T b) -> Alg m e b refer = Alg . Arr.arr  instance-    ArrowApply a => Functor (Alg a i)+    Monad m => Functor (Alg m i)   where     fmap f alg = Alg $ eval alg >>> arr f  instance-    ArrowApply a => Applicative (Alg a i)+    Monad m => Applicative (Alg m i)   where     pure = Alg . constant     af <*> aa = Alg $ (eval af &&& eval aa) >>> arr2 ($)  instance-    (ArrowApply a, Num o) =>-    Num (Alg a i o)+    (Monad m, Num o) =>+    Num (Alg m i o)   where     abs = fmap abs     signum = fmap signum

@@ -34,16 +34,16 @@ newtype Duct a = Duct (Endo [a])  oneMore ::-    ArrowApply a =>-    P.ProcessA a (P.Event ()) (P.Event ())+    Monad m =>+    P.ProcessT m (P.Event ()) (P.Event ()) oneMore = proc ev ->   do     ed <- P.onEnd -< ev     P.gather -< [ev, ed]      intake ::-    ArrowApply a =>-    P.ProcessA a (P.Event b, P.Event ()) (Duct b)+    Monad m =>+    P.ProcessT m (P.Event b, P.Event ()) (Duct b) intake = proc (ev, clock) ->   do     cl2 <- oneMore -< clock@@ -52,8 +52,8 @@     returnA -< Duct e  outlet ::-    ArrowApply a =>-    P.ProcessA a (Duct b, P.Event ()) (P.Event b)+    Monad m =>+    P.ProcessT m (Duct b, P.Event ()) (P.Event b) outlet = proc (~(Duct dct), clock) ->   do     cl2 <- oneMore -< clock

@@ -6,1445 +6,1647 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}--module-    Control.Arrow.Machine.Types-      (-        -- * Stream transducer type-        ProcessA(),--        -- * Event type and utility-        Occasional' (..),-        Occasional (..),-        Event (),-        condEvent,-        filterEvent,-        filterJust,-        filterLeft,-        filterRight,-        splitEvent,-        evMap,--        -- * Coroutine monad-        -- | Procedural coroutine monad that can await or yield values.-        ---        -- Coroutines can be encoded to machines by `constructT` or so on and-        -- then put into `ProcessA` compositions.-        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,-        gSwitch,-        dgSwitch,-        pSwitch,-        pSwitchB,-        dpSwitch,-        dpSwitchB,-        rpSwitch,-        rpSwitchB,-        drpSwitch,-        drpSwitchB,-        par,-        parB,--        -- * Primitive machines - other safe primitives-        fit,-        fitW,--        -- * Primitive machines - unsafe-        unsafeExhaust,-      )-where--import qualified Control.Category as Cat-import Data.Profunctor (Profunctor, dimap, rmap)-import Control.Arrow-import Control.Monad-import Control.Monad.Trans-import Control.Monad.State.Strict-import Control.Monad.Reader-import Control.Monad.Writer hiding ((<>))-import Control.Monad.Identity-import Control.Monad.Trans.Cont (ContT(..), evalContT, callCC)-import Control.Applicative-import qualified Data.Foldable as Fd-import Data.Traversable as Tv-import Data.Semigroup (Semigroup, (<>))-import Data.Maybe (fromMaybe, isNothing, isJust)-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 ProcType a b c = ProcessA a b c--class Stepper a b c s | s -> a, s -> b, s -> c-  where-    feed :: s -> a b (c, s)-    sweep :: s -> a b (Maybe c, s)-    suspend :: s -> 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.------ See an introduction at "Control.Arrow.Machine" documentation.-data ProcessA a b c = ProcessA {-    paFeed :: a b (c, ProcessA a b c),-    paSweep :: a b (Maybe c, ProcessA a b c),-    paSuspend :: !(b -> c)-  }--instance-    Stepper a b c (ProcessA a b c)-  where-    feed = paFeed-    sweep = paSweep-    suspend = paSuspend--toProcessA ::-    (ArrowApply a, Stepper a b c s) =>-    s -> ProcessA a b c-toProcessA s = ProcessA {-    paFeed = feed s >>> arr (second toProcessA),-    paSweep = sweep s >>> arr (second toProcessA),-    paSuspend = suspend s-  }-{-# INLINE[2] toProcessA  #-}---- For internal use-class-    (Applicative f, Monad f) => ProcessHelper f-  where-    step ::-        (ArrowApply a, Stepper a b c s) =>-        s -> a b (f c, s)-    helperToMaybe :: f a -> Maybe a-    weakly :: a -> f a--    compositeStep ::-        (ArrowApply a, Stepper a b p s1, Stepper a p c s2) =>-        s1 -> s2 ->-        a b (f c, s1, s2)---instance-    ProcessHelper Identity-  where-    step pa = feed pa >>> first (arr Identity)-    helperToMaybe = Just . runIdentity-    weakly = Identity-    compositeStep sf test = proc x ->-      do-        (y, sf') <- feed sf -< x-        (z, test') <- feed test -< y-        returnA -< (return z, sf', test')--instance-    ProcessHelper Maybe-  where-    step = sweep-    helperToMaybe = id-    weakly _ = Nothing-    compositeStep sf0 test0 = proc x ->-      do-        let y = suspend sf0 x-        (mt, test') <- sweep test0 -< y-        (case mt of-            Just t -> arr $ const (Just t, sf0, test')-            Nothing -> cont sf0 test')-                -<< x-      where-        cont sf test = proc x ->-          do-            (my, sf') <- sweep sf -< x-            (case my of-                Just y -> cont2 y sf' test-                Nothing -> arr $ const (Nothing, sf', test))-                    -<< x-        cont2 y sf test = proc _ ->-          do-            (t, test') <- feed test -< y-            returnA -< (Just t, sf, test')--makePA ::-    Arrow a =>-    (forall f. ProcessHelper f =>-        a b (f c, ProcessA a b c)) ->-    (b -> c) ->-    ProcessA a b c-makePA h !sus = ProcessA {-    paFeed = h >>> first (arr runIdentity),-    paSweep = h,-    paSuspend = sus-  }---data CompositeStep a b c s1 s2-  where-    CompositeStep ::-        (Stepper a b p s1, Stepper a p c s2) =>-        s1 -> s2 ->-        CompositeStep a b c s1 s2--instance-    ArrowApply a => Stepper a b c (CompositeStep a b c s1 s2)-  where-    feed (CompositeStep s1 s2) =-        compositeStep s1 s2 >>>-            arr (\(fz, s1', s2') -> (runIdentity $ fz, CompositeStep s1' s2'))-    sweep (CompositeStep s1 s2) =-        compositeStep s1 s2 >>>-            arr (\(fz, s1', s2') -> (fz, CompositeStep s1' s2'))-    suspend (CompositeStep s1 s2) =-        suspend s2 . suspend s1---data IDStep a b c-  where-    IDStep :: IDStep (a :: * -> * -> *) b b--instance-    ArrowApply a => Stepper a b c (IDStep a b c)-  where-    feed IDStep = Cat.id &&& arr (const IDStep)-    sweep IDStep = arr (const (Nothing, IDStep))-    suspend IDStep = id--newtype ArrStep (a :: * -> * -> *) b c = ArrStep (b -> c)--instance-    ArrowApply a => Stepper a b c (ArrStep a b c)-  where-    feed (ArrStep f) = arr $ \x -> (f x, ArrStep f)-    sweep (ArrStep f) = arr $ const (Nothing, ArrStep f)-    suspend (ArrStep f) = f---data ParStep a b c s1 s2-  where-    ParStep ::-        (Stepper a b1 c1 s1, Stepper a b2 c2 s2) =>-        s1 -> s2 ->-        ParStep a (b1, b2) (c1, c2) s1 s2--instance-    ArrowApply a => Stepper a b c (ParStep a b c s1 s2)-  where-    feed (ParStep f g) = proc (x1, x2) ->-      do-        (y1, f') <- feed f -< x1-        (y2, g') <- feed g -< x2-        returnA -< ((y1, y2), ParStep f' g')-    sweep (ParStep f g) = proc (x1, x2) ->-      do-        (my1, f') <- sweep f -< x1-        (my2, g') <- sweep g -< x2-        let y1 = fromMaybe (suspend f' x1) my1 -- suspend f ?-            y2 = fromMaybe (suspend g' x2) my2-            r = if (isNothing my1 && isNothing my2) then Nothing else Just (y1, y2)-        returnA -< (r, ParStep f' g')-    suspend (ParStep f g) = suspend f *** suspend g----- |Natural transformation-fit ::-    (ArrowApply a, ArrowApply a') =>-    (forall p q. a p q -> a' p q) ->-    ProcessA a b c -> ProcessA a' b c-fit f pa =-    arr Identity >>>-    fitW runIdentity (\ar -> arr runIdentity >>> f ar) pa---- |Experimental: more general fit.------ Should w be a comonad?-fitW :: (ArrowApply a, ArrowApply a', Functor w) =>-    (forall p. w p -> p) ->-    (forall p q. a p q -> a' (w p) q) -> -    ProcessA a b c -> ProcessA a' (w b) c-fitW extr f pa = makePA-    (f (step pa) >>> arr (second $ fitW extr f))-    (extr >>> suspend pa)---instance-    ArrowApply a => Profunctor (ProcessA a)-  where-    dimap = dimapProc-    {-# INLINE dimap #-}--dimapProc ::-    ArrowApply a =>-    (b->c)->(d->e)->-    ProcType a c d -> ProcType a b e-dimapProc f g pa = makePA-    (arr f >>> step pa >>> (arr (fmap g) *** arr (dimapProc f g)))-    (dimap f g (suspend pa))--{-# NOINLINE dimapProc #-}---instance-    ArrowApply 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 = idProc-    {-# INLINE id #-}--    g . f = compositeProc f g-    {-# INLINE (.) #-}---instance-    ArrowApply a => Arrow (ProcessA a)-  where-    arr = arrProc-    {-# INLINE arr #-}--    first pa = parProc pa idProc-    {-# INLINE first #-}--    second pa = parProc idProc pa-    {-# INLINE second #-}--    (***) = parProc-    {-# INLINE (***) #-}---parProc :: ArrowApply a =>-    ProcType a b c ->-    ProcType a d e ->-    ProcType a (b, d) (c, e)-parProc f g = toProcessA $ ParStep f g-{-# INLINE [0] parProc #-}--idProc :: ArrowApply a => ProcType a b b-idProc = makePA (arr $ \x -> (weakly x, idProc)) id-{-# NOINLINE idProc #-}--arrProc :: ArrowApply a => (b->c) -> ProcType a b c-arrProc f = makePA (arr $ \x -> (weakly (f x), arrProc f)) f-{-# NOINLINE arrProc #-}---- |Composition is proceeded by the backtracking strategy.-compositeProc :: ArrowApply a =>-              ProcType a b d -> ProcType a d c -> ProcType a b c-compositeProc f0 g0 = ProcessA {-    paFeed = proc x ->-      do-        (y, f') <- feed f0 -< x-        (z, g') <- feed g0 -< y-        returnA -< (z, compositeProc f' g'),-    paSweep = proc x ->-      do-        (mz, g') <- sweep g0 -< suspend f0 x-        (case mz-          of-            Just z -> arr $ const (Just z, compositeProc f0 g')-            Nothing -> btrk f0 g')-                -<< x,-    paSuspend = suspend f0 >>> suspend g0-  }-  where-    btrk f g = proc x ->-      do-        (my, f') <- sweep f -< x-        (mz, g') <--            (case my-              of-                Just y -> proc () ->-                  do-                    (z, g') <- feed g -< y-                    returnA -< (Just z, g')-                Nothing -> proc () ->-                  do-                    returnA -< (Nothing, g))-                -<< ()-        returnA -< (mz, compositeProc f' g')--{-# NOINLINE compositeProc #-}---- rules-{-# RULES-"ProcessA: id/*"-    forall g. compositeProc idProc g = g-"ProcessA: */id"-    forall f. compositeProc f idProc = f--"ProcessA: concat/concat"-    forall f g h. compositeProc (compositeProc f g) h = compositeProc f (compositeProc g h)--"ProcessA: dimap/dimap"-    forall f g h i j. dimapProc f j (dimapProc g i h)  = dimapProc (g . f) (j . i) h-"ProcessA: dimap/arr"-    forall f g h. dimapProc f h (arrProc g) = arrProc (h . g . f)--"ProcessA: arr***/par"-    forall f1 f2 g1 g2 h. compositeProc (parProc f1 (arrProc f2)) (compositeProc (parProc g1 g2) h) =-        compositeProc (parProc (compositeProc f1 g1) (dimapProc f2 id g2)) h-"ProcessA: arr***/par-2"-    forall f1 f2 g1 g2. compositeProc (parProc f1 (arrProc f2)) (parProc g1 g2) =-        parProc (compositeProc f1 g1) (dimapProc f2 id g2)-"ProcessA: par/***arr"-    forall f1 f2 g1 g2 h. compositeProc (parProc f1 f2) (compositeProc (parProc (arrProc g1) g2) h) =-        compositeProc (parProc (dimapProc id g1 f1) (compositeProc f2 g2)) h-"ProcessA: par/***arr-2"-    forall f1 f2 g1 g2. compositeProc (parProc f1 f2) (parProc (arrProc g1) g2) =-        parProc (dimapProc id g1 f1) (compositeProc f2 g2)--"ProcessA: first/par"-    forall f1 g1 g2 h. compositeProc (parProc f1 idProc) (compositeProc (parProc g1 g2) h) =-        compositeProc (parProc (compositeProc f1 g1) g2) h-"ProcessA: first/par-2"-    forall f1 g1 g2. compositeProc (parProc f1 idProc) (parProc g1 g2) =-        parProc (compositeProc f1 g1) g2-"ProcessA: par/second"-    forall f1 f2 g2 h. compositeProc (parProc f1 f2) (compositeProc (parProc idProc g2) h) =-        compositeProc (parProc f1 (compositeProc f2 g2)) h-"ProcessA: par/second-2"-    forall f1 f2 g2. compositeProc (parProc f1 f2) (parProc idProc g2) =-        parProc f1 (compositeProc f2 g2)--"ProcessA: arr/arr"-    forall f g h. compositeProc (arrProc f) (compositeProc (arrProc g) h) =-        compositeProc (arrProc (g . f)) h-"ProcessA: arr/arr-2"-    forall f g. compositeProc (arrProc f) (arrProc g) = arrProc (g . f)-"ProcessA: arr/*" [1]-    forall f g. compositeProc (arrProc f) g = dimapProc f id g-"ProcessA: */arr" [1]-    forall f g. compositeProc f (arrProc g) = dimapProc id g f-"ProcessA: arr***arr" [0]-    forall f g. parProc (arrProc f) (arrProc g) = arrProc (f *** g)-  #-}---instance-    ArrowApply a => ArrowChoice (ProcessA a)-  where-    left pa0 = makePA-        (proc eth -> sweep' pa0 eth -<< ())-        (left $ suspend pa0)-      where-        sweep' pa (Left x) = proc () ->-          do-            (my, pa') <- step pa -< x-            returnA -< (Left <$> my, left pa')-        sweep' pa (Right d) = proc () ->-            returnA -< (weakly (Right d), left pa)--instance-    ArrowApply a => ArrowLoop (ProcessA a)-  where-    loop pa =-        makePA-            (proc x ->-              do-                (hyd, pa') <- step pa -< (x, loopSusD x)-                returnA -< (fst <$> hyd, loop pa'))-            (loop $ suspend pa)-      where-        loopSusD = loop (suspend pa >>> \(_, d) -> (d, d))---- | Discrete events on a time line.--- Created and consumed by various transducers.-data Event a = Event a | NoEvent | End---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 monoid 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---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---condEvent :: Bool -> Event a -> Event a-condEvent _ End = End-condEvent True ev = ev-condEvent False _ = NoEvent--filterEvent ::-    Arrow ar =>-    (a -> Bool) ->-    ar (Event a) (Event a)-filterEvent cond = filterJust <<< evMap mcond-  where-    mcond x-        | cond x = Just x-        | otherwise = Nothing--filterJust ::-    Arrow ar => ar (Event (Maybe a)) (Event a)-filterJust = arr filterJust'-  where-    filterJust' (Event (Just x)) = Event x-    filterJust' (Event Nothing) = NoEvent-    filterJust' NoEvent = NoEvent-    filterJust' End = End--filterLeft ::-    Arrow ar =>-    ar (Event (Either a b)) (Event a)-filterLeft = filterJust <<< evMap (either Just (const Nothing))--filterRight ::-    Arrow ar =>-    ar (Event (Either a b)) (Event b)-filterRight = filterJust <<< evMap (either (const Nothing) Just)--splitEvent ::-    Arrow ar =>-    ar (Event (Either a b)) (Event a, Event b)-splitEvent = filterLeft &&& filterRight---- | 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-    ed <- construct (forever await `catchP` yield ()) -< collapse x-    rSwitch (arr $ const noEvent) -< ((), stopped <$ ed)----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--newtype PlanT i o m a =-    PlanT { freePlanT :: F.FT (PlanF i o) m a }-  deriving-    (Functor, Applicative, Monad, MonadTrans,-     Alternative)-    -- , MonadError, MonadReader, MonadCatch, MonadThrow, MonadIO, MonadCont-type Plan i o a = forall m. Monad m => PlanT i o m a--instance-    MonadReader r m => MonadReader r (PlanT i o m)-  where-    ask = PlanT ask-    local f (PlanT pl) = PlanT $ local f pl--instance-    MonadWriter w m => MonadWriter w (PlanT i o m)-  where-    tell = PlanT . tell-    listen = PlanT . listen . freePlanT-    pass = PlanT . pass . freePlanT--instance-    MonadState s m => MonadState s (PlanT i o m)-  where-    get = PlanT get-    put = PlanT . put--instance-    (Monad m, Alternative m) => MonadPlus (PlanT i o m)-  where-    mzero = stop-    mplus = catchP--yield :: o -> Plan i o ()-yield x = PlanT . F.liftF $ YieldPF x ()--await :: Plan i o i-await = PlanT $ F.FT $ \pr free -> free id (AwaitPF pr (free pr StopPF))--stop :: Plan i o a-stop = PlanT $ F.liftF $ StopPF---catchP:: Monad m =>-    PlanT i o m a -> PlanT i o m a -> PlanT i o m a--catchP (PlanT pl) cont0 =-    PlanT $ F.FT $ \pr free ->-        F.runFT-            pl-            (pr' pr)-            (free' cont0 pr free)-  where-    pr' pr = pr--    free' ::-        Monad m =>-        PlanT i o m a ->-        (a -> m r) ->-        (forall x. (x -> m r) -> PlanF i o x -> m r) ->-        (y -> m r) ->-        (PlanF i o y) ->-        m r-    free' (PlanT cont) pr free _ StopPF =-        F.runFT cont pr free-    free' (PlanT cont) pr free r (AwaitPF f ff) =-        free-            (either (\_ -> F.runFT cont pr free) r)-            (AwaitPF (Right . f) (Left ff))-    free' _ _ free r pf =-        free r pf-----constructT ::-    (Monad m, ArrowApply a) =>-    (forall b. m b -> a () b) ->-    PlanT i o m r ->-    ProcessA a (Event i) (Event o)-constructT = constructT'---constructT' ::-    forall a m i o r.-    (Monad m, ArrowApply a) =>-    (forall b. m b -> a () b) ->-    PlanT i o m r ->-    ProcessA a (Event i) (Event o)-constructT' fit0 (PlanT pl0) = prependProc $ F.runFT pl0 pr free-  where-    fit' :: (b -> m c) -> a b c-    fit' fmy = proc x -> fit0 (fmy x) -<< ()--    prependProc ::-        m (Event o, ProcessA a (Event i) (Event o)) ->-        ProcessA a (Event i) (Event o)-    prependProc mr = ProcessA {-        paFeed = proc ex -> do { r <- fit0 mr -< (); prependFeed r -<< ex} ,-        paSweep = proc ex -> do { r <- fit0 mr -< (); prependSweep r -<< ex},-        paSuspend = const NoEvent-      }--    prependFeed (Event x, pa) = arr $ const (Event x, pa)-    prependFeed (NoEvent, pa) = feed pa-    prependFeed (End, _) = arr $ const (End, stopped)--    prependSweep (Event x, pa) = arr $ const (Just (Event x), pa)-    prependSweep (NoEvent, pa) = sweep pa-    prependSweep (End, _) = arr $ const (Just End, stopped)--    pr _ = return (End, stopped)--    free ::-        (x -> m (Event o, ProcessA a (Event i) (Event o)))->-        PlanF i o x ->-        m (Event o, ProcessA a (Event i) (Event o))-    free r (YieldPF y cont) =-        return (Event y, prependProc (r cont))-    free r pl@(AwaitPF f ff) =-        return (NoEvent, awaitProc fma)-      where-        fma (Event x) = r (f x)-        fma NoEvent = free r pl-        fma End = r ff-    free _ StopPF =-        return (End, stopped)--    awaitProc fma = ProcessA {-        paFeed = fit' fma,-        paSweep = fit' fma >>> first eToM,-        paSuspend = const NoEvent-      }--    eToM :: a (Event b) (Maybe (Event b))-    eToM = arr eToMpure-    eToMpure NoEvent = Nothing-    eToMpure e = Just e---repeatedlyT :: (Monad m, ArrowApply a) =>-              (forall b. m b -> a () b) ->-              PlanT i o m r ->-              ProcessA a (Event i) (Event o)--repeatedlyT f = constructT f . forever----- for pure-construct :: ArrowApply a =>-             PlanT i o Identity r ->-             ProcessA a (Event i) (Event o)-construct = constructT (arr . const . runIdentity)--repeatedly :: ArrowApply a =>-              PlanT i o Identity r ->-              ProcessA a (Event i) (Event o)-repeatedly = construct . forever-------- Switches----switch ::-    ArrowApply a =>-    ProcessA a b (c, Event t) ->-    (t -> ProcessA a b c) ->-    ProcessA a b c-switch sf k = ggSwitch (const ()) sf (\() -> k)---dSwitch ::-    ArrowApply a =>-    ProcessA a b (c, Event t) ->-    (t -> ProcessA a b c) ->-    ProcessA a b c-dSwitch sf k = dggSwitch (const ()) sf (\() -> k)---rSwitch ::-    ArrowApply a => ProcessA a b c ->-    ProcessA a (b, Event (ProcessA a b c)) c-rSwitch p = rSwitch' (p *** Cat.id) >>> arr fst-  where-    rSwitch' pid = kSwitch pid test $ \_ p' -> rSwitch'' (p' *** Cat.id)-    rSwitch'' pid = dkSwitch pid test $ \s _ -> rSwitch' s-    test = proc (_, (_, r)) -> returnA -< r---drSwitch ::-    ArrowApply a => ProcessA a b c ->-    ProcessA a (b, Event (ProcessA a b c)) c--drSwitch p =  drSwitch' (p *** Cat.id)-  where-    drSwitch' pid = dSwitch pid $ \p' -> drSwitch' (p' *** Cat.id)---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 =-    ggSwitch-        (\(CompositeStep _ (CompositeStep (ParStep IDStep sf') _)) -> sf')-        (CompositeStep (ArrStep (id &&& id))-           (CompositeStep (ParStep IDStep sf) (arr snd &&& test)))---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 =-    dggSwitch-        (\(CompositeStep _ (CompositeStep (ParStep IDStep sf') _)) -> sf')-        (CompositeStep (ArrStep (id &&& id))-           (CompositeStep (ParStep IDStep sf) (arr snd &&& test)))--ggSwitch ::-    (ArrowApply a, Stepper a b (c, Event t) sWhole) =>-    (sWhole -> s) ->-    sWhole ->-    (s -> t -> ProcessA a b c) ->-    ProcessA a b c-ggSwitch picker whole k = makePA-    (proc x ->-      do-        let-        (hyevt, whole') <- step whole -<< x-        let hy = fst <$> hyevt-            hevt = snd <$> hyevt-        (case (helperToMaybe hevt)-          of-            Just (Event t) -> step (k (picker whole') t)-            _ -> arr $ const (hy, ggSwitch picker whole' k))-                -<< x)-    (arr fst . suspend whole)--dggSwitch ::-    (ArrowApply a, Stepper a b (c, Event t) sWhole) =>-    (sWhole -> s) ->-    sWhole ->-    (s -> t -> ProcessA a b c) ->-    ProcessA a b c-dggSwitch picker whole k = makePA-    (proc x ->-      do-        let-        (hyevt, whole') <- step whole -<< x-        let hy = fst <$> hyevt-            hevt = snd <$> hyevt-        (case (helperToMaybe hevt)-          of-            Just (Event t) -> arr $ const (hy, k (picker whole') t)-            _ -> arr $ const (hy, dggSwitch picker whole' k))-                -<< x)-    (arr fst . suspend whole)--gSwitch ::-    ArrowApply a =>-    ProcessA a b (p, r) ->-    ProcessA a p q ->-    ProcessA a (q, r) (c, Event t) ->-    (ProcessA a p q -> t -> ProcessA a b c) ->-    ProcessA a b c-gSwitch pre sf post =-    ggSwitch-        (\(CompositeStep _ (CompositeStep (ParStep sf' IDStep) _)) -> sf')-        (CompositeStep pre (CompositeStep (ParStep sf IDStep) post))--dgSwitch ::-    ArrowApply a =>-    ProcessA a b (p, r) ->-    ProcessA a p q ->-    ProcessA a (q, r) (c, Event t) ->-    (ProcessA a p q -> t -> ProcessA a b c) ->-    ProcessA a b c-dgSwitch pre sf post =-    dggSwitch-        (\(CompositeStep _ (CompositeStep (ParStep sf' IDStep) _)) -> sf')-        (CompositeStep pre (CompositeStep (ParStep sf IDStep) post))--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 = toProcessA (PluralStep r sfs)--parB ::-    (ArrowApply a, Tv.Traversable col) =>-    col (ProcessA a b c) ->-    ProcessA a b (col c)-parB = par broadcast---data PluralStep ext col a b c-  where-    PluralStep ::-        (forall sf. (b -> col sf -> col (ext, sf))) ->-        (col (ProcessA a ext c)) ->-        PluralStep ext col a b c---instance-    (ArrowApply a, Tv.Traversable col) =>-    Stepper a b (col c) (PluralStep ext col a b c)-  where-    feed (PluralStep r sfs) = parCore r sfs >>> arr (runIdentity *** PluralStep r)-    sweep (PluralStep r sfs) = parCore r sfs >>> arr (id *** PluralStep r)-    suspend (PluralStep r sfs) = suspendAll r sfs--suspendAll ::-    (ArrowApply a, Tv.Traversable col) =>-    (forall sf. (b -> col sf -> col (ext, sf))) ->-    col (ProcessA a ext c) ->-    b -> col c-suspendAll r sfs = (sus <$>) . (r `flip` sfs)-  where-    sus (ext, sf) = suspend sf ext--traverseResult ::-    forall h col c.-    (Tv.Traversable col, ProcessHelper h) =>-    col (h c, c) -> h (col c)-traverseResult zs =-    let-        pr :: (h c, c) -> StateT Bool h c-        pr (hx, d) =-          do-            let mx = helperToMaybe hx-            if isJust mx then put True else return ()-            return (fromMaybe d mx)-        hxs = runStateT (Tv.sequence (pr <$> zs)) False-        exist = fromMaybe False $ helperToMaybe (snd <$> hxs)-        result = fst <$> hxs-      in-        if exist then result else join (weakly result)--parCore ::-    (ArrowApply a, Tv.Traversable col, ProcessHelper h) =>-    (forall sf. (b -> col sf -> col (ext, sf))) ->-    col (ProcessA a ext c) ->-    a b (h (col c), col (ProcessA a ext c))--parCore r sfs = proc x ->-  do-    let input = r x sfs-    ret <- unwrapArrow (Tv.sequenceA (fmap (WrapArrow . app') input)) -<< ()-    let zs = traverseResult $ fmap fst ret-        sfs' = fmap snd ret-    returnA -< (zs, sfs')-  where-    app' (y, sf) = proc () ->-      do-        (hz, sf') <- step sf -< y-        returnA -< ((hz, suspend sf' y), 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 =-    ggSwitch-        (\(CompositeStep _-            (CompositeStep (ParStep IDStep (PluralStep _ sfs')) _)) -> sfs')-        (CompositeStep (ArrStep (id &&& id))-            (CompositeStep (ParStep IDStep (PluralStep r sfs)) (arr snd &&& test)))--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--dpSwitch ::-    (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)-dpSwitch r sfs test =-    dggSwitch-        (\(CompositeStep _-            (CompositeStep (ParStep IDStep (PluralStep _ sfs')) _)) -> sfs')-        (CompositeStep (ArrStep (id &&& id))-            (CompositeStep (ParStep IDStep (PluralStep r sfs)) (arr snd &&& test)))--dpSwitchB ::-    (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)-dpSwitchB = dpSwitch 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 =-    ggSwitch-        (\(ParStep (PluralStep _ sfs') IDStep) -> sfs')-        (ParStep (PluralStep r sfs) IDStep)-        (\sfs' tr -> next r (tr sfs'))-  where-    next ::-        (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)-    next r' sfs' =-        dggSwitch-            (\(ParStep (PluralStep _ sfs'') IDStep) -> sfs'')-            (ParStep (PluralStep r' sfs') IDStep)-            (\sfs'' _ -> 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---drpSwitch ::-    (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)-drpSwitch r sfs =-    dggSwitch-        (\(ParStep (PluralStep _ sfs') IDStep) -> sfs')-        (ParStep (PluralStep r sfs) IDStep)-        (\sfs' tr -> drpSwitch r (tr sfs'))--drpSwitchB ::-    (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)-drpSwitchB = drpSwitch broadcast-------- Unsafe primitives------- | 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 {-        paFeed = p >>> arr (\y -> (Event y, go)),-        paSweep = p >>> arr (\y -> (if nullFd y then Nothing else Just (Event y), go)),-        paSuspend = const NoEvent-      }--    fork = repeatedly $ await >>= Fd.mapM_ yield--    nullFd = getAll . Fd.foldMap (\_ -> All False)--------- Running---------- 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, MonadState (RunInfo a i o m') m) =>-    i -> i -> 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--feedR ::-    (Monad m, MonadState (RunInfo a (Event i) o m') m) =>-    i -> m Bool-feedR x = feed_ (Event x) NoEvent---freeze ::-    Monad m =>-    RM a i o m (ProcessA a i o)-freeze = gets freezeRI--sweepR ::-    Monad m =>-    RM a i o m o-sweepR =-  do-    pa <- freeze-    ph <- gets getPhaseRI-    ri <- get-    case ph of-      Feed ->-        do-            fit0 <- gets getFitRI-            x <- gets getInputRI-            (y, pa') <- lift $ fit0 (feed pa) x-            put $ ri {-                freezeRI = pa',-                getPhaseRI = Sweep-              }-            return y-      Sweep ->-        do-            fit0 <- gets getFitRI-            x <- gets getPaddingRI-            (my, pa') <- lift $ fit0 (sweep pa) x-            put $ ri {-                freezeRI = pa',-                getPhaseRI = if isJust my then Sweep else Suspend-              }-            return $ fromMaybe (suspend pa x) my-      Suspend ->-        do-            x <- gets getPaddingRI-            return $ suspend pa x---sweepAll ::-    (ArrowApply a, Monoid r, Monad m) =>-    (o->r) ->-    ContT Bool (StateT r (RM a i (Event o) m)) ()-sweepAll outpre =-    callCC $ \sus -> forever $ cond sus >> body-  where-    cond sus =-      do-        ph <- lift $ lift $ gets getPhaseRI-        if ph == Suspend then sus () else return ()-    body =-      do-        evx <- lift $ lift $ sweepR-        case evx-          of-            Event x ->-              do-                lift $ modify' (`mappend` outpre x)-            NoEvent ->-                return ()-            End ->-                breakCont False--breakCont :: Monad m => r -> ContT r m a-breakCont = ContT . const . return----- | Run a machine with results concatenated in terms of a monoid.-runOn ::-    (ArrowApply a, Monoid r, Fd.Foldable f) =>-    (c -> r) ->-    ProcessA a (Event b) (Event c) ->-    a (f b) r-runOn outpre pa0 = unArrowMonad $ \xs ->-    runRM arrowMonad pa0 $ execStateT `flip` mempty $-      do-        _ <- evalContT $-          do-            -- Sweep initial events.-            sweepAll outpre--            -- Feed values-            Fd.mapM_ feedSweep xs--            return True--        -- Terminate.-        _ <- lift $ feed_ End End-        evalContT $ sweepAll outpre >> return True--  where-    feedSweep x =-      do-        _ <- lift $ lift $ feedR x-        sweepAll outpre---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 a machine.-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, -- ^ Values yielded while the step.-        hasConsumed :: Bool, -- ^ True if the input value is consumed.-            ---            -- False if the machine has stopped unless consuming the input.-            ---            -- Or in the case of `stepYield`, this field become false when-            -- the machine produces a value unless consuming the input.-        hasStopped :: Bool -- ^ True if the machine has stopped at the end of the step.-      }-    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 suspends.-stepRun ::-    ArrowApply a =>-    ProcessA a (Event b) (Event c) ->-    a b (ExecInfo [c], ProcessA a (Event b) (Event c))-stepRun pa0 = unArrowMonad $ \x ->-  do-    ((csmd, ct, pa), r)  <- runRM arrowMonad pa0 $ runStateT `flip` mempty $-      do-        csmd <- evalContT $-          do-            sweepAll singleton-            return True-        ct <- evalContT $-          do-            _ <- lift $ lift $ feedR x-            sweepAll singleton-            return True-        pa <- lift $ freeze-        return (csmd, ct, pa)-    return $ (retval r csmd ct, pa)-  where-    singleton x = Endo (x:)--    retval r csmd ct = ExecInfo {-        yields = appEndo r [],-        hasConsumed = csmd,-        hasStopped = not ct-      }---- | 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 $ feedR x-        modify $ \ri -> ri { hasConsumed = csmd }--        evo <- lift sweepR--        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 }-+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}++module+    Control.Arrow.Machine.Types+      (+        -- * Stream transducer type+        ProcessT(),+        ProcessA,++        -- * Event type and utility+        Occasional' (..),+        Occasional (..),+        Event (),+        noEvent,+        end,+        ZeroEvent(..),+        condEvent,+        filterEvent,+        filterJust,+        filterLeft,+        filterRight,+        splitEvent,+        evMap,++        -- * Coroutine monad+        -- | Procedural coroutine monad that can await or yield values.+        --+        -- Coroutines can be encoded to machines by `constructT` or so on and+        -- then put into `ProcessT` compositions.+        PlanT(..),+        Plan,++        MonadAwait (..),+        MonadYield (..),+        MonadStop (..),+        catchP,++        stopped,+        muted,++        -- * Constructing machines from plans+        constructT,+        repeatedlyT,++        construct,+        repeatedly,++        -- * Evolution monad+        -- | Time-evolution monad, or generalized plan monad.+        Evolution(..),+        packProc,+        awaitProc,+        yieldProc,++        -- * Running machines (at once)+        runT,+        runT_,+        run,+        run_,++        -- * Running machines (step-by-step)+        stepRun,+        stepYield,++        -- * Primitive machines - switches+        -- | Switches inspired by the 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,+        gSwitch,+        dgSwitch,+        pSwitch,+        pSwitchB,+        dpSwitch,+        dpSwitchB,+        rpSwitch,+        rpSwitchB,+        drpSwitch,+        drpSwitchB,+        par,+        parB,++        -- * Primitive machines - other safe primitives+        fit,+        fitW,++        -- * Primitive machines - unsafe+        unsafeExhaust,+      )+where++import qualified Control.Category as Cat+import Data.Profunctor (Profunctor, dimap, rmap)+import Data.Void+import Control.Arrow+import Control.Monad+import Control.Monad.Trans+import Control.Monad.State.Strict+import Control.Monad.Reader+import Control.Monad.Writer hiding ((<>))+import Control.Monad.Identity+import Control.Monad.Trans.Cont+import Control.Applicative+import qualified Data.Foldable as Fd+import Data.Traversable as Tv+import Data.Semigroup (Semigroup, (<>))+import Data.Maybe (fromMaybe, isNothing, isJust)+import qualified Control.Monad.Trans.Free.Church as F+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 ProcType a b c = ProcessT a b c++class Stepper m b c s | s -> m, s -> b, s -> c+  where+    feed :: s -> b -> m (c, s)+    sweep :: s -> b -> m (Maybe c, s)+    suspend :: s -> b -> c++-- | The stream transducer arrow.+--+-- To construct `ProcessT` instances, use `Control.Arrow.Machine.Plan.Plan`,+-- `arr`, functions declared in `Control.Arrow.Machine.Utils`,+-- or arrow combinations of them.+--+-- See an introduction at "Control.Arrow.Machine" documentation.+data ProcessT m b c = ProcessT {+    paFeed :: b -> m (c, ProcessT m b c),+    paSweep :: b -> m (Maybe c, ProcessT m b c),+    paSuspend :: !(b -> c)+  }++-- | Isomorphic to ProcessT when 'a' is ArrowApply.+type ProcessA a = ProcessT (ArrowMonad a)++instance+    Stepper a b c (ProcessT a b c)+  where+    feed = paFeed+    sweep = paSweep+    suspend = paSuspend++toProcessT ::+    (Monad m, Stepper m b c s) =>+    s -> ProcessT m b c+toProcessT s = ProcessT {+    paFeed = liftM (second toProcessT) . feed s,+    paSweep = liftM (second toProcessT) . sweep s,+    paSuspend = suspend s+  }+{-# INLINE[2] toProcessT  #-}++-- For internal use+class+    (Applicative f, Monad f) => ProcessHelper f+  where+    step ::+        (Monad m, Stepper m b c s) =>+        s -> b -> m (f c, s)+    helperToMaybe :: f a -> Maybe a+    weakly :: a -> f a++    compositeStep ::+        (Monad m, Stepper m b p s1, Stepper m p c s2) =>+        s1 -> s2 ->+        b -> m (f c, s1, s2)+++instance+    ProcessHelper Identity+  where+    step pa = liftM (first Identity) . feed pa+    helperToMaybe = Just . runIdentity+    weakly = Identity+    compositeStep sf test x =+      do+        (y, sf') <- feed sf x+        (z, test') <- feed test y+        return (return z, sf', test')++instance+    ProcessHelper Maybe+  where+    step = sweep+    helperToMaybe = id+    weakly _ = Nothing+    compositeStep sf0 test0 x =+      do+        let y = suspend sf0 x+        (mt, test') <- sweep test0 y+        case mt+          of+            Just t -> return (Just t, sf0, test')+            Nothing -> next sf0 test'++      where+        next sf test =+          do+            (my, sf') <- sweep sf x+            case my+              of+                Just y -> next2 y sf' test+                Nothing -> return (Nothing, sf', test)++        next2 y sf test =+          do+            (t, test') <- feed test y+            return (Just t, sf, test')++makePA ::+    Monad m =>+    (forall f. ProcessHelper f =>+        b -> m (f c, ProcessT m b c)) ->+    (b -> c) ->+    ProcessT m b c+makePA h !sus = ProcessT {+    paFeed = liftM (first runIdentity) . h,+    paSweep = h,+    paSuspend = sus+  }+++data CompositeStep m b c s1 s2+  where+    CompositeStep ::+        (Stepper m b p s1, Stepper m p c s2) =>+        s1 -> s2 ->+        CompositeStep m b c s1 s2++instance+    Monad m => Stepper m b c (CompositeStep m b c s1 s2)+  where+    feed (CompositeStep s1 s2) x =+      do+        (fz, s1', s2') <- compositeStep s1 s2 x+        return (runIdentity fz, CompositeStep s1' s2')+    sweep (CompositeStep s1 s2) x =+      do+        (fz, s1', s2') <- compositeStep s1 s2 x+        return (fz, CompositeStep s1' s2')+    suspend (CompositeStep s1 s2) =+        suspend s2 . suspend s1+++data IDStep m b c+  where+    IDStep :: IDStep (m :: * -> *) b b++instance+    Monad m => Stepper m b c (IDStep m b c)+  where+    feed IDStep x = return (x, IDStep)+    sweep IDStep _ = return (Nothing, IDStep)+    suspend IDStep = id++newtype ArrStep (m :: * -> *) b c = ArrStep (b -> c)++instance+    Monad m => Stepper m b c (ArrStep m b c)+  where+    feed (ArrStep f) x = return (f x, ArrStep f)+    sweep (ArrStep f) _ = return (Nothing, ArrStep f)+    suspend (ArrStep f) = f+++data ParStep m b c s1 s2+  where+    ParStep ::+        (Stepper m b1 c1 s1, Stepper m b2 c2 s2) =>+        s1 -> s2 ->+        ParStep m (b1, b2) (c1, c2) s1 s2++instance+    Monad m => Stepper m b c (ParStep m b c s1 s2)+  where+    feed (ParStep f g)  (x1, x2) =+      do+        (y1, f') <- feed f x1+        (y2, g') <- feed g x2+        return ((y1, y2), ParStep f' g')+    sweep (ParStep f g) (x1, x2) =+      do+        (my1, f') <- sweep f x1+        (my2, g') <- sweep g x2+        let y1 = fromMaybe (suspend f' x1) my1 -- suspend f ?+            y2 = fromMaybe (suspend g' x2) my2+            r = if (isNothing my1 && isNothing my2) then Nothing else Just (y1, y2)+        return (r, ParStep f' g')+    suspend (ParStep f g) = suspend f *** suspend g+++-- |Natural transformation+fit ::+    (Monad m, Monad m') =>+    (forall p. m p -> m' p) ->+    ProcessT m b c -> ProcessT m' b c+fit f pa =+    arr Identity >>>+    fitW runIdentity (\ar (Identity x) -> f (ar x)) pa++-- |Experimental: more general fit.+--+-- Should w be a comonad?+fitW :: (Monad m, Monad m', Functor w) =>+    (forall p. w p -> p) ->+    (forall p q. (p -> m q) -> w p -> m' q) -> +    ProcessT m b c -> ProcessT m' (w b) c+fitW extr f pa = makePA+    (liftM (second $ fitW extr f) . f (step pa))+    (extr >>> suspend pa)++instance+    Monad m => Profunctor (ProcessT m)+  where+    dimap = dimapProc+    {-# INLINE dimap #-}++dimapProc ::+    Monad m =>+    (b->c)->(d->e)->+    ProcType m c d -> ProcType m b e+dimapProc f g pa = makePA+    (liftM (fmap g *** dimapProc f g) . step pa . f)+    (dimap f g (suspend pa))++{-# NOINLINE dimapProc #-}+++instance+    Monad m => Functor (ProcessT m i)+  where+    fmap = rmap++instance+    Monad m => Applicative (ProcessT m i)+  where+    pure = arr . const+    pf <*> px = (pf &&& px) >>> arr (uncurry ($))++instance+    (Monad m, Monoid o) => Monoid (ProcessT m i o)+  where+    mempty = pure mempty+    mappend = liftA2 mappend++instance+    Monad m => Cat.Category (ProcessT m)+  where+    id = idProc+    {-# INLINE id #-}++    g . f = compositeProc f g+    {-# INLINE (.) #-}+++instance+    Monad m => Arrow (ProcessT m)+  where+    arr = arrProc+    {-# INLINE arr #-}++    first pa = parProc pa idProc+    {-# INLINE first #-}++    second pa = parProc idProc pa+    {-# INLINE second #-}++    (***) = parProc+    {-# INLINE (***) #-}+++parProc :: Monad m =>+    ProcType m b c ->+    ProcType m d e ->+    ProcType m (b, d) (c, e)+parProc f g = toProcessT $ ParStep f g+{-# INLINE [0] parProc #-}++idProc :: Monad m => ProcType m b b+idProc = let pa = makePA (\x -> return (weakly x, pa)) id in pa+{-# NOINLINE idProc #-}++arrProc :: Monad m => (b->c) -> ProcType m b c+arrProc f = let pa = makePA (\x -> return (weakly (f x), pa)) f in pa+{-# NOINLINE arrProc #-}++-- |Composition is proceeded by the backtracking strategy.+compositeProc :: Monad m =>+              ProcType m b d -> ProcType m d c -> ProcType m b c+compositeProc f0 g0 = ProcessT {+    paFeed = \x ->+      do+        (y, f') <- feed f0 x+        (z, g') <- feed g0 y+        return (z, compositeProc f' g'),+    paSweep = \x ->+      do+        (mz, g') <- sweep g0 $ suspend f0 x+        case mz+          of+            Just z -> return (Just z, compositeProc f0 g')+            Nothing -> btrk f0 g' x,+    paSuspend = suspend f0 >>> suspend g0+  }+  where+    btrk f g x =+      do+        (my, f') <- sweep f x+        (mz, g') <-+            case my+              of+                Just y ->+                  do+                    (z, g') <- feed g y+                    return (Just z, g')+                Nothing ->+                    return (Nothing, g)+        return (mz, compositeProc f' g')++{-# NOINLINE compositeProc #-}++-- rules+{-# RULES+"ProcessT: id/*"+    forall g. compositeProc idProc g = g+"ProcessT: */id"+    forall f. compositeProc f idProc = f++"ProcessT: concat/concat"+    forall f g h. compositeProc (compositeProc f g) h = compositeProc f (compositeProc g h)++"ProcessT: dimap/dimap"+    forall f g h i j. dimapProc f j (dimapProc g i h)  = dimapProc (g . f) (j . i) h+"ProcessT: dimap/arr"+    forall f g h. dimapProc f h (arrProc g) = arrProc (h . g . f)++"ProcessT: arr***/par"+    forall f1 f2 g1 g2 h. compositeProc (parProc f1 (arrProc f2)) (compositeProc (parProc g1 g2) h) =+        compositeProc (parProc (compositeProc f1 g1) (dimapProc f2 id g2)) h+"ProcessT: arr***/par-2"+    forall f1 f2 g1 g2. compositeProc (parProc f1 (arrProc f2)) (parProc g1 g2) =+        parProc (compositeProc f1 g1) (dimapProc f2 id g2)+"ProcessT: par/***arr"+    forall f1 f2 g1 g2 h. compositeProc (parProc f1 f2) (compositeProc (parProc (arrProc g1) g2) h) =+        compositeProc (parProc (dimapProc id g1 f1) (compositeProc f2 g2)) h+"ProcessT: par/***arr-2"+    forall f1 f2 g1 g2. compositeProc (parProc f1 f2) (parProc (arrProc g1) g2) =+        parProc (dimapProc id g1 f1) (compositeProc f2 g2)++"ProcessT: first/par"+    forall f1 g1 g2 h. compositeProc (parProc f1 idProc) (compositeProc (parProc g1 g2) h) =+        compositeProc (parProc (compositeProc f1 g1) g2) h+"ProcessT: first/par-2"+    forall f1 g1 g2. compositeProc (parProc f1 idProc) (parProc g1 g2) =+        parProc (compositeProc f1 g1) g2+"ProcessT: par/second"+    forall f1 f2 g2 h. compositeProc (parProc f1 f2) (compositeProc (parProc idProc g2) h) =+        compositeProc (parProc f1 (compositeProc f2 g2)) h+"ProcessT: par/second-2"+    forall f1 f2 g2. compositeProc (parProc f1 f2) (parProc idProc g2) =+        parProc f1 (compositeProc f2 g2)++"ProcessT: arr/arr"+    forall f g h. compositeProc (arrProc f) (compositeProc (arrProc g) h) =+        compositeProc (arrProc (g . f)) h+"ProcessT: arr/arr-2"+    forall f g. compositeProc (arrProc f) (arrProc g) = arrProc (g . f)+"ProcessT: arr/*" [1]+    forall f g. compositeProc (arrProc f) g = dimapProc f id g+"ProcessT: */arr" [1]+    forall f g. compositeProc f (arrProc g) = dimapProc id g f+"ProcessT: arr***arr" [1]+    forall f g. parProc (arrProc f) (arrProc g) = arrProc (f *** g)+  #-}++instance+    Monad m => ArrowChoice (ProcessT m)+  where+    left pa0 = makePA+        (\eth -> sweep' pa0 eth)+        (left $ suspend pa0)+      where+        sweep' pa (Left x) =+          do+            (my, pa') <- step pa x+            return (Left <$> my, left pa')+        sweep' pa (Right d) =+            return (weakly (Right d), left pa)++instance+    Monad m => ArrowLoop (ProcessT m)+  where+    loop pa =+        makePA+            (\x ->+              do+                (hyd, pa') <- step pa (x, loopSusD x)+                return (fst <$> hyd, loop pa'))+            (loop $ suspend pa)+      where+        loopSusD = loop (suspend pa >>> \(_, d) -> (d, d))+++-- | Discrete events on a time line.+-- Created and consumed by various transducers.+data Event a = Event a | NoEvent | End+++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 monoid sum of all member occasionals.+class+    Occasional' a+  where+    collapse :: a -> Event ()++-- | Occasional signals with creation methods.+class+    Occasional' a => Occasional a+  where+    burst :: Event Void -> a+++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+    burst = burst &&& burst++instance+    Occasional' (Event a)+  where+    collapse = (() <$)++instance+    Occasional (Event a)+  where+    burst = fmap absurd++noEvent :: Occasional a => a+noEvent = burst NoEvent++end :: Occasional a => a+end = burst End++data ZeroEvent = ZeroEvent deriving (Eq, Show, Enum, Bounded)++instance+    Monoid ZeroEvent+  where+    mempty = ZeroEvent+    mappend _ _ = ZeroEvent++instance+    Occasional' ZeroEvent+  where+    collapse _ = mempty+++condEvent :: Bool -> Event a -> Event a+condEvent _ End = End+condEvent True ev = ev+condEvent False _ = NoEvent++filterEvent ::+    Arrow ar =>+    (a -> Bool) ->+    ar (Event a) (Event a)+filterEvent cond = filterJust <<< evMap mcond+  where+    mcond x+        | cond x = Just x+        | otherwise = Nothing++filterJust ::+    Arrow ar => ar (Event (Maybe a)) (Event a)+filterJust = arr filterJust'+  where+    filterJust' (Event (Just x)) = Event x+    filterJust' (Event Nothing) = NoEvent+    filterJust' NoEvent = NoEvent+    filterJust' End = End++-- |Split an event stream.+--+-- >>> run (filterLeft) [Left 1, Right 2, Left 3, Right 4]+-- [1,3]+filterLeft ::+    Arrow ar =>+    ar (Event (Either a b)) (Event a)+filterLeft = filterJust <<< evMap (either Just (const Nothing))++-- |Split an event stream.+--+-- >>> run filterRight [Left 1, Right 2, Left 3, Right 4]+-- [2,4]+filterRight ::+    Arrow ar =>+    ar (Event (Either a b)) (Event b)+filterRight = filterJust <<< evMap (either (const Nothing) Just)++-- |Split an event stream.+--+-- >>> run (splitEvent >>> arr fst) [Left 1, Right 2, Left 3, Right 4]+-- [1,3]+--+-- >>> run (splitEvent >>> arr snd) [Left 1, Right 2, Left 3, Right 4]+-- [2,4]+splitEvent ::+    Arrow ar =>+    ar (Event (Either a b)) (Event a, Event b)+splitEvent = filterLeft &&& filterRight++-- | Alias of "arr . fmap"+--+-- While "ProcessT 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++++muted ::+    (Monad m, Occasional' b, Occasional c) => ProcessT m b c+muted = arr collapse >>> repeatedly await >>> arr burst++-- | A monad type represents time evolution of ProcessT+newtype Evolution i o m r = Evolution+  {+    runEvolution :: Cont (ProcessT m i o) r+  }+  deriving+    (Functor, Applicative, Monad)++instance+    Occasional o =>+    MonadTrans (Evolution i o)+  where+    {-# INLINE lift #-}+    lift ma = Evolution $ cont $ \fmpf -> packProc (fmpf <$> ma)++instance+    (MonadIO m, Occasional o) =>+    MonadIO (Evolution i o m)+  where+    {-# INLINE liftIO #-}+    liftIO ma = lift $ liftIO ma+++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+++newtype PlanT i o m a =+    PlanT { freePlanT :: F.FT (PlanF i o) m a }+  deriving+    (Functor, Applicative, Monad)++type Plan i o a = forall m. Monad m => PlanT i o m a++packProc ::+    (Monad m, Occasional o) =>+    m (ProcessT m i o) ->+    ProcessT m i o+packProc !mp = ProcessT {+    paFeed = \ex -> mp >>= \p -> feed p ex ,+    paSweep = \ex -> mp >>= \p -> sweep p ex,+    paSuspend = const noEvent+  }+{-# INLINE[0] packProc #-}+{-# RULES+"ProcessT: return/packProc"+    forall p. return (packProc p) = p+ #-}+{-+"ProcessT: packProc/return"+    forall p. packProc (return p) = p+ -}++instance+    MonadTrans (PlanT i o)+  where+    lift mx = PlanT $ lift mx+    {-# INLINE lift #-}++instance+    MonadReader r m => MonadReader r (PlanT i o m)+  where+    ask = lift ask+    local f mx = PlanT $ local f (freePlanT mx)++instance+    MonadWriter w m => MonadWriter w (PlanT i o m)+  where+    tell = lift . tell+    listen mx = PlanT $ listen (freePlanT mx)+    pass mx = PlanT $ pass (freePlanT mx)++instance+    MonadState s m => MonadState s (PlanT i o m)+  where+    get = lift get+    put x = lift $ put x++instance+    Monad m => Alternative (PlanT i o m)+  where+    empty = stop+    (<|>) = catchP++instance+    Monad m => MonadPlus (PlanT i o m)+  where+    mzero = stop+    mplus = catchP++instance+    MonadIO m => MonadIO (PlanT i o m)+  where+    liftIO = lift . liftIO+    {-# INLINE liftIO #-}++class+    MonadAwait m a | m -> a+  where+    await :: m a++instance+    Monad m => MonadAwait (PlanT i o m) i+  where+    {-# INLINE await #-}+    await = PlanT $ F.wrap $ AwaitPF return (F.liftF StopPF)++instance+    (Monad m, Occasional o) =>+    MonadAwait (Evolution (Event a) o m) a+  where+    {-# INLINE await #-}+    await = Evolution $ cont $ \next -> awaitProc next stopped++class+    MonadYield m a | m -> a+  where+    yield :: a -> m ()++instance+    Monad m => MonadYield (PlanT i o m) o+  where+    {-# INLINE yield #-}+    yield x = PlanT $ F.liftF $ YieldPF x ()++instance+    Monad m => MonadYield (Evolution i (Event a) m) a+  where+    {-# INLINE yield #-}+    yield x = Evolution $ cont $ \next -> yieldProc x (next ())++class+    MonadStop m+  where+    stop :: m a++instance+    Monad m => MonadStop (PlanT i o m)+  where+    {-# INLINE stop #-}+    stop = PlanT $ F.liftF StopPF++instance+    (Monad m, Occasional o) =>+    MonadStop (Evolution i o m)+  where+    {-# INLINE stop #-}+    stop = Evolution $ cont $ const stopped++catchP:: Monad m =>+    PlanT i o m a -> PlanT i o m a -> PlanT i o m a++catchP (PlanT pl) next0 =+    PlanT $ F.FT $ \pr free ->+        F.runFT pl pr (free' next0 pr free)+  where+    free' ::+        Monad m =>+        PlanT i o m a ->+        (a -> m r) ->+        (forall x. (x -> m r) -> PlanF i o x -> m r) ->+        (y -> m r) ->+        (PlanF i o y) ->+        m r+    free' (PlanT next) pr free r pl' =+        let nextR = F.runFT next pr free+            go StopPF = nextR+            go (AwaitPF f ff) =+                free (either (\_ -> nextR) r) $ AwaitPF (Right . f) (Left ff)+            go _ = free r pl'+          in+            go pl'++{-# INLINE awaitProc #-}+awaitProc ::+    (Monad m, Occasional o) =>+    (a -> ProcessT m (Event a) o) ->+    ProcessT m (Event a) o ->+    ProcessT m (Event a) o+awaitProc f ff = awaitProc'+  where+    awaitProc' = ProcessT {+        paFeed = awaitFeed,+        paSweep = awaitSweep,+        paSuspend = const noEvent+      }++    awaitFeed (Event x) = feed (f x) NoEvent+    awaitFeed NoEvent = return (noEvent, awaitProc')+    awaitFeed End = feed ff End++    awaitSweep (Event x) = sweep (f x) NoEvent+    awaitSweep NoEvent = return (Nothing, awaitProc')+    awaitSweep End = sweep ff End++{-# INLINE yieldProc #-}+yieldProc ::+    Monad m =>+    a ->+    ProcessT m i (Event a) ->+    ProcessT m i (Event a)+yieldProc y pa = ProcessT {+    paFeed = \_ -> return (Event y, pa),+    paSweep = \_ -> return (Just (Event y), pa),+    paSuspend = const NoEvent+  }++{-# INLINE stopped #-}+stopped ::+    (Monad m, Occasional o) =>+    ProcessT m i o+stopped = ProcessT {+    paFeed = \_ -> return (end, arr (const end)),+    paSweep = \_ -> return (Just end, arr (const end)),+    paSuspend = pure end+  }++{-# INLINE constructT #-}+constructT ::+    (Monad m) =>+    PlanT i o m r ->+    ProcessT m (Event i) (Event o)+constructT pl0 = runCont (runEvolution $ realizePlan pl0) (const stopped)++{-# INLINE realizePlan #-}+realizePlan ::+    Monad m =>+    PlanT i o m a ->+    Evolution (Event i) (Event o) m a+realizePlan pl = Evolution $ cont $ \next ->+    packProc $ F.runFT (freePlanT pl) (return . next) (\b fr -> return $ free (packProc . b <$> fr))+  where+    free ::+        Monad m => PlanF i o (ProcessT m (Event i) (Event o)) -> ProcessT m (Event i) (Event o)+    free (AwaitPF f ff) = awaitProc f ff+    free (YieldPF y pa) = yieldProc y pa+    free StopPF = stopped++{-# INLINE repeatedlyT #-}+repeatedlyT ::+    Monad m =>+    PlanT i o m r ->+    ProcessT m (Event i) (Event o)+repeatedlyT pl0 = runCont (forever $ runEvolution $ realizePlan pl0) absurd+++-- for pure+{-# INLINE construct #-}+construct ::+    Monad m =>+    PlanT i o Identity r ->+    ProcessT m (Event i) (Event o)+construct = fit (return . runIdentity) . constructT++{-# INLINE repeatedly #-}+repeatedly ::+    Monad m =>+    PlanT i o Identity r ->+    ProcessT m (Event i) (Event o)+repeatedly = fit (return . runIdentity) . repeatedlyT+++--+-- Switches+--++-- |Run the 1st transducer at the beggining. Then switch to 2nd when Event t occurs.+--+-- >>> :{+-- let+--     before = proc x ->+--       do+--         trigger <- filterEvent (== 3) -< x+--         returnA -< ((*10) <$> x, trigger)+--     after t = proc x -> returnA -< (*100) <$> x+--  in+--     run (switch before after) [1..5]+-- :}+-- [10,20,300,400,500]+switch ::+    Monad m =>+    ProcessT m b (c, Event t) ->+    (t -> ProcessT m b c) ->+    ProcessT m b c+switch sf k = ggSwitch (const ()) sf (\() -> k)+++-- |Delayed version of `switch`+--+-- >>> :{+-- let+--     before = proc x ->+--       do+--         trigger <- filterEvent (== 3) -< x+--         returnA -< ((*10) <$> x, trigger)+--     after t = proc x -> returnA -< (*100) <$> x+--  in+--     run (dSwitch before after) [1..5]+-- :}+-- [10,20,30,400,500]+dSwitch ::+    Monad m =>+    ProcessT m b (c, Event t) ->+    (t -> ProcessT m b c) ->+    ProcessT m b c+dSwitch sf k = dggSwitch (const ()) sf (\() -> k)++-- |Recurring switch.+--+-- >>> :{+-- let pa = proc evtp ->+--       do+--         evx <- returnA -< fst <$> evtp+--         evarr <- filterJust -< snd <$> evtp+--         rSwitch (evMap (*10)) -< (evx, evarr)+--     l = [(1, Nothing),+--          (2, Just (arr $ fmap (*100))),+--          (3, Nothing),+--          (4, Just (arr $ fmap (*1000))),+--          (5, Nothing)]+--   in+--     run pa l+-- :}+-- [10,200,300,4000,5000]+rSwitch ::+    Monad m =>+    ProcessT m b c ->+    ProcessT m (b, Event (ProcessT m b c)) c+rSwitch p = rSwitch' (p *** Cat.id) >>> arr fst+  where+    rSwitch' pid = kSwitch pid test $ \_ p' -> rSwitch'' (p' *** Cat.id)+    rSwitch'' pid = dkSwitch pid test $ \s _ -> rSwitch' s+    test = proc (_, (_, r)) -> returnA -< r+++-- |Delayed version of `rSwitch`.+--+-- >>> :{+-- let pa = proc evtp ->+--       do+--         evx <- returnA -< fst <$> evtp+--         evarr <- filterJust -< snd <$> evtp+--         drSwitch (evMap (*10)) -< (evx, evarr)+--     l = [(1, Nothing),+--          (2, Just (arr $ fmap (*100))),+--          (3, Nothing),+--          (4, Just (arr $ fmap (*1000))),+--          (5, Nothing)]+--   in+--     run pa l+-- :}+-- [10,20,300,400,5000]+drSwitch ::+    Monad m => ProcessT m b c ->+    ProcessT m (b, Event (ProcessT m b c)) c++drSwitch p =  drSwitch' (p *** Cat.id)+  where+    drSwitch' pid = dSwitch pid $ \p' -> drSwitch' (p' *** Cat.id)+++kSwitch ::+    Monad m =>+    ProcessT m b c ->+    ProcessT m (b, c) (Event t) ->+    (ProcessT m b c -> t -> ProcessT m b c) ->+    ProcessT m b c+kSwitch sf test =+    ggSwitch+        (\(CompositeStep _ (CompositeStep (ParStep IDStep sf') _)) -> sf')+        (CompositeStep (ArrStep (id &&& id))+           (CompositeStep (ParStep IDStep sf) (arr snd &&& test)))+++dkSwitch ::+    Monad m =>+    ProcessT m b c ->+    ProcessT m (b, c) (Event t) ->+    (ProcessT m b c -> t -> ProcessT m b c) ->+    ProcessT m b c+dkSwitch sf test =+    dggSwitch+        (\(CompositeStep _ (CompositeStep (ParStep IDStep sf') _)) -> sf')+        (CompositeStep (ArrStep (id &&& id))+           (CompositeStep (ParStep IDStep sf) (arr snd &&& test)))++ggSwitch ::+    (Monad m, Stepper m b (c, Event t) sWhole) =>+    (sWhole -> s) ->+    sWhole ->+    (s -> t -> ProcessT m b c) ->+    ProcessT m b c+ggSwitch picker whole k = makePA+    (\x ->+      do+        let+        (hyevt, whole') <- step whole x+        let hy = fst <$> hyevt+            hevt = snd <$> hyevt+        case (helperToMaybe hevt)+          of+            Just (Event t) -> step (k (picker whole') t) x+            _ -> return (hy, ggSwitch picker whole' k))+    (arr fst . suspend whole)++dggSwitch ::+    (Monad m, Stepper m b (c, Event t) sWhole) =>+    (sWhole -> s) ->+    sWhole ->+    (s -> t -> ProcessT m b c) ->+    ProcessT m b c+dggSwitch picker whole k = makePA+    (\x ->+      do+        let+        (hyevt, whole') <- step whole x+        let hy = fst <$> hyevt+            hevt = snd <$> hyevt+        case (helperToMaybe hevt)+          of+            Just (Event t) -> return (hy, k (picker whole') t)+            _ -> return (hy, dggSwitch picker whole' k))+    (arr fst . suspend whole)++gSwitch ::+    Monad m =>+    ProcessT m b (p, r) ->+    ProcessT m p q ->+    ProcessT m (q, r) (c, Event t) ->+    (ProcessT m p q -> t -> ProcessT m b c) ->+    ProcessT m b c+gSwitch pre sf post =+    ggSwitch+        (\(CompositeStep _ (CompositeStep (ParStep sf' IDStep) _)) -> sf')+        (CompositeStep pre (CompositeStep (ParStep sf IDStep) post))++dgSwitch ::+    Monad m =>+    ProcessT m b (p, r) ->+    ProcessT m p q ->+    ProcessT m (q, r) (c, Event t) ->+    (ProcessT m p q -> t -> ProcessT m b c) ->+    ProcessT m b c+dgSwitch pre sf post =+    dggSwitch+        (\(CompositeStep _ (CompositeStep (ParStep sf' IDStep) _)) -> sf')+        (CompositeStep pre (CompositeStep (ParStep sf IDStep) post))++broadcast ::+    Functor col =>+    b -> col sf -> col (b, sf)+broadcast x sfs = fmap (\sf -> (x, sf)) sfs++par ::+    (Monad m, Tv.Traversable col) =>+    (forall sf. (b -> col sf -> col (ext, sf))) ->+    col (ProcessT m ext c) ->+    ProcessT m b (col c)+par r sfs = toProcessT (PluralStep r sfs)++parB ::+    (Monad m, Tv.Traversable col) =>+    col (ProcessT m b c) ->+    ProcessT m b (col c)+parB = par broadcast+++data PluralStep ext col m b c+  where+    PluralStep ::+        (forall sf. (b -> col sf -> col (ext, sf))) ->+        (col (ProcessT m ext c)) ->+        PluralStep ext col m b c+++instance+    (Monad m, Tv.Traversable col) =>+    Stepper m b (col c) (PluralStep ext col m b c)+  where+    feed (PluralStep r sfs) = liftM (runIdentity *** PluralStep r) . parCore r sfs+    sweep (PluralStep r sfs) = liftM (id *** PluralStep r) . parCore r sfs+    suspend (PluralStep r sfs) = suspendAll r sfs++suspendAll ::+    (Monad m, Tv.Traversable col) =>+    (forall sf. (b -> col sf -> col (ext, sf))) ->+    col (ProcessT m ext c) ->+    b -> col c+suspendAll r sfs = (sus <$>) . (r `flip` sfs)+  where+    sus (ext, sf) = suspend sf ext++traverseResult ::+    forall h col c.+    (Tv.Traversable col, ProcessHelper h) =>+    col (h c, c) -> h (col c)+traverseResult zs =+    let+        pr :: (h c, c) -> StateT Bool h c+        pr (hx, d) =+          do+            let mx = helperToMaybe hx+            if isJust mx then put True else return ()+            return (fromMaybe d mx)+        hxs = runStateT (Tv.sequence (pr <$> zs)) False+        exist = fromMaybe False $ helperToMaybe (snd <$> hxs)+        result = fst <$> hxs+      in+        if exist then result else join (weakly result)++parCore ::+    (Applicative m, Monad m, Tv.Traversable col, ProcessHelper h) =>+    (forall sf. (b -> col sf -> col (ext, sf))) ->+    col (ProcessT m ext c) ->+    b -> m (h (col c), col (ProcessT m ext c))+parCore r sfs x =+  do+    let input = r x sfs+    ret <- Tv.sequenceA $ fmap app' input+    let zs = traverseResult $ fmap fst ret+        sfs' = fmap snd ret+    return (zs, sfs')+  where+    app' (y, sf) =+      do+        (hz, sf') <- step sf y+        return ((hz, suspend sf' y), sf')++pSwitch ::+    (Monad m, Tv.Traversable col) =>+    (forall sf. (b -> col sf -> col (ext, sf))) ->+    col (ProcessT m ext c) ->+    ProcessT m (b, col c) (Event mng) ->+    (col (ProcessT m ext c) -> mng -> ProcessT m b (col c)) ->+    ProcessT m b (col c)+pSwitch r sfs test =+    ggSwitch+        (\(CompositeStep _+            (CompositeStep (ParStep IDStep (PluralStep _ sfs')) _)) -> sfs')+        (CompositeStep (ArrStep (id &&& id))+            (CompositeStep (ParStep IDStep (PluralStep r sfs)) (arr snd &&& test)))++pSwitchB ::+    (Monad m, Tv.Traversable col) =>+    col (ProcessT m b c) ->+    ProcessT m (b, col c) (Event mng) ->+    (col (ProcessT m b c) -> mng -> ProcessT m b (col c)) ->+    ProcessT m b (col c)+pSwitchB = pSwitch broadcast++dpSwitch ::+    (Monad m, Tv.Traversable col) =>+    (forall sf. (b -> col sf -> col (ext, sf))) ->+    col (ProcessT m ext c) ->+    ProcessT m (b, col c) (Event mng) ->+    (col (ProcessT m ext c) -> mng -> ProcessT m b (col c)) ->+    ProcessT m b (col c)+dpSwitch r sfs test =+    dggSwitch+        (\(CompositeStep _+            (CompositeStep (ParStep IDStep (PluralStep _ sfs')) _)) -> sfs')+        (CompositeStep (ArrStep (id &&& id))+            (CompositeStep (ParStep IDStep (PluralStep r sfs)) (arr snd &&& test)))++dpSwitchB ::+    (Monad m, Tv.Traversable col) =>+    col (ProcessT m b c) ->+    ProcessT m (b, col c) (Event mng) ->+    (col (ProcessT m b c) -> mng -> ProcessT m b (col c)) ->+    ProcessT m b (col c)+dpSwitchB = dpSwitch broadcast++rpSwitch ::+    (Monad m, Tv.Traversable col) =>+    (forall sf. (b -> col sf -> col (ext, sf))) ->+    col (ProcessT m ext c) ->+    ProcessT m+        (b, Event (col (ProcessT m ext c) -> col (ProcessT m ext c)))+        (col c)+rpSwitch r sfs =+    ggSwitch+        (\(ParStep (PluralStep _ sfs') IDStep) -> sfs')+        (ParStep (PluralStep r sfs) IDStep)+        (\sfs' tr -> next r (tr sfs'))+  where+    next ::+        (Monad m, Tv.Traversable col) =>+        (forall sf. (b -> col sf -> col (ext, sf))) ->+        col (ProcessT m ext c) ->+        ProcessT m+            (b, Event (col (ProcessT m ext c) -> col (ProcessT m ext c)))+            (col c)+    next r' sfs' =+        dggSwitch+            (\(ParStep (PluralStep _ sfs'') IDStep) -> sfs'')+            (ParStep (PluralStep r' sfs') IDStep)+            (\sfs'' _ -> rpSwitch r' sfs'')+++rpSwitchB ::+    (Monad m, Tv.Traversable col) =>+    col (ProcessT m b c) ->+    ProcessT m+        (b, Event (col (ProcessT m b c) -> col (ProcessT m b c)))+        (col c)+rpSwitchB = rpSwitch broadcast+++drpSwitch ::+    (Monad m, Tv.Traversable col) =>+    (forall sf. (b -> col sf -> col (ext, sf))) ->+    col (ProcessT m ext c) ->+    ProcessT m+        (b, Event (col (ProcessT m ext c) -> col (ProcessT m ext c)))+        (col c)+drpSwitch r sfs =+    dggSwitch+        (\(ParStep (PluralStep _ sfs') IDStep) -> sfs')+        (ParStep (PluralStep r sfs) IDStep)+        (\sfs' tr -> drpSwitch r (tr sfs'))++drpSwitchB ::+    (Monad m, Tv.Traversable col) =>+    col (ProcessT m b c) ->+    ProcessT m+        (b, Event (col (ProcessT m b c) -> col (ProcessT m b c)))+        (col c)+drpSwitchB = drpSwitch broadcast+++--+-- Unsafe primitives+--++-- | 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 ::+    (Monad m, Fd.Foldable f) =>+    (b -> m (f c)) ->+    ProcessT m b (Event c)+unsafeExhaust p =+    go >>> fork+  where+    go = ProcessT {+        paFeed = \x -> do {y <- p x; return (Event y, go)},+        paSweep = \x -> do {y <- p x; return (if nullFd y then Nothing else Just (Event y), go)},+        paSuspend = const NoEvent+      }++    fork = repeatedly $ await >>= Fd.mapM_ yield++    nullFd = getAll . Fd.foldMap (\_ -> All False)+++--+-- Running+--++--+-- Running Monad (To be exported)+--+data RunInfo i o m = RunInfo {+    freezeRI :: !(ProcessT m i o),+    getInputRI :: !i,+    getPaddingRI :: !i,+    getPhaseRI :: !Phase+  }++type RM i o m = StateT (RunInfo i o m) m++runRM ::+    Monad m' =>+    ProcessT m (Event i) o ->+    StateT (RunInfo (Event i) o m) m' x ->+    m' x+runRM pa mx =+    evalStateT mx $+        RunInfo {+            freezeRI = pa,+            getInputRI = NoEvent,+            getPaddingRI = NoEvent,+            getPhaseRI = Sweep+          }++++feed_ ::+    (Monad m, MonadState (RunInfo i o m') m) =>+    i -> i -> 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++feedR ::+    (Monad m, MonadState (RunInfo (Event i) o m') m) =>+    i -> m Bool+feedR x = feed_ (Event x) NoEvent+++freeze ::+    Monad m =>+    RM i o m (ProcessT m i o)+freeze = gets freezeRI++sweepR ::+    Monad m =>+    RM i o m o+sweepR =+  do+    pa <- freeze+    ph <- gets getPhaseRI+    ri <- get+    case ph of+      Feed ->+        do+            x <- gets getInputRI+            (y, pa') <- lift $ feed pa x+            put $ ri {+                freezeRI = pa',+                getPhaseRI = Sweep+              }+            return y+      Sweep ->+        do+            x <- gets getPaddingRI+            (my, pa') <- lift $ sweep pa x+            put $ ri {+                freezeRI = pa',+                getPhaseRI = if isJust my then Sweep else Suspend+              }+            return $ fromMaybe (suspend pa x) my+      Suspend ->+        do+            x <- gets getPaddingRI+            return $ suspend pa x+++sweepAll ::+    (Monad m, Monad m') =>+    (forall p. RM i (Event o) m p -> m' p) ->+    (o -> m' ()) ->+    ContT Bool m' ()+sweepAll lft outpre =+    callCC $ \sus -> forever $ cond sus >> body+  where+    cond sus =+      do+        ph <- lift $ lft $ gets getPhaseRI+        if ph == Suspend then sus () else return ()+    body =+      do+        evx <- lift $ lft $ sweepR+        case evx+          of+            Event x ->+              do+                lift $ outpre x+            NoEvent ->+                return ()+            End ->+                breakCont False++breakCont :: Monad m => r -> ContT r m a+breakCont = ContT . const . return+++-- | Run a machine.+runT ::+    (Monad m, Fd.Foldable f) =>+    (c -> m ()) ->+    ProcessT m (Event b) (Event c) ->+    f b -> m ()+runT outpre0 pa0 xs =+    runRM pa0 $+      do+        _ <- evalContT $+          do+            -- Sweep initial events.+            sweepAll id outpre++            -- Feed values+            Fd.mapM_ feedSweep xs++            return True++        -- Terminate.+        _ <- feed_ End End+        _ <- evalContT $ sweepAll id outpre >> return True+        return ()+  where+    feedSweep x =+      do+        _ <- lift $ feedR x+        sweepAll id outpre++    outpre = lift . outpre0++type Builder b = F.F ((,) b)++putB :: b -> Builder b ()+putB x = F.liftF (x, ())++bToList :: Builder b a -> [b]+bToList x = build $ \cons nil -> F.runF x (const nil) (uncurry cons)++-- | Run a machine discarding all results.+runT_ ::+    (Monad m, Fd.Foldable f) =>+    ProcessT m (Event a) (Event b) ->+    f a -> m ()+runT_ pa l =+    runT (const $ return ()) pa l++run ::+    Fd.Foldable f =>+    ProcessT Identity (Event a) (Event b) ->+    f a -> [b]+run pa = bToList . runT putB (fit lift pa)++run_ ::+    (Fd.Foldable f, ArrowApply a) =>+    ProcessA a (Event b) (Event c) ->+    a (f b) ()+run_ pa = proc l -> case runT_ pa l of {ArrowMonad f -> f} -<< ()++lftRM :: (Monad m, Monad m') =>+    (forall p. m p -> m' p) ->+    RM i o m a ->+    StateT (RunInfo i o m) m' a+lftRM lft' st = StateT $ \s -> lft' $ runStateT st s+++-- | Execute until an input consumed and the machine suspends.+--+-- During the execution, the machine may yield values or stops.+-- It can be handled by two callbacks.+--+-- In some case the machine failed to consume the input value.+-- If so, the value is passed to the termination callback.+stepRun ::+    (Monad m, Monad m') =>+    (forall p. m p -> m' p) -- ^ Lifting function (pass `id` if m' ~ m)+      ->+    (b -> m' ()) -- ^ Callback on every output value.+      ->+    (Maybe a -> m' ()) -- ^ Callback on termination.+      ->+    ProcessT m (Event a) (Event b)  -- ^ The machine to run.+      ->+    a -- ^ The argument to the machine.+      ->+    m' (ProcessT m (Event a) (Event b))+stepRun lft yd stp pa0 x =+  do+    pa <- runRM pa0 $+      do+        csmd <- evalContT $+          do+            sweepAll (lftRM lft) (lift . yd)+            return True+        if csmd+          then do+            ct <- evalContT $+              do+                _ <- lift $ feedR x+                sweepAll (lftRM lft) (lift . yd)+                return True+            if ct+              then return ()+              else lift $ stp $ Nothing+          else+            lift $ stp $ Just x+        pa <- lftRM lft freeze+        return pa+    return pa+++-- | Execute until an output produced.+--+-- During the execution, the machine may await values or stops.+-- It can be handled by two callbacks.+--+-- If the machine stops without producing any value,+-- The first element of the return tuple is `Nothing`.+stepYield ::+    (Monad m, Monad m') =>+    (forall p. m p -> m' p)  -- ^ Lifting function (pass `id` if m' ~ m)+      ->+    m' a -- ^ Callback on input value request.+      ->+    m' () -- ^ Callback on termination+      ->+    ProcessT m (Event a) (Event b) -- ^ The machine to run.+      ->+    m' (Maybe b, ProcessT m (Event a) (Event b))+stepYield lft aw stp pa0 = runRM pa0 $+  do+    r <- go False+    pa <- lftRM lft freeze+    return (r, pa)++  where+    go csmd =+        lftRM lft sweepR >>= handleEv csmd++    handleEv _ (Event y) =+        return $ Just y++    handleEv True NoEvent =+        return Nothing++    handleEv False NoEvent =+      do+        x <- lift $ aw+        _ <- lftRM lft $ feedR x+        go True++    handleEv _ End =+        lift stp >> return Nothing

@@ -5,6 +5,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE BangPatterns #-}  #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-}@@ -49,8 +50,8 @@         tee,         gather,         fork,-        filter,-        echo,+        fire,+        fire0,         anytime,         par,         parB,@@ -59,7 +60,7 @@         onEnd, #if defined(MIN_VERSION_arrows)         -- * Transformer-        readerProc+        -- readerProc #endif      ) where@@ -72,47 +73,88 @@ import Control.Monad.Trans import Control.Monad.State import Control.Arrow-import Control.Applicative #if defined(MIN_VERSION_arrows) import Control.Arrow.Transformer.Reader (ArrowAddReader(..)) #endif-import Control.Arrow.Machine.ArrowUtil+-- import Control.Arrow.Machine.ArrowUtil import Control.Arrow.Machine.Types -+-- $setup+-- >>> :set -XArrows    hold ::-    ArrowApply a => b -> ProcessA a (Event b) b+    Monad m => b -> ProcessT m (Event b) b hold old = proc evx ->   do     rSwitch (pure old) -< ((), pure <$> evx)  dHold ::-    ArrowApply a => b -> ProcessA a (Event b) b+    Monad m => b -> ProcessT m (Event b) b dHold old = proc evx ->   do     drSwitch (pure old) -< ((), pure <$> evx) +-- | Accumulate inputs like fold.+--+-- >>> :{+-- let pa = proc evx ->+--       do+--         val <- accum 0 -< (+1) <$ evx+--         returnA -< val <$ evx+--   in+--     run pa (replicate 10 ())+-- :}+-- [1,2,3,4,5,6,7,8,9,10]+--+-- Since 4.0.0, this function become strict for the first argument+-- because lazy one could rarely be used.+--+-- You can make `switch`es to make lazy one.+ accum ::-    ArrowApply a => b -> ProcessA a (Event (b->b)) b-accum x = switch (pure x &&& arr (($x)<$>)) accum'+    Monad m => b -> ProcessT m (Event (b->b)) b+accum !x = switch (pure x &&& arr (($x)<$>)) accum'   where     accum' y = dSwitch (pure y &&& Cat.id) (const (accum y)) +-- | Delayed version of `accum`.+--+-- >>> :{+-- let pa = proc evx ->+--       do+--         val <- dAccum 0 -< (+1) <$ evx+--         returnA -< val <$ evx+--   in+--     run pa (replicate 10 ())+-- :}+-- [0,1,2,3,4,5,6,7,8,9]+--+-- Since 4.0.0, this function become strict for the first argument+-- because lazy one could rarely be used.+--+-- You can make `switch`es to make lazy one.+ dAccum ::-    ArrowApply a => b -> ProcessA a (Event (b->b)) b-dAccum x = dSwitch (pure x &&& arr (($x)<$>)) dAccum+    Monad m => b -> ProcessT m (Event (b->b)) b+dAccum !x = dSwitch (pure x &&& arr (($x)<$>)) dAccum  +-- |Detects edges of input behaviour.+--+-- >>> run (hold 0 >>> edge) [1, 1, 2, 2, 2, 3]+-- [0,1,2,3]+--+-- >>> run (hold 0 >>> edge) [0, 1, 1, 2, 2, 2, 3]+-- [0,1,2,3] edge ::-    (ArrowApply a, Eq b) =>-    ProcessA a b (Event b)+    (Monad m, Eq b) =>+    ProcessT m b (Event b) edge = proc x ->   do     rec-        ev <- unsafeExhaust (arr judge) -< (prv, x)+        ev <- unsafeExhaust (return . judge) -< (prv, x)         prv <- dHold Nothing -< Just x <$ ev     returnA -< ev   where@@ -198,24 +240,24 @@ --   run (source [...] >>> af) (repeat ()) -- @ source ::-    (ArrowApply a, Fd.Foldable f) =>-    f c -> ProcessA a (Event b) (Event c)-source l = construct $ Fd.mapM_ yd l+    (Monad m, Fd.Foldable f) =>+    f a -> ProcessT m (Event i) (Event a)+source l = construct (Fd.mapM_ yd l)   where     yd x = await >> yield x  -- | Provides a blocking event stream. blockingSource ::-    (ArrowApply a, Fd.Foldable f) =>-    f c -> ProcessA a () (Event c)-blockingSource l = pure noEvent >>> construct (Fd.mapM_ yield l)+    (Monad m, Fd.Foldable f) =>+    f a -> ProcessT m ZeroEvent (Event a)+blockingSource l = arr collapse >>> construct (Fd.mapM_ yield l)  -- | Make a blocking source interleaved. interleave ::-    ArrowApply a =>-    ProcessA a () (Event c) ->-    ProcessA a (Event b) (Event c)-interleave bs0 = sweep1 (pure () >>> bs0)+    Monad m =>+    ProcessT m ZeroEvent (Event a) ->+    ProcessT m (Event i) (Event a)+interleave bs0 = sweep1 (mempty >>> bs0)   where     waiting bs r =         dSwitch@@ -231,7 +273,7 @@         ev' <- splitter bs r -< ev         returnA -< (filterJust (fst <$> ev'), snd <$> ev')     splitter bs r =-        construct $+        (arr collapse >>>) . construct $           do             _ <- await             yield (Just r, bs)@@ -240,9 +282,9 @@  -- | Make an interleaved source blocking. blocking ::-    ArrowApply a =>-    ProcessA a (Event ()) (Event c) ->-    ProcessA a () (Event c)+    Monad m =>+    ProcessT m (Event ()) (Event a) ->+    ProcessT m ZeroEvent (Event a) blocking is = dSwitch (blockingSource (repeat ()) >>> is >>> (Cat.id &&& onEnd)) (const stopped)  @@ -259,64 +301,91 @@ -- @... \<- gather -\< [Left \<$\> e1, Right \<$\> e2]@ -- tee ::-    ArrowApply a => ProcessA a (Event b1, Event b2) (Event (Either b1 b2))+    Monad m => ProcessT m (Event b1, Event b2) (Event (Either b1 b2)) tee = proc (e1, e2) -> gather -< [Left <$> e1, Right <$> e2]    -- |Make multiple event channels into one. -- If simultaneous events are given, lefter one is emitted earlier.+--+-- >>> :{+-- let pa = proc x ->+--       do+--         r1 <- filterEvent (\x -> x `mod` 2 == 0) -< x+--         r2 <- filterEvent (\x -> x `mod` 3 == 0) -< x+--         gather -< [r1, r2]+--   in+--     run pa [1..6]+-- :}+-- [2,3,4,6,6]+--+-- It is terminated when the last input finishes.+--+-- >>> :{+-- let pa = proc x ->+--       do+--         r1 <- filterEvent (\x -> x `mod` 3 == 0) -< x :: Event Int+--         r2 <- stopped -< x+--         r3 <- returnA -< r2+--         fin <- gather -< [r1, r2, r3]+--         val <- hold 0 -< r1+--         end <- onEnd -< fin+--         returnA -< val <$ end+--   in+--     run pa [1..5]+-- :}+-- [3]+ gather ::-    (ArrowApply a, Fd.Foldable f) =>-    ProcessA a (f (Event b)) (Event b)+    (Monad m, Fd.Foldable f) =>+    ProcessT m (f (Event b)) (Event b) gather = arr (Fd.foldMap $ fmap singleton) >>> fork   where     singleton x = x NonEmpty.:| []   -- |Given an array-valued event and emit it's values as inidvidual events.+--+-- >>> run fork [[1,2,3],[],[4,5]]+-- [1,2,3,4,5] fork ::-    (ArrowApply a, Fd.Foldable f) =>-    ProcessA a (Event (f b)) (Event b)+    (Monad m, Fd.Foldable f) =>+    ProcessT m (Event (f b)) (Event b)  fork = repeatedly $     await >>= Fd.mapM_ yield  -- |Executes an action once per an input event is provided.-anytime ::-    ArrowApply a =>-    a b c ->-    ProcessA a (Event b) (Event c)--anytime action = repeatedlyT (ary0 unArrowMonad) $-  do-    x <- await-    ret <- lift $ arrowMonad action x-    yield ret---filter ::-    ArrowApply a =>-    a b Bool ->-    ProcessA a (Event b) (Event b)-filter cond = repeatedlyT (ary0 unArrowMonad) $+fire ::+    Monad m =>+    (b -> m c) ->+    ProcessT m (Event b) (Event c)+fire fmy = repeatedlyT $   do     x <- await-    b <- lift $ arrowMonad cond x-    if b then yield x else return ()+    y <- lift $ fmy x+    yield y +-- |Executes an action once per an input event is provided.+fire0 ::+    Monad m =>+    m c ->+    ProcessT m (Event ()) (Event c)+fire0 = fire  . const -echo ::+-- |Executes an action once per an input event is provided.+anytime ::     ArrowApply a =>-    ProcessA a (Event b) (Event b)--echo = filter (arr (const True))+    a b c ->+    ProcessA a (Event b) (Event c)+anytime f = fire (\x -> ArrowMonad (arr (const x) >>> f))  -- |Emit an event of given value as soon as possible. oneshot ::-    ArrowApply a =>+    Monad m =>     c ->-    ProcessA a b (Event c)+    ProcessT m b (Event c) oneshot x = arr (const noEvent) >>> go   where     go = construct $@@ -328,14 +397,25 @@ --  now = oneshot () -- @ now ::-    ArrowApply a =>-    ProcessA a b (Event ())+    Monad m =>+    ProcessT m b (Event ()) now = oneshot ()  -- |Emit an event at the end of the input stream.+-- >>> :{+-- let+--     pa = proc evx ->+--       do+--         x <- hold 0 -< evx+--         ed <- onEnd -< evx+--         returnA -< x <$ ed+--   in+--     run pa [1..10]+-- :}+-- [10] onEnd ::-    (ArrowApply a, Occasional' b) =>-    ProcessA a b (Event ())+    (Monad m, Occasional' b) =>+    ProcessT m b (Event ()) onEnd = arr collapse >>> go   where     go = repeatedly $@@ -343,13 +423,15 @@   #if defined(MIN_VERSION_arrows)+{- -- | Run reader of base arrow. readerProc ::-    (ArrowApply a, ArrowApply a', ArrowAddReader r a a') =>-    ProcessA a b c ->-    ProcessA a' (b, r) c+    (Monad m, Monad m', ArrowAddReader r a a') =>+    ProcessT m b c ->+    ProcessT m' (b, r) c readerProc pa = arr swap >>> fitW snd (\ar -> arr swap >>> elimReader ar) pa   where     swap :: (a, b) -> (b, a)     swap ~(a, b) = (b, a)+-} #endif

@@ -0,0 +1,212 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Arrows #-}++module+    Common.RandomProc+where++import Prelude+import Control.Arrow.Machine as P+import Control.Arrow+import qualified Control.Category as Cat+import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Control.Monad.State+import Control.Monad.Writer+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+              deriving Show++data ProcGen = PgNop |+               PgStop |+               PgPush ProcGen |+               PgPop (ProcGen, ProcGen) ProcJoin |+               PgOdd ProcGen |+               PgDouble ProcGen |+               PgIncl ProcGen |+               PgHarf ProcGen+             deriving Show++instance+    Arbitrary ProcJoin+  where+    arbitrary = oneof [liftM PjFst arbitrary,+                      liftM PjSnd arbitrary,+                      liftM PjSum arbitrary]++instance+    Arbitrary ProcGen+  where+    arbitrary = sized $ \i ->+                frequency [(40, rest), (40 + i, content)]+      where+        rest = return PgNop+        content = oneof [+                   return PgNop,+                   return PgStop,+                   liftM PgPush arbitrary,+                   liftM2 PgPop arbitrary arbitrary,+                   liftM PgOdd arbitrary,+                   liftM PgDouble arbitrary,+                   liftM PgIncl arbitrary,+                   liftM PgHarf arbitrary+                  ]+type MyProcT = ProcessT (State [Int])++mkProc :: ProcGen+       -> MyProcT (Event Int) (Event Int)+++mkProc PgNop = Cat.id++mkProc (PgPush next) = mc >>> mkProc next+  where+    mc = repeatedlyT $+       do+         x <- await+         lift $ modify (\xs -> x:xs)+         yield x++mkProc (PgPop (fx, fy) fz) =+    mc >>> ((evMap fst >>> fork) &&& (evMap snd >>> fork))+       >>> (mkProc fx *** mkProc fy) >>> mkProcJ fz+  where+    mc = repeatedlyT $+       do+         x <- await+         ys <- lift $ get+         case ys+           of+             [] ->+                 yield (Just x, Nothing)+             (y:yss) ->+               do+                 lift $ put yss+                 yield (Just x, Just y)++mkProc (PgOdd next) = P.filterEvent cond >>> mkProc next+  where+    cond x = x `mod` 2 == 1++mkProc (PgDouble next) = arr (fmap $ \x -> [x, x]) >>> fork >>> mkProc next++mkProc (PgIncl next) = arr (fmap (+1)) >>> mkProc next++mkProc (PgHarf next) = arr (fmap (`div`2)) >>> mkProc next++mkProc (PgStop) = stopped++mkProcJ :: ProcJoin -> MyProcT (Event Int, Event Int) (Event Int)++mkProcJ (PjFst pg) = arr fst+mkProcJ (PjSnd pg) = arr snd+mkProcJ (PjSum pg) = proc (evx, evy) ->+    returnA -< getSum <$> foldMap (Sum <$>) [evx, evy]+++stateProc :: MyProcT (Event a) (Event b) -> [a] -> ([b], [Int])+stateProc pa i =+    runState (execWriterT $ runT (\x -> tell [x]) (fit lift pa) i) []++class+    TestIn a+  where+    input :: MyProcT (Event Int) a++class+    TestOut a+  where+    output :: MyProcT a (Event Int)++instance+    TestIn (Event Int)+  where+    input = Cat.id++instance+    TestOut (Event Int)+  where+    output = Cat.id++instance+    (TestIn a, TestIn b) => TestIn (a, b)+  where+    input = mc >>>+        ((evMap fst >>> fork >>> input) &&& (evMap snd >>> fork >>> input))+      where+        mc = repeatedly $+          do+            x <- await+            y <- await+            yield (Just x, Just y)++instance+    (TestOut a, TestOut b) => TestOut (a, b)+  where+    output = proc (x1, x2) ->+      do+        y1 <- output -< x1+        y2 <- output -< x2+        gather -< [y1, y2]++instance+    (TestIn a, TestIn b) =>+        TestIn (Either a b)+  where+    input = proc evx ->+      do+        -- 一個前の値で分岐してみる+        b <- dHold True -<+               (\x -> x `mod` 2 == 0) <$> evx++        if b+          then+            arr Left <<< input -< evx+          else+            arr Right <<< input -< evx++instance+    (TestOut a, TestOut b) => TestOut (Either a b)+  where+    output = output ||| output++type MyTestT a b = MyProcT a b -> MyProcT a b -> Bool++mkEquivTest :: (TestIn a, TestOut b) =>+               (Maybe (ProcGen, ProcJoin), ProcGen, ProcGen, [Int]) ->+               MyTestT a b+mkEquivTest (Nothing, pre, post, l) pa pb =+    let+        preA = mkProc pre+        postA = mkProc post+        mkCompared p = preA >>> input >>> p >>> output >>> postA+        x = stateProc (mkCompared pa) l+        y = stateProc (mkCompared pb) l+      in+        x == y++mkEquivTest (Just (par, j), pre, post, l) pa pb =+    let+        preA = mkProc pre+        postA = mkProc post+        parA = mkProc par+        joinA = mkProcJ j+        mkCompared p = preA >>> input >>> p >>> output >>> postA+        x = stateProc (mkCompared pa) l+        y = stateProc (mkCompared pb) l+      in+        x == y++mkEquivTest2 ::(Maybe (ProcGen, ProcJoin), ProcGen, ProcGen, [Int]) ->+               MyProcT (Event Int, Event Int) (Event Int, Event Int) ->+               MyProcT (Event Int, Event Int) (Event Int, Event Int) ->+               Bool+mkEquivTest2 = mkEquivTest+

@@ -1,60 +0,0 @@-{-# LANGUAGE Arrows #-}--module-    LoopUtil-where--import Data.Functor-import Control.Arrow-import Test.Hspec--import Control.Category ((>>>))--import Control.Arrow.Machine as P-import Control.Monad.Trans (liftIO)-import qualified Control.Arrow.Machine.Misc.Pump as Pump--import Data.Monoid (Endo(Endo), mappend, appEndo)--newtype Duct a = Duct (Endo [a])--doubler = arr (fmap $ \x -> [x, x]) >>> P.fork--loopUtil =-  do-    describe "loop" $-      do-        it "is possible that value by `dHold` or `dAccum` can refer at upstream." $-          do-            let -                pa :: ProcessA (Kleisli IO) (Event Int) (Event Int)-                pa = proc evx ->-                  do-                    rec-                        anytime (Kleisli print) -< y <$ evx-                        anytime (Kleisli putStr) -< "" <$ evx -- side effect-                        evx2 <- doubler -< evx-                        y <- P.dAccum 0 -< (+) <$> evx2-                    returnA -< y <$ evx-            ret <- liftIO $ runKleisli (P.run pa) [1, 2, 3]-            ret `shouldBe` [0, 1+1, 1+1+2+2]-  -    describe "Pump" $-      do-        it "pumps up an event stream." $-          do-            let-                pa :: ProcessA (Kleisli IO) (Event Int) (Event Int)-                pa = proc evx ->-                  do-                    rec-                        evOut <- Pump.outlet -< (dct, () <$ evx)-                        anytime (Kleisli putStr) -< "" <$ evx -- side effect-                        so <- doubler -< evx-                        dct <- Pump.intake -< (so, () <$ evx)-                    returnA -< evOut--            ret <- liftIO $ runKleisli (P.run pa) [4, 5, 6]-            ret `shouldBe` [4, 4, 5, 5, 6, 6]--

@@ -0,0 +1,45 @@+{-# LANGUAGE Arrows #-}++module+    Misc.PumpSpec+where++import Data.Functor+import Control.Arrow+import Test.Hspec++import Control.Category ((>>>))++import Control.Arrow.Machine as P+import Control.Monad.Trans (liftIO)+import qualified Control.Arrow.Machine.Misc.Pump as Pump++import Data.Monoid (Endo(Endo), mappend, appEndo)++import Data.IORef++newtype Duct a = Duct (Endo [a])++doubler = arr (fmap $ \x -> [x, x]) >>> P.fork++spec =+  do+    it "pumps up an event stream." $+      do+        ref <- newIORef ([] :: [Int])+        let+            pa :: ProcessT IO (Event Int) (Event ())+            pa = proc evx ->+              do+                rec+                    evOut <- Pump.outlet -< (dct, () <$ evx)+                    fire (putStr) -< "" <$ evx -- side effect+                    so <- doubler -< evx+                    dct <- Pump.intake -< (so, () <$ evx)+                fire (\x -> modifyIORef ref (x:)) -< evOut++        liftIO $ P.runT_ pa [4, 5, 6]+        ret <- readIORef ref+        reverse ret `shouldBe` [4, 4, 5, 5, 6, 6]++

@@ -1,221 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Arrows #-}--module-    RandomProc-where--import Prelude-import Control.Arrow.Machine as P-import Control.Arrow-import qualified Control.Category as Cat-import Control.Applicative-import Control.Monad-import Control.Monad.Trans-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-              deriving Show--data ProcGen = PgNop | -               PgStop |-               PgPush ProcGen |-               PgPop (ProcGen, ProcGen) ProcJoin |-               PgOdd ProcGen |-               PgDouble ProcGen |-               PgIncl ProcGen |-               PgHarf ProcGen-             deriving Show--instance-    Arbitrary ProcJoin-  where-    arbitrary = oneof [liftM PjFst arbitrary,-                      liftM PjSnd arbitrary,-                      liftM PjSum arbitrary]--instance -    Arbitrary ProcGen-  where-    arbitrary = sized $ \i ->-                frequency [(40, rest), (40 + i, content)]-      where-        rest = return PgNop-        content = oneof [-                   return PgNop, -                   return PgStop, -                   liftM PgPush arbitrary,-                   liftM2 PgPop arbitrary arbitrary,-                   liftM PgOdd arbitrary,-                   liftM PgDouble arbitrary,-                   liftM PgIncl arbitrary,-                   liftM PgHarf arbitrary-                  ]-type MyProcT = ProcessA (Kleisli (State [Int]))--mkProc :: ProcGen -       -> MyProcT (Event Int) (Event Int)---mkProc PgNop = Cat.id--mkProc (PgPush next) = mc >>> mkProc next-  where-    mc = repeatedlyT kleisli0 $-       do-         x <- await-         lift $ modify (\xs -> x:xs)-         yield x--mkProc (PgPop (fx, fy) fz) =-    mc >>> ((evMap fst >>> fork) &&& (evMap snd >>> fork))-       >>> (mkProc fx *** mkProc fy) >>> mkProcJ fz-  where-    mc = repeatedlyT kleisli0 $-       do-         x <- await-         ys <- lift $ get-         case ys -           of-             [] -> -                 yield (Just x, Nothing)-             (y:yss) -> -               do -                 lift $ put yss-                 yield (Just x, Just y)--mkProc (PgOdd next) = P.filter (arr cond) >>> mkProc next-  where-    cond x = x `mod` 2 == 1--mkProc (PgDouble next) = arr (fmap $ \x -> [x, x]) >>> fork >>> mkProc next--mkProc (PgIncl next) = arr (fmap (+1)) >>> mkProc next--mkProc (PgHarf next) = arr (fmap (`div`2)) >>> mkProc next--mkProc (PgStop) = stopped--mkProcJ :: ProcJoin -> MyProcT (Event Int, Event Int) (Event Int)--mkProcJ (PjFst pg) = arr fst-mkProcJ (PjSnd pg) = arr snd-mkProcJ (PjSum pg) = proc (evx, evy) ->-    returnA -< getSum <$> foldMap (Sum <$>) [evx, evy]---stateProc :: MyProcT (Event a) (Event b) -> [a] -> ([b], [Int])-stateProc a i = -    runState mx []-{--    unsafePerformIO $ -      do-        x <- timeout 10000 $-          do-            let x = runState mx []-            deepseq x $ return x-        return (fromJust x)--}-  where-    mx = runKleisli (run a) i--class -    TestIn a-  where-    input :: MyProcT (Event Int) a--class-    TestOut a-  where-    output :: MyProcT a (Event Int)--instance-    TestIn (Event Int)-  where-    input = Cat.id--instance-    TestOut (Event Int)-  where-    output = Cat.id--instance-    (TestIn a, TestIn b) => TestIn (a, b)-  where-    input = mc >>> -        ((evMap fst >>> fork >>> input) &&& (evMap snd >>> fork >>> input))-      where-        mc = repeatedly $-          do-            x <- await-            y <- await-            yield (Just x, Just y)--instance-    (TestOut a, TestOut b) => TestOut (a, b)-  where-    output = proc (x1, x2) ->-      do-        y1 <- output -< x1-        y2 <- output -< x2-        gather -< [y1, y2]--instance-    (TestIn a, TestIn b) => -        TestIn (Either a b)-  where-    input = proc evx ->-      do-        -- 一個前の値で分岐してみる-        b <- dHold True -< -               (\x -> x `mod` 2 == 0) <$> evx--        if b-          then-            arr Left <<< input -< evx-          else-            arr Right <<< input -< evx--instance-    (TestOut a, TestOut b) => TestOut (Either a b)-  where-    output = output ||| output--type MyTestT a b = MyProcT a b -> MyProcT a b -> Bool--mkEquivTest :: (TestIn a, TestOut b) =>-               (Maybe (ProcGen, ProcJoin), ProcGen, ProcGen, [Int]) ->-               MyTestT a b-mkEquivTest (Nothing, pre, post, l) pa pb =-    let-        preA = mkProc pre-        postA = mkProc post-        mkCompared p = preA >>> input >>> p >>> output >>> postA-        x = stateProc (mkCompared pa) l-        y = stateProc (mkCompared pb) l-      in-        x == y--mkEquivTest (Just (par, j), pre, post, l) pa pb =-    let-        preA = mkProc pre-        postA = mkProc post-        parA = mkProc par-        joinA = mkProcJ j-        mkCompared p = preA >>> input >>> p >>> output >>> postA-        x = stateProc (mkCompared pa) l-        y = stateProc (mkCompared pb) l-      in-        x == y--mkEquivTest2 ::(Maybe (ProcGen, ProcJoin), ProcGen, ProcGen, [Int]) ->-               MyProcT (Event Int, Event Int) (Event Int, Event Int) -> -               MyProcT (Event Int, Event Int) (Event Int, Event Int) ->-               Bool-mkEquivTest2 = mkEquivTest

@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+

@@ -0,0 +1,111 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-}++module+    Types.BasicSpec+where++import qualified Control.Arrow.Machine as P++import Control.Arrow.Machine hiding (filter, source)+import Control.Applicative+import qualified Control.Category as Cat+import Control.Arrow+import Control.Monad.State+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Identity (Identity, runIdentity)+import Debug.Trace+import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized)++import Common.RandomProc+++spec =+  do+    it "is stream transducer." $+      do+        let+          process = repeatedly $+            do+              x <- await+              yield x+              yield (x + 1)++          resultA = run process [1,2,4]++        resultA `shouldBe` [1, 2, 2, 3, 4, 5]++    let+        -- 入力1度につき同じ値を2回出力する+        doubler = repeatedly $+                  do {x <- await; yield x; yield x}+        -- 入力値をStateのリストの先頭にPushする副作用を行い、同じ値を出力する+        pusher = repeatedlyT $+                 do {x <- await; lift $ modify (x:); yield x}++    it "has stop state" $+      let+          -- 一度だけ入力をそのまま出力し、すぐに停止する+          onlyOnce = construct $ await >>= yield++          x = stateProc (doubler >>> pusher >>> onlyOnce) [3, 3]+        in+          -- 最後尾のMachineが停止した時点で処理を停止するが、+          -- 既にa2が出力した値の副作用は処理する+          x `shouldBe` ([3], [3, 3])++    it "has side-effect" $+      let+          incl = evMap (+1)++          -- doublerで信号が2つに分岐する。+          -- このとき、副作用は1つ目の信号について末尾まで+          -- -> 二つ目の信号について分岐点から末尾まで ...+          -- の順で処理される。+          a = pusher >>> doubler >>> incl >>> pusher >>> incl >>> pusher++          x = stateProc a [1000]+        in+          x `shouldBe` ([1002, 1002], reverse [1000,1001,1002,1001,1002])++    it "never spoils any FEED" $+      let+          counter = construct $ counterDo 1+          counterDo n =+            do+              x <- await+              yield $ n * 100 + x+              counterDo (n+1)+          x = stateProc (doubler >>> doubler >>> counter) [1,2]+        in+          fst x `shouldBe` [101, 201, 301, 401, 502, 602, 702, 802]++    prop "each path can have independent number of events" $ \l ->+      let+          split2' = fmap fst &&& fmap snd+          gen = arr (fmap $ \x -> [x, x]) >>> fork >>> arr split2'+          r1 = run (gen >>> arr fst) (l::[(Int, [Int])])+          r2 = run (gen >>> second (fork >>> repeatedly (await >>= yield)) >>> arr fst)+               (l::[(Int, [Int])])+        in+          r1 == r2++    it "is lazy for individual input values" $+      do+        let l = run Cat.id (take 10 $ repeat undefined)+        length l `shouldBe` 10++{-+    it "is lazy for inpurt stream" $+      do+        let l = take 10 $ run Cat.id (repeat undefined)+        length l `shouldBe` 10+-}

@@ -0,0 +1,57 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-}++module+    Types.ChoiceSpec+where++import qualified Control.Arrow.Machine as P++import Control.Arrow.Machine hiding (filter, source)+import Control.Applicative+import qualified Control.Category as Cat+import Control.Arrow+import Control.Monad.State+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Identity (Identity, runIdentity)+import Debug.Trace+import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized)++import Common.RandomProc+++spec =+  do+    it "temp1" $+     do+       let+            af = mkProc $ PgStop+            ag = mkProc $ PgOdd PgNop+            aj1 = arr Right+            aj2 = arr $ either id id+            l = [1]+            r1 = stateProc+                   (aj1 >>> left af >>> aj2)+                   l+          in+            r1 `shouldBe` ([1],[])++    prop "left (f >>> g) = left f >>> left g" $ \fx gx cond ->+        let+            f = mkProc fx+            g = mkProc gx++            equiv = mkEquivTest cond+                ::(MyTestT (Either (Event Int) (Event Int))+                           (Either (Event Int) (Event Int)))+          in+            (left (f >>> g)) `equiv` (left f >>> left g)+

@@ -0,0 +1,75 @@+{-# LANGUAGE Arrows #-}++module+    Types.LoopSpec+where++import Data.Functor+import Control.Arrow+import Test.Hspec++import Control.Arrow.Machine as P+import Control.Monad.Trans (liftIO)++import Data.IORef++import Common.RandomProc++doubler = arr (fmap $ \x -> [x, x]) >>> P.fork++spec =+  do+    it "is possible that value by `dHold` or `dAccum` can refer at upstream." $+      do+        ref <- newIORef ([] :: [Int])+        let+            pa :: ProcessT IO (Event Int) (Event ())+            pa = proc evx ->+              do+                rec+                    P.fire print -< y <$ evx+                    P.fire putStr -< "" <$ evx -- side effect+                    evx2 <- doubler -< evx+                    y <- P.dAccum 0 -< (+) <$> evx2+                fire (\x -> modifyIORef ref (x:)) -<  y <$ evx++        liftIO $ P.runT_ pa [1, 2, 3]+        ret <- readIORef ref+        reverse ret `shouldBe` [0, 1+1, 1+1+2+2]++    it "can be used with rec statement(pure)" $+      let+          a = proc ev ->+            do+              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 "the last value is valid." $+      do+        let+            mc = repeatedly $+              do+                x <- await+                yield x+                yield (x*2)+            pa = proc x ->+              do+                rec y <- mc -< (+z) <$> x+                    z <- dHold 0 -< y+                returnA -< y+        run pa [1, 10] `shouldBe` [1, 2, 12, 24]++    it "carries no events to upstream." $+      do+        let+            pa = proc ev ->+              do+                rec r <- dHold True -< False <$ ev2+                    ev2 <- fork -< [(), ()] <$ ev+                returnA -< r <$ ev+        run pa [1, 2, 3] `shouldBe` [True, True, True]+

@@ -0,0 +1,70 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-}++module+    Types.PlanSpec+where++import qualified Control.Arrow.Machine as P++import Control.Arrow.Machine hiding (filter, source)+import Control.Applicative+import qualified Control.Category as Cat+import Control.Arrow+import Control.Monad.State+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Identity (Identity, runIdentity)+import Debug.Trace+import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized)++import Common.RandomProc+++spec =+  do+    let pl =+          do+            x <- await+            yield x+            yield (x+1)+            x <- await+            yield x+            yield (x+1)+        l = [2, 5, 10, 20, 100]++    it "can be constructed into ProcessA" $+      do+        let+            result = run (construct pl) l+        result `shouldBe` [2, 3, 5, 6]++    it "can be repeatedly constructed into ProcessA" $+      do+        let+            result = run (repeatedly pl) l+        result `shouldBe` [2, 3, 5, 6, 10, 11, 20, 21, 100, 101]++    it "can handle the end with catchP." $+      do+        let+            plCatch =+              do+                x <- await `catchP` (yield 1 >> stop)+                yield x+                y <- (yield 2 >> await >> yield 3 >> await) `catchP` (yield 4 >> return 5)+                yield y+                y <- (await >>= yield >> stop) `catchP` (yield 6 >> return 7)+                yield y+        run (construct plCatch) [] `shouldBe` [1]+        run (construct plCatch) [100] `shouldBe` [100, 2, 4, 5, 6, 7]+        run (construct plCatch) [100, 200] `shouldBe` [100, 2, 3, 4, 5, 6, 7]+        run (construct plCatch) [100, 200, 300] `shouldBe` [100, 2, 3, 300, 6, 7]+        run (construct plCatch) [100, 200, 300, 400] `shouldBe` [100, 2, 3, 300, 400, 6, 7]

@@ -0,0 +1,155 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-}++module+Types.RuleSpec+where++import qualified Control.Arrow.Machine as P++import Control.Arrow.Machine hiding (filter, source)+import Control.Applicative+import qualified Control.Category as Cat+import Control.Arrow+import Control.Monad.State+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Identity (Identity, runIdentity)+import Debug.Trace+import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized)++import Common.RandomProc+++spec =+  do+    describe "ProcessA as Category" $ catSpec+    describe "ProcessA as Arrow" $ arrSpec+    describe "Rules for ArrowLoop" $ arrowLoopSpec++catSpec =+  do+    prop "has asocciative composition" $ \fx gx hx cond ->+      let+          f = mkProc fx+          g = mkProc gx+          h = mkProc hx+          equiv = mkEquivTest cond+        in+          ((f >>> g) >>> h) `equiv` (f >>> (g >>> h))++    prop "has identity" $ \fx gx cond ->+      let+          f = mkProc fx+          g = mkProc gx+          equiv = mkEquivTest cond+        in+          (f >>> g) `equiv` (f >>> Cat.id >>> g)++arrSpec =+  do+    it "can be made from pure function(arr)" $+      do+        (run . arr . fmap $ (+ 2)) [1, 2, 3]+          `shouldBe` [3, 4, 5]++    prop "arr id is identity" $ \fx gx cond ->+      let+          f = mkProc fx+          g = mkProc gx+          equiv = mkEquivTest cond+        in+          (f >>> g) `equiv` (f >>> arr id >>> g)++    it "can be parallelized" $+      do+        pendingWith "to correct"+{-+        let+            myProc2 = repeatedlyT (Kleisli . const) $+              do+                x <- await+                lift $ modify (++ [x])+                yield `mapM` (take x $ repeat x)++            toN = evMaybe Nothing Just+            en (ex, ey) = Event (toN ex, toN ey)+            de evxy = (fst <$> evxy, snd <$> evxy)++            l = map (\x->(x,x)) [1,2,3]++            (result, state) =+                stateProc (arr de >>> first myProc2 >>> arr en) l++        (result >>= maybe mzero return . fst)+            `shouldBe` [1,2,2,3,3,3]+        (result >>= maybe mzero return . snd)+            `shouldBe` [1,2,3]+        state `shouldBe` [1,2,3]+-}++    prop "first and composition." $ \fx gx cond ->+      let+          f = mkProc fx+          g = mkProc gx+          equiv = mkEquivTest2 cond+        in+          (first (f >>> g)) `equiv` (first f >>> first g)++    prop "first-second commutes" $  \fx cond ->+      let+          f = first $ mkProc fx+          g = second (arr $ fmap (+2))++          equiv = mkEquivTest2 cond+        in+          (f >>> g) `equiv` (g >>> f)++    prop "first-fst commutes" $  \fx cond ->+      let+          f = mkProc fx+          equiv = mkEquivTest cond+                ::(MyTestT (Event Int, Event Int) (Event Int))+        in+          (first f >>> arr fst) `equiv` (arr fst >>> f)++    prop "assoc relation" $ \fx cond ->+      let+          f = mkProc fx+          assoc ((a,b),c) = (a,(b,c))++          equiv = mkEquivTest cond+                ::(MyTestT ((Event Int, Event Int), Event Int)+                           (Event Int, (Event Int, Event Int)))+        in+          (first (first f) >>> arr assoc) `equiv` (arr assoc >>> first f)++arrowLoopSpec =+  do+    let+        fixcore f y = if y `mod` 5 == 0 then y else y + f (y-1)+        pure (evx, f) = (f <$> evx, fixcore f)+        apure = arr pure++    prop "left tightening" $ \fx cond ->+      let+          f = mkProc fx++          equiv = mkEquivTest cond+        in+          (loop (first f >>> apure)) `equiv` (f >>> loop apure)++    prop "right tightening" $ \fx cond ->+      let+          f = mkProc fx++          equiv = mkEquivTest cond+        in+          (loop (apure >>> first f)) `equiv` (loop apure >>> f)

@@ -0,0 +1,192 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}++module+    Types.StepExecutionSpec+where++import qualified Control.Arrow.Machine as P++import Data.Maybe (isJust)+import Control.Arrow.Machine hiding (filter, source)+import Control.Applicative+import qualified Control.Category as Cat+import Control.Arrow+import Control.Monad.State+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Identity (Identity, runIdentity)+import Debug.Trace+import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized)++import Common.RandomProc++-- | Represents return values and informations of step executions.+data ExecInfo a =+    ExecInfo+      {+        yields :: [a], -- ^ Values yielded while the step.+        hasConsumed :: Bool, -- ^ True if the input value is consumed.+            --+            -- False if the machine has stopped unless consuming the input.+            --+            -- Or in the case of `stepYield`, this field become false when+            -- the machine produces a value unless consuming the input.+        hasStopped :: Bool -- ^ True if the machine has stopped at the end of the step.+      }+    deriving (Eq, Show)+++spec =+  do+    it "supports step execution" $+      do+        let+            pl =+              do+                x <- await+                yield x+                yield (x+1)+                x <- await+                yield x+                yield (x+1)+                yield (x+5)+            init = construct pl++            pl2 =+              do+                _ <- await+                return ()+            init2 = construct pl2++            emptyEI = ExecInfo+              {+                yields = [],+                hasConsumed = True, -- Set False if there's any leftover+                hasStopped = False+              }++            onYield x =+                modify $ \ei@ExecInfo{yields = xs} -> ei {yields = xs ++ [x]}++            onStop ma =+                modify $ \ei -> ei {hasConsumed = not (isJust ma), hasStopped = True}++        -- execution part+        --   x <- await+        --   yield x+        --   yield (x+1)+        (now, ret) <- runStateT (stepRun lift onYield onStop init 1) emptyEI+        yields ret `shouldBe` [1, 2]+        hasConsumed ret `shouldBe` True+        hasStopped ret `shouldBe` False++        -- execution part+        --   x <- await+        --   yield x+        --   yield (x+1)+        --   yield (x+5)+        (now, ret) <- runStateT (stepRun lift onYield onStop now 1) emptyEI+        yields ret `shouldBe` [1, 2, 6]+        hasConsumed ret `shouldBe` True+        hasStopped ret `shouldBe` True++        -- no execution part is left+        (now, ret) <- runStateT (stepRun lift onYield onStop now 1) emptyEI+        yields ret `shouldBe` ([]::[Int])+        hasConsumed ret `shouldBe` False+        hasStopped ret `shouldBe` True++        -- execution part+        --   _ <- await+        --   return ()+        (now, ret) <- runStateT (stepRun lift onYield onStop init2 1) emptyEI+        yields ret `shouldBe` ([]::[Int])+        hasConsumed ret `shouldBe` True+        hasStopped ret `shouldBe` True++    it "supports yield-driven step" $+      do+        let+            init = construct $+              do+                yield (-1)+                _ <- await+                x <- await+                mapM yield (iterate (+1) x) -- infinite+            init2 = construct $+              do+                return ()+            init3 = construct $+              do+                _ <- await+                return ()++            emptyEI = ExecInfo+              {+                yields = [], -- Not used+                hasConsumed = False,+                hasStopped = False+              }++            provide x =+              do+                modify $ \ei -> ei {hasConsumed = True}+                return x++            onStop =+                modify $ \ei -> ei {hasStopped = True}++        -- execution part+        --   yield (-1)+        ((val, now), ret) <- runStateT (stepYield lift (provide 5) onStop init) emptyEI+        val `shouldBe` Just (-1)+        hasConsumed ret `shouldBe` False+        hasStopped ret `shouldBe` False++        -- execution part+        --   _ <- await+        ((val, now), ret) <- runStateT (stepYield lift (provide 6) onStop now) emptyEI+        val `shouldBe` Nothing+        hasConsumed ret `shouldBe` True+        hasStopped ret `shouldBe` False++        -- execution part+        --   x <- await+        --   mapM yield (iterate (+1) x) -- first one+        ((val, now), ret) <- runStateT (stepYield lift (provide 10) onStop now) emptyEI+        val `shouldBe` Just 10+        hasConsumed ret `shouldBe` True+        hasStopped ret `shouldBe` False++        -- execution part+        --   mapM yield (iterate (+1) x) -- second one+        ((val, now), ret) <- runStateT (stepYield lift (provide 10) onStop now) emptyEI+        val `shouldBe` Just 11+        hasConsumed ret `shouldBe` False+        hasStopped ret `shouldBe` False++        -- execution part+        --   return ()+        ((val, now), ret) <- runStateT (stepYield lift (provide 0) onStop init2) emptyEI+        val `shouldBe` (Nothing :: Maybe Int)+        hasConsumed ret `shouldBe` False+        hasStopped ret `shouldBe` True++        -- execution part+        --   _ <- await+        --   return ()+        ((val, now), ret) <- runStateT (stepYield lift (provide 0) onStop init3) emptyEI+        val `shouldBe` (Nothing :: Maybe Int)+        hasConsumed ret `shouldBe` True+        hasStopped ret `shouldBe` True++

@@ -0,0 +1,40 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-}++module+    Types.SwitchSpec+where++import Data.Maybe (fromMaybe)+import qualified Control.Arrow.Machine as P+import Control.Arrow.Machine hiding (filter, source)+import Control.Applicative+import qualified Control.Category as Cat+import Control.Arrow+import Control.Monad.State+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Identity (Identity, runIdentity)+import Debug.Trace+import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized)++import Common.RandomProc+++spec =+  do+    describe "kSwitch" $+      do+        it "switches spontaneously" $+          do+            let+                theArrow sw = sw (oneshot False) (arr snd) $ \_ _ -> oneshot True+            run (theArrow kSwitch) [] `shouldBe` [True]+            run (theArrow dkSwitch) [] `shouldBe` [False, True]

@@ -0,0 +1,74 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-}++module+    Utils.SourceSpec+where++import Data.Maybe (fromMaybe)+import qualified Control.Arrow.Machine as P+import Control.Arrow.Machine hiding (filter, source)+import Control.Applicative+import qualified Control.Category as Cat+import Control.Arrow+import Control.Monad.State+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Identity (Identity, runIdentity)+import Debug.Trace+import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized)++import Common.RandomProc++spec =+  do+    describe "source" $+      do+        it "provides interleaved source stream" $+          do+            let+                pa = proc cl ->+                  do+                    s1 <- P.source [1, 2, 3] -< cl+                    s2 <- P.source [4, 5, 6] -< cl+                    P.gather -< [s1, s2]+            P.run pa (repeat ()) `shouldBe` [1, 4, 2, 5, 3, 6]+    describe "blockingSource" $+      do+        it "provides blocking source stream" $+          do+            let+                pa = proc _ ->+                  do+                    s1 <- P.blockingSource [1, 2, 3] -< mempty+                    s2 <- P.blockingSource [4, 5, 6] -< mempty+                    P.gather -< [s1, s2]+            P.run pa (repeat ()) `shouldBe` [4, 5, 6, 1, 2, 3]++    describe "source and blockingSource" $+      do+        prop "[interleave blockingSource = source]" $ \l cond ->+            let+                _ = l::[Int]+                equiv = mkEquivTest cond+                    ::(MyTestT (Event Int) (Event Int))+              in+                P.source l `equiv` P.interleave (P.blockingSource l)++        prop "[blocking source = blockingSource]" $ \l cond ->+            let+                _ = l::[Int]+                equiv = mkEquivTest cond+                    ::(MyTestT (Event Int) (Event Int))+              in+                (mempty >>> P.blockingSource l)+                    `equiv` (mempty >>> P.blocking (P.source l))++

@@ -0,0 +1,8 @@+module Main where++import Test.DocTest++main :: IO ()+main = doctest ["src"]++

@@ -1,596 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Arrows #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE FlexibleContexts #-}--module-    Main-where--import Data.Maybe (fromMaybe)-import qualified Control.Arrow.Machine as P-import Control.Arrow.Machine hiding (filter, source)-import Control.Applicative-import qualified Control.Category as Cat-import Control.Arrow-import Control.Monad.State-import Control.Monad-import Control.Monad.Trans-import Control.Monad.Identity (Identity, runIdentity)-import Debug.Trace-import Test.Hspec-import Test.Hspec.QuickCheck (prop)-import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized)-import RandomProc-import LoopUtil-runKI a x = runIdentity (runKleisli a x)----main = hspec $-  do-    basics-    rules-    loops-    choice-    plans-    utility-    switches-    source-    execution-    loopUtil---basics =-  do-    describe "ProcessA" $-      do-        it "is stream transducer." $-          do-            let-              process = repeatedly $-                do-                  x <- await-                  yield x-                  yield (x + 1)--              resultA = run process [1,2,4]--            resultA `shouldBe` [1, 2, 2, 3, 4, 5]--        let-            -- 入力1度につき同じ値を2回出力する-            doubler = repeatedly $-                      do {x <- await; yield x; yield x}-            -- 入力値をStateのリストの先頭にPushする副作用を行い、同じ値を出力する-            pusher = repeatedlyT (Kleisli . const) $-                     do {x <- await; lift $ modify (x:); yield x}--        it "has stop state" $-          let-              -- 一度だけ入力をそのまま出力し、すぐに停止する-              onlyOnce = construct $ await >>= yield--              x = stateProc (doubler >>> pusher >>> onlyOnce) [3, 3]-            in-              -- 最後尾のMachineが停止した時点で処理を停止するが、-              -- 既にa2が出力した値の副作用は処理する-              x `shouldBe` ([3], [3, 3])--        it "has side-effect" $-          let-              incl = arr $ fmap (+1)--              -- doublerで信号が2つに分岐する。-              -- このとき、副作用は1つ目の信号について末尾まで-              -- -> 二つ目の信号について分岐点から末尾まで ...-              -- の順で処理される。-              a = pusher >>> doubler >>> incl >>> pusher >>> incl >>> pusher--              x = stateProc a [1000]-            in-              x `shouldBe` ([1002, 1002], reverse [1000,1001,1002,1001,1002])--        it "never spoils any FEED" $-          let-              counter = construct $ counterDo 1-              counterDo n =-                do-                  x <- await-                  yield $ n * 100 + x-                  counterDo (n+1)-              x = stateProc (doubler >>> doubler >>> counter) [1,2]-            in-              fst x `shouldBe` [101, 201, 301, 401, 502, 602, 702, 802]--        prop "each path can have independent number of events" $ \l ->-          let-              split2' = fmap fst &&& fmap snd-              gen = arr (fmap $ \x -> [x, x]) >>> fork >>> arr split2'-              r1 = runKI (run (gen >>> arr fst)) (l::[(Int, [Int])])-              r2 = runKI (run (gen >>> second (fork >>> echo) >>> arr fst))-                   (l::[(Int, [Int])])-            in-              r1 == r2--        it "is lazy for individual input values" $-          do-            let l = runOn (\x -> [x]) Cat.id (take 10 $ repeat undefined)-            length l `shouldBe` 10--{--        it "is lazy for inpurt stream" $-          do-            let l = take 10 $ run Cat.id (repeat undefined)-            length l `shouldBe` 10--}--rules =-  do-    describe "ProcessA as Category" $-      do-        prop "has asocciative composition" $ \fx gx hx cond ->-          let-              f = mkProc fx-              g = mkProc gx-              h = mkProc hx-              equiv = mkEquivTest cond-            in-              ((f >>> g) >>> h) `equiv` (f >>> (g >>> h))--        prop "has identity" $ \fx gx cond ->-          let-              f = mkProc fx-              g = mkProc gx-              equiv = mkEquivTest cond-            in-              (f >>> g) `equiv` (f >>> Cat.id >>> g)--    describe "ProcessA as Arrow" $-      do-        it "can be made from pure function(arr)" $-          do-            (run . arr . fmap $ (+ 2)) [1, 2, 3]-              `shouldBe` [3, 4, 5]--        prop "arr id is identity" $ \fx gx cond ->-          let-              f = mkProc fx-              g = mkProc gx-              equiv = mkEquivTest cond-            in-              (f >>> g) `equiv` (f >>> arr id >>> g)--        it "can be parallelized" $-          do-            pendingWith "to correct"-{--            let-                myProc2 = repeatedlyT (Kleisli . const) $-                  do-                    x <- await-                    lift $ modify (++ [x])-                    yield `mapM` (take x $ repeat x)--                toN = evMaybe Nothing Just-                en (ex, ey) = Event (toN ex, toN ey)-                de evxy = (fst <$> evxy, snd <$> evxy)--                l = map (\x->(x,x)) [1,2,3]--                (result, state) =-                    stateProc (arr de >>> first myProc2 >>> arr en) l--            (result >>= maybe mzero return . fst)-                `shouldBe` [1,2,2,3,3,3]-            (result >>= maybe mzero return . snd)-                `shouldBe` [1,2,3]-            state `shouldBe` [1,2,3]--}--        prop "first and composition." $ \fx gx cond ->-          let-              f = mkProc fx-              g = mkProc gx-              equiv = mkEquivTest2 cond-            in-              (first (f >>> g)) `equiv` (first f >>> first g)--        prop "first-second commutes" $  \fx cond ->-          let-              f = first $ mkProc fx-              g = second (arr $ fmap (+2))--              equiv = mkEquivTest2 cond-            in-              (f >>> g) `equiv` (g >>> f)--        prop "first-fst commutes" $  \fx cond ->-          let-              f = mkProc fx-              equiv = mkEquivTest cond-                    ::(MyTestT (Event Int, Event Int) (Event Int))-            in-              (first f >>> arr fst) `equiv` (arr fst >>> f)--        prop "assoc relation" $ \fx cond ->-          let-              f = mkProc fx-              assoc ((a,b),c) = (a,(b,c))--              equiv = mkEquivTest cond-                    ::(MyTestT ((Event Int, Event Int), Event Int)-                               (Event Int, (Event Int, Event Int)))-            in-              (first (first f) >>> arr assoc) `equiv` (arr assoc >>> first f)--loops =-  do-    describe "ProcessA as ArrowLoop" $-      do-        it "can be used with rec statement(pure)" $-          let-              a = proc ev ->-                do-                  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 "the last value is valid." $-          do-            let-                mc = repeatedly $-                  do-                    x <- await-                    yield x-                    yield (x*2)-                pa = proc x ->-                  do-                    rec y <- mc -< (+z) <$> x-                        z <- dHold 0 -< y-                    returnA -< y-            run pa [1, 10] `shouldBe` [1, 2, 12, 24]--        it "carries no events to upstream." $-          do-            let-                pa = proc ev ->-                  do-                    rec r <- dHold True -< False <$ ev2-                        ev2 <- fork -< [(), ()] <$ ev-                    returnA -< r <$ ev-            run pa [1, 2, 3] `shouldBe` [True, True, True]---    describe "Rules for ArrowLoop" $-      do-        let-            fixcore f y = if y `mod` 5 == 0 then y else y + f (y-1)-            pure (evx, f) = (f <$> evx, fixcore f)-            apure = arr pure--        prop "left tightening" $ \fx cond ->-          let-              f = mkProc fx--              equiv = mkEquivTest cond-            in-              (loop (first f >>> apure)) `equiv` (f >>> loop apure)--        prop "right tightening" $ \fx cond ->-          let-              f = mkProc fx--              equiv = mkEquivTest cond-            in-              (loop (apure >>> first f)) `equiv` (loop apure >>> f)---choice =-  do-    describe "ProcessA as ArrowChoice" $-      do-        it "temp1" $-         do-           let-                af = mkProc $ PgStop-                ag = mkProc $ PgOdd PgNop-                aj1 = arr Right-                aj2 = arr $ either id id-                l = [1]-                r1 = stateProc-                       (aj1 >>> left af >>> aj2)-                       l-              in-                r1 `shouldBe` ([1],[])--        prop "left (f >>> g) = left f >>> left g" $ \fx gx cond ->-            let-                f = mkProc fx-                g = mkProc gx--                equiv = mkEquivTest cond-                    ::(MyTestT (Either (Event Int) (Event Int))-                               (Either (Event Int) (Event Int)))-              in-                (left (f >>> g)) `equiv` (left f >>> left g)---plans = describe "Plan" $-  do-    let pl =-          do-            x <- await-            yield x-            yield (x+1)-            x <- await-            yield x-            yield (x+1)-        l = [2, 5, 10, 20, 100]--    it "can be constructed into ProcessA" $-      do-        let-            result = run (construct pl) l-        result `shouldBe` [2, 3, 5, 6]--    it "can be repeatedly constructed into ProcessA" $-      do-        let-            result = run (repeatedly pl) l-        result `shouldBe` [2, 3, 5, 6, 10, 11, 20, 21, 100, 101]--    it "can handle the end with catchP." $-      do-        let-            plCatch =-              do-                x <- await `catchP` (yield 1 >> stop)-                yield x-                y <- (yield 2 >> await >> yield 3 >> await) `catchP` (yield 4 >> return 5)-                yield y-                y <- (await >>= yield >> stop) `catchP` (yield 6 >> return 7)-                yield y-        run (construct plCatch) [] `shouldBe` [1]-        run (construct plCatch) [100] `shouldBe` [100, 2, 4, 5, 6, 7]-        run (construct plCatch) [100, 200] `shouldBe` [100, 2, 3, 4, 5, 6, 7]-        run (construct plCatch) [100, 200, 300] `shouldBe` [100, 2, 3, 300, 6, 7]-        run (construct plCatch) [100, 200, 300, 400] `shouldBe` [100, 2, 3, 300, 400, 6, 7]--utility =-  do-    describe "splitEvent" $-      do-        it "splits an event stream" $-          do-            run (splitEvent >>> arr fst) [Left 1, Right 2, Left 3, Right 4] `shouldBe` [1, 3]-            run (splitEvent >>> arr snd) [Left 1, Right 2, Left 3, Right 4] `shouldBe` [2, 4]--    describe "edge" $-      do-        it "detects edges of input behaviour" $-          do-            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-        it "acts like fold." $-          do-            let-                pa = proc evx ->-                  do-                    val <- accum 0 -< (+1) <$ evx-                    returnA -< val <$ evx--            run pa (replicate 10 ()) `shouldBe` [1..10]--    describe "onEnd" $-      do-        it "fires only once at the end of a stream." $-          do-            let-                pa = proc evx ->-                  do-                    x <- hold 0 -< evx-                    ed <- onEnd -< evx-                    returnA -< x <$ ed-            run pa [1..4] `shouldBe` [4]--    describe "gather" $-      do-        it "correctly handles the end" $-          do-            let-                pa = proc x ->-                  do-                    r1 <- P.filter $ arr (\x -> x `mod` 3 == 0) -< x-                    r2 <- stopped -< x::Event Int-                    r3 <- returnA -< r2-                    fin <- gather -< [r1, r2, r3]-                    val <- hold 0 -< r1-                    end <- onEnd -< fin-                    returnA -< val <$ end-            run pa [1, 2, 3, 4, 5] `shouldBe` ([3]::[Int])---switches =-  do-    describe "switch" $-      do-        it "switches once" $-          do-            let-                before = proc evx ->-                  do-                    ch <- P.filterEvent (\x -> x `mod` 2 == 0) -< evx-                    returnA -< (noEvent, ch)--                after t = proc evx -> returnA -< (t*) <$> evx--                l = [1,3,4,1,3,2]--                -- 最初に偶数が与えられるまでは、入力を無視(NoEvent)し、-                -- それ以降は最初に与えられた偶数 * 入力値を返す-                ret = run (switch before after) l--                -- dが付くと次回からの切り替えとなる-                retD = run (dSwitch before after) l--            ret `shouldBe` [16, 4, 12, 8]-            retD `shouldBe` [4, 12, 8]--    describe "rSwitch" $-      do-        it "switches any times" $-          do-            let-               theArrow sw = proc evtp ->-                 do-                   evx <- P.fork -< fst <$> evtp-                   evarr <- P.fork -< snd <$> evtp-                   sw (arr $ fmap (+2)) -< (evx, evarr)--               l = [(Just 5, Nothing),-                    (Just 1, Just (arr $ fmap (*2))),-                    (Just 3, Nothing),-                    (Just 6, Just (arr $ fmap (*3))),-                    (Just 7, Nothing)]-               ret = run (theArrow rSwitch) l-               retD = run (theArrow drSwitch) l--            ret `shouldBe` [7, 2, 6, 18, 21]-            retD `shouldBe` [7, 3, 6, 12, 21]-    describe "kSwitch" $-      do-        it "switches spontaneously" $-          do-            let-                oneshot x = pure () >>> blockingSource [x]-                theArrow sw = sw (oneshot False) (arr snd) $ \_ _ -> oneshot True-            run (theArrow kSwitch) [] `shouldBe` [True]-            run (theArrow dkSwitch) [] `shouldBe` [False, True]--source =-  do-    describe "source" $-      do-        it "provides interleaved source stream" $-          do-            let-                pa = proc cl ->-                  do-                    s1 <- P.source [1, 2, 3] -< cl-                    s2 <- P.source [4, 5, 6] -< cl-                    P.gather -< [s1, s2]-            P.run pa (repeat ()) `shouldBe` [1, 4, 2, 5, 3, 6]-    describe "blockingSource" $-      do-        it "provides blocking source stream" $-          do-            let-                pa = proc _ ->-                  do-                    s1 <- P.blockingSource [1, 2, 3] -< ()-                    s2 <- P.blockingSource [4, 5, 6] -< ()-                    P.gather -< [s1, s2]-            P.run pa (repeat ()) `shouldBe` [4, 5, 6, 1, 2, 3]--    describe "source and blockingSource" $-      do-        prop "[interleave blockingSource = source]" $ \l cond ->-            let-                _ = l::[Int]-                equiv = mkEquivTest cond-                    ::(MyTestT (Event Int) (Event Int))-              in-                P.source l `equiv` P.interleave (P.blockingSource l)--        prop "[blocking source = blockingSource]" $ \l cond ->-            let-                _ = l::[Int]-                equiv = mkEquivTest cond-                    ::(MyTestT (Event Int) (Event Int))-              in-                (pure () >>> P.blockingSource l)-                    `equiv` (pure () >>> P.blocking (P.source l))---execution = describe "Execution of ProcessA" $-    do-      let-          pl =-            do-              x <- await-              yield x-              yield (x+1)-              x <- await-              yield x-              yield (x+1)-              yield (x+5)-          init = construct pl--      it "supports step execution" $-        do-          let-              (ret, now) = stepRun init 1-          yields ret `shouldBe` [1, 2]-          hasStopped ret `shouldBe` False--          let-              (ret, now2) = stepRun now 1-          yields ret `shouldBe` [1, 2, 6]-          hasStopped ret `shouldBe` True--          let-              (ret, _) = stepRun now2 1-          yields ret `shouldBe` ([]::[Int])-          hasStopped ret `shouldBe` True--      it "supports step execution (2)" $-          pendingWith "Correct stop handling"-{--      prop "supports step execution (2)" $ \p l ->-          let-              pa = mkProc p-              all pc (x:xs) ys =-                do-                  (r, cont) <- runKleisli (stepRun pc) x-                  all cont (if hasStopped r then [] else xs) (ys ++ yields r)-              all pc [] ys = runKleisli (run pc) [] >>= return . (ys++)-            in-              runState (all pa (l::[Int]) []) [] == stateProc pa l--}--      it "supports yield-driven step" $-        do-          let-              init = construct $-                do-                  yield (-1)-                  x <- await-                  mapM yield (iterate (+1) x) -- infinite--              (ret, now) = stepYield init 5-          yields ret `shouldBe` Just (-1)-          hasConsumed ret `shouldBe` False-          hasStopped ret `shouldBe` False--          let-              (ret, now2) = stepYield now 10-          yields ret `shouldBe` Just 10-          hasConsumed ret `shouldBe` True-          hasStopped ret `shouldBe` False--          let-              (ret, now3) = stepYield now2 10-          yields ret `shouldBe` Just 11-          hasConsumed ret `shouldBe` False-          hasStopped ret `shouldBe` False-