diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/machinecell.cabal b/machinecell.cabal --- a/machinecell.cabal +++ b/machinecell.cabal @@ -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 diff --git a/src/Control/Arrow/Machine.hs b/src/Control/Arrow/Machine.hs --- a/src/Control/Arrow/Machine.hs +++ b/src/Control/Arrow/Machine.hs @@ -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. diff --git a/src/Control/Arrow/Machine/Evolution.hs b/src/Control/Arrow/Machine/Evolution.hs new file mode 100644 --- /dev/null +++ b/src/Control/Arrow/Machine/Evolution.hs @@ -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 diff --git a/src/Control/Arrow/Machine/Misc/Discrete.hs b/src/Control/Arrow/Machine/Misc/Discrete.hs --- a/src/Control/Arrow/Machine/Misc/Discrete.hs +++ b/src/Control/Arrow/Machine/Misc/Discrete.hs @@ -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 diff --git a/src/Control/Arrow/Machine/Misc/Pump.hs b/src/Control/Arrow/Machine/Misc/Pump.hs --- a/src/Control/Arrow/Machine/Misc/Pump.hs +++ b/src/Control/Arrow/Machine/Misc/Pump.hs @@ -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 diff --git a/src/Control/Arrow/Machine/Types.hs b/src/Control/Arrow/Machine/Types.hs --- a/src/Control/Arrow/Machine/Types.hs +++ b/src/Control/Arrow/Machine/Types.hs @@ -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 diff --git a/src/Control/Arrow/Machine/Utils.hs b/src/Control/Arrow/Machine/Utils.hs --- a/src/Control/Arrow/Machine/Utils.hs +++ b/src/Control/Arrow/Machine/Utils.hs @@ -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 diff --git a/test/Common/RandomProc.hs b/test/Common/RandomProc.hs new file mode 100644 --- /dev/null +++ b/test/Common/RandomProc.hs @@ -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 + diff --git a/test/LoopUtil.hs b/test/LoopUtil.hs deleted file mode 100644 --- a/test/LoopUtil.hs +++ /dev/null @@ -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] - - diff --git a/test/Misc/PumpSpec.hs b/test/Misc/PumpSpec.hs new file mode 100644 --- /dev/null +++ b/test/Misc/PumpSpec.hs @@ -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] + + diff --git a/test/RandomProc.hs b/test/RandomProc.hs deleted file mode 100644 --- a/test/RandomProc.hs +++ /dev/null @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} + diff --git a/test/Types/BasicSpec.hs b/test/Types/BasicSpec.hs new file mode 100644 --- /dev/null +++ b/test/Types/BasicSpec.hs @@ -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 +-} diff --git a/test/Types/ChoiceSpec.hs b/test/Types/ChoiceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Types/ChoiceSpec.hs @@ -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) + diff --git a/test/Types/LoopSpec.hs b/test/Types/LoopSpec.hs new file mode 100644 --- /dev/null +++ b/test/Types/LoopSpec.hs @@ -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] + diff --git a/test/Types/PlanSpec.hs b/test/Types/PlanSpec.hs new file mode 100644 --- /dev/null +++ b/test/Types/PlanSpec.hs @@ -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] diff --git a/test/Types/RuleSpec.hs b/test/Types/RuleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Types/RuleSpec.hs @@ -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) diff --git a/test/Types/StepExecutionSpec.hs b/test/Types/StepExecutionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Types/StepExecutionSpec.hs @@ -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 + + diff --git a/test/Types/SwitchSpec.hs b/test/Types/SwitchSpec.hs new file mode 100644 --- /dev/null +++ b/test/Types/SwitchSpec.hs @@ -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] diff --git a/test/Utils/SourceSpec.hs b/test/Utils/SourceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Utils/SourceSpec.hs @@ -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)) + + diff --git a/test/doctest.hs b/test/doctest.hs new file mode 100644 --- /dev/null +++ b/test/doctest.hs @@ -0,0 +1,8 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = doctest ["src"] + + diff --git a/test/spec.hs b/test/spec.hs deleted file mode 100644 --- a/test/spec.hs +++ /dev/null @@ -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 -