diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +2.0.0 +------------ +* Relocate files + * `catch` and its families are moved to Misc.Exception +* Performance improve +* Added primitives: `fitEx`, `unsafeSteady`, `unsafeExhaust` +* Added: `condEvent`, `filterEvent`, `muted` +* Added to Misc: `Discrete`, `Pump.asUpdater`, `Pump.Alg` +* Deleted deprecated: `hEv`, `hEv'`, `evMaybe`, `fromEvent`, `split`, + `join`, `split2`, `join2`, `feedback`, `feedback1`, `isNoEvent`, `isOccasional`, `isEnd` +* Deleted `Foldable` and `Traversable` instance of `Event`. +* Added `Occasional'` by splitting some members from `Occasional` 1.3.1 ------------ diff --git a/machinecell.cabal b/machinecell.cabal --- a/machinecell.cabal +++ b/machinecell.cabal @@ -1,5 +1,5 @@ name: machinecell -version: 1.3.1 +version: 2.0.0 synopsis: Arrow based stream transducers license: BSD3 license-file: LICENSE @@ -21,10 +21,17 @@ AFRP-like utilities are also available. library - exposed-modules: Control.Arrow.Machine, Control.Arrow.Machine.Event, Control.Arrow.Machine.Plan, Control.Arrow.Machine.Types, Control.Arrow.Machine.Utils, Control.Arrow.Machine.Running, Control.Arrow.Machine.ArrowUtil, Control.Arrow.Machine.Exception, Control.Arrow.Machine.Core, Control.Arrow.Machine.Misc.Pump - other-modules: Control.Arrow.Machine.Event.Internal, Control.Arrow.Machine.Plan.Internal + exposed-modules: + Control.Arrow.Machine, + Control.Arrow.Machine.Types, + Control.Arrow.Machine.Utils, + Control.Arrow.Machine.ArrowUtil, + Control.Arrow.Machine.Misc.Exception, + Control.Arrow.Machine.Misc.Pump, + Control.Arrow.Machine.Misc.Discrete other-extensions: FlexibleInstances, Arrows, RankNTypes, TypeSynonymInstances, MultiParamTypeClasses, GADTs, FlexibleContexts, NoMonomorphismRestriction, RecursiveDo - build-depends: base >=4.0 && <5.0, mtl >=2.0.1.1, free >=4.5, profunctors >=4.0, arrows >=0.4.1.2, semigroups >=0.8.3.1 + ghc-options: -Wall + build-depends: base >=4.0 && <5.0, mtl >=2.0.1.1, free >=4.5 && < 4.12, profunctors >=4.0, arrows >=0.4.1.2, semigroups >=0.8.3.1 hs-source-dirs: src default-language: Haskell2010 @@ -34,7 +41,7 @@ hs-source-dirs: test main-is: spec.hs other-modules: RandomProc, LoopUtil - Build-depends: base >=4.0 && <5.0, mtl >=2.0.1.1, profunctors >=4.0, QuickCheck >=1.0, hspec >=0.2.0, machinecell -any + Build-depends: base >=4.0 && <5.0, mtl >=2.0.1.1, profunctors >=4.0, QuickCheck >=1.0, hspec >=0.2.0, arrows >=0.4.1.2, semigroups >=0.8.3.1, machinecell -any source-repository head type: git @@ -44,4 +51,4 @@ source-repository this type: git location: https://github.com/as-capabl/machinecell.git - tag: release-1.3.1 + tag: release-2.0.0 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 @@ -4,29 +4,306 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GADTs #-} + +{-| +Module: Control.Arrow.Machine +Description: Contains the main documentation and module imports. +-} module Control.Arrow.Machine ( + -- * Quick introduction + -- $introduction + + -- * Note + -- $note + -- * Modules - module Control.Arrow.Machine.Event, - module Control.Arrow.Machine.Utils, - module Control.Arrow.Machine.Plan, - module Control.Arrow.Machine.Exception, - module Control.Arrow.Machine.Running, + -- | "Control.Arrow.Machine" is good to import qualified, because no operators are exported. + -- + -- Alternatively, you can import libraries below individually, + -- with only "Control.Arrow.Machine.Utils" qualified or identifier specified. + -- + -- Control.Arrow.Machine.Misc.* are not included by default. + -- They are all designed to import qualified. module Control.Arrow.Machine.ArrowUtil, - - -- * The transducer arrow - ProcessA(), - fit + module Control.Arrow.Machine.Types, + module Control.Arrow.Machine.Utils ) where -import Control.Arrow.Machine.Event -import Control.Arrow.Machine.Utils -import Control.Arrow.Machine.Plan -import Control.Arrow.Machine.Exception -import Control.Arrow.Machine.Running import Control.Arrow.Machine.ArrowUtil +import Control.Arrow.Machine.Types +import Control.Arrow.Machine.Utils +-- $introduction +-- As other iteratee or pipe libraries, machinecell abstracts general iteration processes. +-- +-- Here is an example that is a simple iteration over a list. +-- +-- \>\>\> run (evMap (+1)) [1, 2, 3] +-- [2, 3, 4] +-- +-- In above statement, "`evMap` (+1)" has a type "ProcessA (-\>) (Event Int) (Event Int)", +-- which denotes "A stream transducer that takes a series of Int as input, +-- gives a series of Int as output, run on base arrow (-\>)." +-- +-- `ProcessA` is the transducer type of machinecell library. +-- +-- = Side effects +-- +-- In general, `Arrow` types other than (-\>) may have side effects. +-- For example any monadic side effects can be performed by wrapping the monad with `Kleisli`. +-- +-- ProcessA can run the effects as following. +-- +-- \>\>\> runKleisli (run_ $ anytime (Kleisli print)) [1, 2, 3] +-- 1 +-- 2 +-- 3 +-- +-- Where `anytime` makes a transducer that executes side effects for each input. +-- `run_` is almost same as `run` but discards transducer's output. +-- +-- That is useful in the case rather side effects are main concern. +-- +-- = ProcessA as pipes +-- +-- "ProcessA a (Event b) (Event c)" transducers are actually one-directional composable pipes. +-- +-- They can be constructed from `Plan` monads. +-- In `Plan` monad context, `await` and `yield` can be used to get and emit values. +-- And actions of base monads can be `lift`ed to the context. +-- +-- Then, resulting processes are composed as `Category` using `(\>\>\>)` operator. +-- +-- @ +-- source :: ProcessA (Kleisli IO) (Event ()) (Event String) +-- source = repeatedlyT kleisli0 $ +-- do +-- _ \<- await +-- x \<- lift getLine +-- yield x +-- +-- pipe :: ArrowApply a =\> ProcessA a (Event String) (Event String) +-- pipe = construct $ +-- do +-- s1 \<- await +-- s2 \<- await +-- yield (s1 ++ s2) +-- +-- sink :: ProcessA (Kleisli IO) (Event String) (Event Void) +-- sink = repeatedlyT kleisli0 +-- do +-- x \<- await +-- lift $ putStrLn x +-- @ +-- +-- \>\>\> runKleisli (run_ $ source \>\>\> pipe \>\>\> sink) (repeat ()) +-- +-- The above code reads two lines from stdin, puts a concatenated line to stdout and finishes. +-- +-- Unlike other pipe libraries, even a source must call `await`. +-- +-- The source awaits dummy input, namely "(repeat ())", and discard input values. +-- Even the input is an infinite list, this program stops when the "pipe" transducer stops. +-- +-- == More details on finalizing +-- +-- Finalizing behavior of transducers obey the following scenario. +-- +-- 1. Signals of type `Event` can carry /end signs/. +-- 2. Most transducers stop when they get an end sign. +-- (Some exceptions can be made by `onEnd` or `catchP`) +-- 3. If `run` function detects an end sign as an output of a running transducer, +-- it stops feeding input values and alternatively feeds end signs. +-- 4. Continue iteration until no more events can be occurred. +-- +-- So "await \`catchP\` some_cleanup" can handle any stop of both upstream and downstream. +-- +-- On the other hand, a plan never gets end sign without calling await. +-- That's why even sources must call await. +-- +-- = Arrow composition +-- +-- One of the most attractive feature of machinecell is the /arrow composition/. +-- +-- In addition to `Category`, ProcessA has `Arrow` instance declaration, +-- which allows parallel compositions. +-- +-- If a type has an `Arrow` instance, it can be wrote by ghc extended proc-do notation as following. +-- +-- @ +-- f :: ProcessA (Kleisli IO) (Event Int) (Event ()) +-- f = proc x -\> +-- do +-- -- Process odd integers. +-- odds \<- filter $ arr odd -\< x +-- anytime $ Kleisli (putStrLn . ("Odd: " ++)) -\< show \<$\> odds +-- +-- -- Process even integers. +-- evens \<- filter $ arr even -\< x +-- anytime $ Kleisli (putStrLn . ("Even: " ++)) -\< show \<$\> evens +-- @ +-- +-- \>\>\> P.runKleisli (run f) [1..10] +-- Odd: 1 +-- Even: 2 +-- Odd: 3 +-- Even: 4 +-- ... +-- +-- The result implies that two statements that inputs x and their downstreams are +-- executed in parallel. +-- +-- = Behaviours +-- +-- The transducers we have already seen are all have input and output type wrapped by `Event`. +-- We have not taken care of them so far because all of them are cancelled each other. +-- +-- But several built-in transducers provides non-event values like below. +-- +-- @ +-- hold :: ArrowApply a =\> b -\> ProcessA a (Event b) b +-- accum :: ArrowApply a =\> b -\> ProcessA a (Event (b-\>b)) b +-- @ +-- +-- `hold` keeps the last input until a new value is provided. +-- +-- `accum` updates its outputting by applying every input function. +-- +-- According to a knowledge from arrowized FRP(functional reactive programming), +-- values that appear naked in arrow notations are /behaviour/, +-- that means /coutinuous/ time-varying values, +-- whereas /event/ values are /discrete/. +-- +-- Note that all values that can be input, output, or taken effects must be discrete. +-- +-- To use continuous values anyhow interacting the real world, +-- they must be encoded to discrete values. +-- +-- That's done by functor calculations between any existing events. +-- +-- An example is below. +-- +-- @ +-- f :: ArrowApply a =\> ProcessA a (Event Int) (Event Int) +-- f = proc x -\> +-- do +-- y \<- accum 0 -\< (+) \<$\> x +-- returnA -\< y \<$ x +-- @ +-- +-- \>\>\> run f [1, 2, 3] +-- [1, 3, 6] +-- +-- `(\<$)` operator discards the value of rhs and only uses that's container structure +-- e.g. 1 \<$ Just "a" =\> Just 1, 1 \<$ Nothing =\> Nothing, +-- 1 \<$ [True, False, undefined] =\> [1, 1, 1]. +-- +-- In this case, the value of y are outputed according to the timing of x. +-- -import Control.Arrow.Machine.Types + + +-- $note +-- = Purity of `ProcessA (-\>)` +-- Since `a` of `ProcessA a b c` represents base monad(ArrowApply), `ProcessA (-\>)` is expected to be pure. +-- +-- In other words, the following arrow results the same result for arbitrary `f`. +-- +-- @ +-- proc x -\> +-- do +-- _ \<- fit arr f -\< x +-- g -\< x +-- @ +-- +-- Which is desugared to `f &&& g \>\>\> arr snd`. At least if `Event` constructor is exported, +-- the proposition is falsible. +-- When `f` is "arr (replicate k) \>\>\> fork" for some integer k and `g` is "arr (const $ Event ())", +-- g yields ()s for k times. That is because, the result value of arrow "f &&& g" is +-- nothing but "(Event x, Event ())" and its number of yields is k because "Event x" must +-- be yielded k times. +-- +-- That's because `Event` constructor is hidden. +-- Using primitives exported by this module, it works almost correctly. +-- Event number is conserved by inserting an appropriate number of `NoEvent`s. +-- But there is still a loophole. +-- +-- Under the current implementation, the arrow below behaves like "arr (const $ Event x)". +-- +-- @ +-- proc x -\> hold noEvent -\< ev \<$ ev +-- @ +-- +-- I have an idea to correct this, such that the above arrow always be `NoEvent`. +-- But in the result `Event` is no longer a functor in the meaning of haskell type class. +-- +-- For now, if you never make value of nested event type like "ev \<$ ev", +-- the problem will be avoided. +-- +-- = Looping +-- +-- Although `ProcessA` is an instance of `ArrowLoop`, +-- to send values to upstream, there is a little difficulties. +-- +-- In example below, result is [0, 1, 1, 1], not [0, 1, 2, 3]. +-- +-- @ +-- f = proc x -\> +-- do +-- rec +-- b \<- dHold 0 -\< y +-- y \<- fork -\< (\xx -\> [xx, xx+1, xx+2, xx+3]) \<$\> x +-- returnA -\< b \<$ y +-- +-- dHold i = proc x -\> drSwitch (pure i) -\< ((), pure \<$\> x) +-- @ +-- +-- \>\>\> run f [1] +-- [0, 1, 1, 1] +-- +-- This is because of machinecell's execution strategy. +-- It's much similar to Prolog's backtracking stategy. +-- At the time backtracking reaches `fork` three values are +-- found and backtracking go and back three times between fork and returnA, +-- but not reaches to dHold until all outputs are done. +-- +-- In general, `Event` values should not be refered at upstream. +-- +-- Rather, they should be encoded to behaviours and send to upstream in +-- rec statement and delayed by `cycleDelay`. +-- +-- Another way to send values to upstream is `encloseState`. +-- +-- = Unsafe primitives +-- +-- In the code below, `edge` does not fire. +-- +-- @ +-- encloseState False (sta \>\>\> peekState) \>\>\> edge +-- @ +-- +-- where +-- +-- @ +-- sta = constructT (ary0 $ statefully unArrowMonad) (put True \>\> await \>\> put False) +-- @ +-- +-- That is because, when "put True" is executing, the backtracking is going up and never hits `edge` +-- until "put False" is executed. +-- +-- The same occurs for "proc b -> if b then (now -< ()) else (returnA -< noEvent)" instead of `edge`. +-- +-- Even worse, it again breaks the purity of `ProcessA`. +-- `await` gets `NoEvent` if some "arr (replicate k) \>\>\> fork" is inserted somewhere in upstream. +-- Then `edge` may fire because "put False" execution is delayed. +-- +-- This means that, `encloseState`, `peekState`, `edge`, and `ArrowChoice` instance for `ProcessA` +-- should never be existed simultaneously. +-- +-- Moreover, their primitives `unsafeSteady`, `unsafeExhaust`, `fitEx` are so. +-- +-- But I hope some of them can be rescued. So for now, this library contains them all. + diff --git a/src/Control/Arrow/Machine/Core.hs b/src/Control/Arrow/Machine/Core.hs deleted file mode 100644 --- a/src/Control/Arrow/Machine/Core.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Arrows #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GADTs #-} - - -{-| -Extracted stuff to be used unqualified from ../Machine.hs. --} -module - Control.Arrow.Machine.Core - ( - -- * Modules - module Control.Arrow.Machine.Event, --- module Control.Arrow.Machine.Utils, - module Control.Arrow.Machine.Plan, --- module Control.Arrow.Machine.Exception, - module Control.Arrow.Machine.Running, --- module Control.Arrow.Machine.ArrowUtil, - - -- * The transducer arrow - ProcessA(), - fit, - ) -where - -import Control.Arrow.Machine.Event --- import Control.Arrow.Machine.Utils -import Control.Arrow.Machine.Plan --- import Control.Arrow.Machine.Exception -import Control.Arrow.Machine.Running -import qualified Control.Arrow.Machine.Running as Running --- import Control.Arrow.Machine.ArrowUtil - -import Control.Arrow.Machine.Types -import Control.Arrow - - diff --git a/src/Control/Arrow/Machine/Event.hs b/src/Control/Arrow/Machine/Event.hs deleted file mode 100644 --- a/src/Control/Arrow/Machine/Event.hs +++ /dev/null @@ -1,21 +0,0 @@ -module - Control.Arrow.Machine.Event - ( - Occasional (..), - Event (), - - -- * Deprecated - -- |They should be used only for internal use. - hEv, - hEv', - evMaybe, - fromEvent, - evMap, - split, - join, - split2, - join2 - ) -where - -import Control.Arrow.Machine.Event.Internal diff --git a/src/Control/Arrow/Machine/Event/Internal.hs b/src/Control/Arrow/Machine/Event/Internal.hs deleted file mode 100644 --- a/src/Control/Arrow/Machine/Event/Internal.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Arrows #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GADTs #-} - -module - Control.Arrow.Machine.Event.Internal -where - -import Control.Arrow -import Control.Applicative -import Data.Foldable -import Data.Traversable -import Data.Monoid (Monoid, mappend, mconcat, mempty) -import Data.Semigroup (Semigroup, (<>)) -import Control.Monad (liftM, MonadPlus(..)) - -data Event a = Event a | NoEvent | End deriving (Eq, Show) - - -instance - Functor Event - where - fmap f NoEvent = NoEvent - fmap f End = End - fmap f (Event x) = Event (f x) - -{- -instance - Applicative Event - where - pure = Event - - (Event f) <*> (Event x) = Event $ f x - End <*> _ = End - _ <*> End = End - _ <*> _ = NoEvent --} - -instance - Foldable Event - where - foldMap f (Event x) = f x - foldMap _ NoEvent = mempty - foldMap _ End = mempty - - -instance - Traversable Event - where - traverse f (Event x) = Event <$> f x - traverse f NoEvent = pure NoEvent - traverse f End = pure End - -instance - Semigroup a => Monoid (Event a) - where - mempty = End - Event x `mappend` Event y = Event (x <> y) - Event x `mappend` _ = Event x - _ `mappend` Event y = Event y - NoEvent `mappend` _ = NoEvent - _ `mappend` NoEvent = NoEvent - _ `mappend` _ = End - -{- -instance - Monad Event - where - return = Event - - Event x >>= f = f x - NoEvent >>= _ = NoEvent - End >>= _ = End - - _ >> End = End - l >> r = l >>= const r - - fail _ = End - - -instance - MonadPlus Event - where - mzero = End - - Event x `mplus` _ = Event x - _ `mplus` Event x = Event x - End `mplus` r = r - l `mplus` End = l - _ `mplus` _ = NoEvent --} - - - - -class - Occasional a - where - noEvent :: a - end :: a - isNoEvent :: a -> Bool - isEnd :: a -> Bool - isOccasion :: a -> Bool - isOccasion x = not (isNoEvent x) && not (isEnd x) - -instance - (Occasional a, Occasional b) => Occasional (a, b) - where - noEvent = (noEvent, noEvent) - end = (end, end) - isOccasion xy@(x, y) = - (isOccasion x || isOccasion y) && not (isEnd xy) - isNoEvent xy = - not (isOccasion xy) && not (isEnd xy) - isEnd (x, y) = isEnd x && isEnd y - - - - -instance - Occasional (Event a) - where - noEvent = NoEvent - end = End - isNoEvent NoEvent = True - isNoEvent _ = False - isEnd End = True - isEnd _ = False - -hEv :: ArrowApply a => a (e,b) c -> a e c -> a (e, Event b) c -hEv f1 f2 = proc (e, ev) -> - helper ev -<< e - where - helper (Event x) = proc e -> f1 -< (e, x) - helper NoEvent = f2 - helper End = f2 - -hEv' :: ArrowApply a => a (e,b) c -> a e c -> a e c -> a (e, Event b) c -hEv' f1 f2 f3 = proc (e, ev) -> - helper ev -<< e - where - helper (Event x) = proc e -> f1 -< (e, x) - helper NoEvent = f2 - helper End = f3 - - - - -evMaybe :: Arrow a => c -> (b->c) -> a (Event b) c -evMaybe r f = arr (go r f) - where - go _ f (Event x) = f x - go r _ NoEvent = r - go r _ End = r - - -fromEvent :: Arrow a => b -> a (Event b) b -fromEvent x = evMaybe x id - - --- TODO: テスト -condEvent :: Bool -> Event a -> Event a -condEvent _ End = End -condEvent True ev = ev -condEvent False ev = NoEvent - - --- TODO: テスト -filterEvent :: (a -> Bool) -> Event a -> Event a -filterEvent cond ev@(Event x) = condEvent (cond x) ev -filterEvent _ ev = ev - - -evMap :: Arrow a => (b->c) -> a (Event b) (Event c) -evMap = arr . fmap - - --- TODO: テスト -split :: (Arrow a, Occasional b) => a (Event b) b -split = arr go - where - go (Event x) = x - go NoEvent = noEvent - go End = end - - -join :: (Arrow a, Occasional b) => a b (Event b) -join = arr go - where - go x - | isEnd x = End - | isNoEvent x = NoEvent - | otherwise = Event x - - -split2 :: Event (Event a, Event b) -> (Event a, Event b) -split2 = split - - -join2 :: (Event a, Event b) -> Event (Event a, Event b) -join2 = join diff --git a/src/Control/Arrow/Machine/Exception.hs b/src/Control/Arrow/Machine/Exception.hs deleted file mode 100644 --- a/src/Control/Arrow/Machine/Exception.hs +++ /dev/null @@ -1,98 +0,0 @@ - - -module - Control.Arrow.Machine.Exception - ( - catch, - handle, - bracket, - bracket_, - bracketOnError, - finally, - onException - ) -where - -import qualified Control.Monad.Trans.Free as F -import qualified Control.Monad.Trans.Free.Church as F - -import Data.Functor ((<$>)) - -import Control.Arrow.Machine.Types -import Control.Arrow.Machine.Event -import Control.Arrow.Machine.Event.Internal (Event(..)) - -import Control.Arrow.Machine.Plan.Internal -import Control.Arrow.Machine.Plan - -import Debug.Trace - - -catch :: Monad m => - PlanT i o m a -> PlanT i o m a -> PlanT i o m a - -catch pl cont = - F.toFT $ catch' (F.fromFT pl) (F.fromFT cont) - -catch' (F.FreeT mf) cont@(F.FreeT mcont) = - F.FreeT $ mf >>= go - where - go (F.Pure a) = return $ F.Pure a - go (F.Free StopPF) = mcont - go (F.Free (AwaitPF f ff)) = - return $ F.Free $ - AwaitPF (\i -> f i `catch'` cont) (ff `catch'` cont) - go (F.Free fft) = - return $ F.Free $ (`catch'` cont) <$> fft - -handle :: Monad m => - PlanT i o m a -> PlanT i o m a -> PlanT i o m a - -handle = flip catch - - -bracket :: Monad m => - PlanT i o m a -> (a -> PlanT i o m b)-> (a -> PlanT i o m c) -> PlanT i o m c -bracket before after thing = - do - a <- before - r <- thing a `catch` (after a >> stop) - _ <- after a - return r - - -bracket_ :: Monad m => - PlanT i o m a -> PlanT i o m b-> PlanT i o m c -> PlanT i o m c -bracket_ before after thing = - do - before - r <- thing `catch` (after >> stop) - _ <- after - return r - - -bracketOnError :: Monad m => - PlanT i o m a -> (a -> PlanT i o m b)-> (a -> PlanT i o m c) -> PlanT i o m c -bracketOnError before after thing = - do - a <- before - r <- thing a `catch` (after a >> stop) - return r - - -finally :: Monad m => - PlanT i o m a -> PlanT i o m b-> PlanT i o m a -finally thing after = - do - r <- thing `catch` (after >> stop) - _ <- after - return r - - -onException :: Monad m => - PlanT i o m a -> PlanT i o m b-> PlanT i o m a -onException thing after = - do - thing `catch` (after >> stop) - - diff --git a/src/Control/Arrow/Machine/Misc/Discrete.hs b/src/Control/Arrow/Machine/Misc/Discrete.hs new file mode 100644 --- /dev/null +++ b/src/Control/Arrow/Machine/Misc/Discrete.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Arrows #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module + Control.Arrow.Machine.Misc.Discrete + ( + -- *Discrete + -- | This module should be imported manually. + T(), + updates, + value, + + arr, + arr2, + arr3, + arr4, + arr5, + + constant, + hold, + accum, + fromEq, + + edge, + asUpdater, + Alg + ) +where + +import Prelude hiding (id, (.)) +import Control.Category +import Control.Arrow hiding (arr) +import Control.Applicative +import qualified Control.Arrow as Arr +import qualified Control.Arrow.Machine as P +import Data.Monoid (mconcat, mappend) + +data T a = T { + updates :: (P.Event ()), + value :: a + } + +makeT :: + ArrowApply a => + P.ProcessA a (P.Event (), b) (T b) +makeT = Arr.arr $ uncurry T + +arr :: + ArrowApply a => + (b->c) -> + P.ProcessA a (T b) (T c) +arr f = + Arr.arr $ \(T ev x) -> + T ev (f x) + +arr2 :: + ArrowApply a => + (b1->b2->c) -> + P.ProcessA a (T b1, T b2) (T c) +arr2 f = + Arr.arr $ \(T ev1 x1, T ev2 x2) -> + T (mconcat [ev1, ev2]) (f x1 x2) + +arr3 :: + ArrowApply a => + (b1->b2->b3->c) -> + P.ProcessA a (T b1, T b2, T b3) (T c) +arr3 f = + Arr.arr $ \(T ev1 x1, T ev2 x2, T ev3 x3) -> + T (mconcat [ev1, ev2, ev3]) (f x1 x2 x3) + +arr4 :: + ArrowApply a => + (b1->b2->b3->b4->c) -> + P.ProcessA a (T b1, T b2, T b3, T b4) (T c) +arr4 f = + Arr.arr $ \(T ev1 x1, T ev2 x2, T ev3 x3, T ev4 x4) -> + T (mconcat [ev1, ev2, ev3, ev4]) (f x1 x2 x3 x4) + +arr5 :: + ArrowApply a => + (b1->b2->b3->b4->b5->c) -> + P.ProcessA a (T b1, T b2, T b3, T b4, T b5) (T c) +arr5 f = + Arr.arr $ \(T ev1 x1, T ev2 x2, T ev3 x3, T ev4 x4, T ev5 x5) -> + T (mconcat [ev1, ev2, ev3, ev4, ev5]) (f x1 x2 x3 x4 x5) + +constant:: + ArrowApply a => + c -> + P.ProcessA a b (T c) +constant x = + (P.now &&& Arr.arr (const x)) >>> makeT + +onUpdate :: + ArrowApply a => + P.ProcessA a (P.Event b) (P.Event ()) +onUpdate = proc ev -> + do + n <- P.now -< () + returnA -< n `mappend` P.collapse ev + +hold :: + ArrowApply a => + b -> + P.ProcessA a (P.Event b) (T b) +hold i = + (onUpdate &&& P.hold i) >>> makeT + +accum :: + ArrowApply a => + b -> + P.ProcessA a (P.Event (b->b)) (T b) +accum i = + (onUpdate &&& P.accum i) >>> makeT + +fromEq :: + (ArrowApply a, Eq b) => + P.ProcessA a b (T b) +fromEq = proc x -> + do + ev <- P.edge -< x + returnA -< T (P.collapse ev) x + +edge :: + ArrowApply a => + P.ProcessA a (T b) (P.Event b) +edge = Arr.arr $ \(T ev x) -> x <$ ev + +asUpdater :: + ArrowApply a => + a b c -> + P.ProcessA a (T b) (P.Event c) +asUpdater ar = edge >>> P.anytime ar + + + +newtype Alg a i o = Alg { eval :: P.ProcessA a i (T o) } + +instance + ArrowApply a => Functor (Alg a i) + where + fmap f alg = Alg $ eval alg >>> arr f + +instance + ArrowApply a => Applicative (Alg a i) + where + pure = Alg . constant + af <*> aa = Alg $ (eval af &&& eval aa) >>> arr2 ($) diff --git a/src/Control/Arrow/Machine/Misc/Exception.hs b/src/Control/Arrow/Machine/Misc/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Control/Arrow/Machine/Misc/Exception.hs @@ -0,0 +1,76 @@ + + +module + Control.Arrow.Machine.Misc.Exception + ( + catch, + handle, + bracket, + bracket_, + bracketOnError, + finally, + onException + ) +where + + +import Control.Arrow.Machine.Types + + +catch :: Monad m => + PlanT i o m a -> PlanT i o m a -> PlanT i o m a + +catch = catchP + + +handle :: Monad m => + PlanT i o m a -> PlanT i o m a -> PlanT i o m a + +handle = flip catch + + +bracket :: Monad m => + PlanT i o m a -> (a -> PlanT i o m b)-> (a -> PlanT i o m c) -> PlanT i o m c +bracket before after thing = + do + a <- before + r <- thing a `catch` (after a >> stop) + _ <- after a + return r + + +bracket_ :: Monad m => + PlanT i o m a -> PlanT i o m b-> PlanT i o m c -> PlanT i o m c +bracket_ before after thing = + do + _ <- before + r <- thing `catch` (after >> stop) + _ <- after + return r + + +bracketOnError :: Monad m => + PlanT i o m a -> (a -> PlanT i o m b)-> (a -> PlanT i o m c) -> PlanT i o m c +bracketOnError before after thing = + do + a <- before + r <- thing a `catch` (after a >> stop) + return r + + +finally :: Monad m => + PlanT i o m a -> PlanT i o m b-> PlanT i o m a +finally thing after = + do + r <- thing `catch` (after >> stop) + _ <- after + return r + + +onException :: Monad m => + PlanT i o m a -> PlanT i o m b-> PlanT i o m a +onException thing after = + do + thing `catch` (after >> stop) + + 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 @@ -30,7 +30,7 @@ import qualified Control.Arrow.Machine as P import Data.Monoid (Endo(Endo), mappend, appEndo) -newtype Duct a = Duct { unDuct :: Endo [a] } +newtype Duct a = Duct (Endo [a]) oneMore :: ArrowApply a => diff --git a/src/Control/Arrow/Machine/Plan.hs b/src/Control/Arrow/Machine/Plan.hs deleted file mode 100644 --- a/src/Control/Arrow/Machine/Plan.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE Arrows #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -{-| -A coroutine monad, inspired by machines library. --} -module - Control.Arrow.Machine.Plan - ( - -- * Types and Primitives - PlanT, - Plan, - - await, - yield, - stop, - - stopped, - - -- * Constructing machines - constructT, - repeatedlyT, - - construct, - repeatedly - ) -where - -import qualified Control.Category as Cat -import qualified Control.Monad.Trans.Free as F -import qualified Control.Monad.Trans.Free.Church as F - -import Data.Monoid (mappend) -import Data.Functor ((<$>)) -import Control.Monad -import Control.Arrow -import Control.Monad.Trans -import Debug.Trace - -import Control.Arrow.Machine.ArrowUtil -import Control.Arrow.Machine.Types -import Control.Arrow.Machine.Event -import Control.Arrow.Machine.Event.Internal (Event(..)) - -import Control.Arrow.Machine.Plan.Internal - -stopped :: - (ArrowApply a, Occasional c) => ProcessA a b c -stopped = arr (const end) - - - - - -yield :: o -> Plan i o () -yield x = F.liftF $ YieldPF x () - -await :: Plan i o i -await = F.FT $ \pure free -> free (AwaitPF pure (free StopPF)) - -stop :: Plan i o a -stop = F.liftF $ StopPF - - - - - - -constructT :: (Monad m, ArrowApply a) => - (forall b. m b -> a () b) -> - PlanT i o m r -> - ProcessA a (Event i) (Event o) - -constructT fit pl = ProcessA $ fit' $ F.runFT pl pure free - where - fit' ma = proc arg -> do { (evx, pa) <- fit ma -< (); modFit evx pa -<< arg } - - modFit :: ArrowApply a => Event c -> StepType a b (Event c) -> StepType a b (Event c) - modFit (Event x) stp = retArrow Feed (Event x) (ProcessA stp) - modFit End stp = retArrow Feed End (ProcessA stp) - modFit _ stp = stp - - retArrow ph' evx cont = arr $ \(ph, _) -> - case ph of - Suspend -> - (ph `mappend` Suspend, - if isEnd evx then End else NoEvent, - ProcessA $ retArrow ph' evx cont) - _ -> - (ph `mappend` ph', evx, cont) - - pure _ = return $ (End, retArrow Suspend End stopped) - - free (AwaitPF f ff) = - do - return $ (NoEvent, arr (uncurry (awaitIt f ff)) >>> proc pc -> pc -<< ()) - - free (YieldPF y fc) = return $ (Event y, fit' fc) - - free StopPF = return $ (End, retArrow Suspend End stopped) - - - awaitIt f _ Feed (Event x) = proc _ -> - do - (evy, stp) <- fit (f x) -< () - returnA -< (Feed, evy, ProcessA stp) - - awaitIt _ ff Feed End = proc _ -> - do - (evy, stp) <- fit ff -< () - returnA -< (Feed, evy, ProcessA stp) - - awaitIt _ ff Sweep End = proc _ -> - do - (evy, stp) <- fit ff -< () - returnA -< (if not $ isNoEvent evy then Feed else Suspend, evy, ProcessA stp) - - awaitIt f ff ph evx = proc _ -> - returnA -< (ph `mappend` Suspend, NoEvent, - ProcessA $ arr (uncurry (awaitIt f ff)) >>> proc pc -> pc -<< ()) - - -repeatedlyT :: (Monad m, ArrowApply a) => - (forall b. m b -> a () b) -> - PlanT i o m r -> - ProcessA a (Event i) (Event o) - -repeatedlyT f pl = constructT f $ forever pl - - --- for pure -construct :: ArrowApply a => - Plan i o t -> - ProcessA a (Event i) (Event o) -construct pl = constructT (ary0 unArrowMonad) pl - -repeatedly :: ArrowApply a => - Plan i o t -> - ProcessA a (Event i) (Event o) -repeatedly pl = construct $ forever pl diff --git a/src/Control/Arrow/Machine/Plan/Internal.hs b/src/Control/Arrow/Machine/Plan/Internal.hs deleted file mode 100644 --- a/src/Control/Arrow/Machine/Plan/Internal.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} - -module - Control.Arrow.Machine.Plan.Internal -where - -import qualified Control.Monad.Trans.Free as F -import qualified Control.Monad.Trans.Free.Church as F - -data PlanF i o a where - AwaitPF :: (i->a) -> a -> PlanF i o a - YieldPF :: o -> a -> PlanF i o a - StopPF :: PlanF i o a - -instance (Functor (PlanF i o)) where - fmap g (AwaitPF f ff) = AwaitPF (g . f) (g ff) - fmap g (YieldPF x r) = YieldPF x (g r) - fmap g StopPF = StopPF - - -type PlanT i o m a = F.FT (PlanF i o) m a -type Plan i o a = forall m. Monad m => PlanT i o m a diff --git a/src/Control/Arrow/Machine/Running.hs b/src/Control/Arrow/Machine/Running.hs deleted file mode 100644 --- a/src/Control/Arrow/Machine/Running.hs +++ /dev/null @@ -1,296 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Arrows #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE MultiWayIf #-} - -module - Control.Arrow.Machine.Running - ( - -- * Run at once. - run, - runOn, - run_, - -- * Run step-by-step. - ExecInfo(..), - stepRun, - stepYield - ) -where - -import Control.Arrow -import Control.Applicative (Alternative (..)) -import Control.Monad.State -import Control.Monad.Writer -import Data.Monoid (Monoid (..), Endo(..), appEndo) -import Data.Maybe (fromMaybe) - -import Control.Arrow.Machine.ArrowUtil -import Control.Arrow.Machine.Types -import Control.Arrow.Machine.Event -import Control.Arrow.Machine.Event.Internal (Event(..)) - - --- --- Utilities --- -while_ :: - Monad m => - m Bool -> m a -> m () -while_ cond body = - do - b <- cond - if b - then body >> while_ cond body - else return () - --- | Monoid wrapper -data WithEnd r = WithEnd { - getRWE :: r, - getContWE :: Bool - } - -instance - Monoid r => Monoid (WithEnd r) - where - mempty = WithEnd mempty True - WithEnd x True `mappend` WithEnd y b = WithEnd (x `mappend` y) b - mx@(WithEnd x False) `mappend` _ = mx - - --- --- Running Monad (To be exported) --- -data RunInfo a i o m = RunInfo { - freezeRI :: ProcessA a i o, - getInputRI :: i, - getPaddingRI :: i, - getPhaseRI :: Phase, - getFitRI :: forall p q. a p q -> p -> m q -} - -type RM a i o m = StateT (RunInfo a i o m) m - -runRM :: - (Monad m, ArrowApply a) => - (forall p q. a p q -> p -> m q) -> - ProcessA a (Event i) o -> - RM a (Event i) o m x -> - m x -runRM f pa mx = - evalStateT mx $ - RunInfo { - freezeRI = pa, - getInputRI = NoEvent, - getPaddingRI = NoEvent, - getPhaseRI = Sweep, - getFitRI = f - } - - - -feed_ :: - Monad m => - i -> i -> RM a i o m Bool -feed_ input padding = - do - ph <- gets getPhaseRI - if ph == Suspend - then - do - ri <- get - put $ ri { - getInputRI = input, - getPaddingRI = padding, - getPhaseRI = Feed - } - return True - else - return False - -feed :: - Monad m => - i -> RM a (Event i) o m Bool -feed x = feed_ (Event x) NoEvent - - -finalizeE :: - Monad m => - RM a (Event i) o m Bool -finalizeE = feed_ End End - - -freeze :: - Monad m => - RM a i o m (ProcessA a i o) -freeze = gets freezeRI - - -sweep :: - Monad m => - RM a i o m o -sweep = - do - pa <- freeze - fit <- gets getFitRI - ph <- gets getPhaseRI - x <- if ph == Feed - then gets getInputRI - else gets getPaddingRI - - (ph', y, pa') <- lift $ fit (step pa) (ph, x) - - ri <- get - put $ ri { - freezeRI = - pa', - getPhaseRI = - if ph' == Feed then Sweep else ph' - } - - return y - - -sweepAll :: - (ArrowApply a, Monoid r, Monad m) => - (o->r) -> - WriterT (WithEnd r) (RM a i (Event o) m) () -sweepAll outpre = - while_ - ((not . (== Suspend)) `liftM` lift (gets getPhaseRI)) $ - do - evx <- lift sweep - case evx - of - Event x -> - tell (WithEnd (outpre x) True) - NoEvent -> - return () - End -> - tell (WithEnd mempty False) - - --- | Run a machine with results concatenated in terms of a monoid. -runOn :: - (ArrowApply a, Monoid r) => - (c -> r) -> - ProcessA a (Event b) (Event c) -> - a [b] r -runOn outpre pa0 = unArrowMonad $ \xs -> - do - wer <- runRM arrowMonad pa0 $ execWriterT $ - do - go xs - lift (feed_ End End) - sweepAll outpre - return $ getRWE wer - - where - go xs = - do - (_, wer) <- listen $ sweepAll outpre - if getContWE wer then cont xs else return () - - cont [] = return () - - cont (x:xs) = - do - lift $ feed x - go xs - - --- | Run a machine. -run :: - ArrowApply a => - ProcessA a (Event b) (Event c) -> - a [b] [c] -run pa = - runOn (\x -> Endo (x:)) pa >>> - arr (appEndo `flip` []) - --- | Run a machine discarding all results. -run_ :: - ArrowApply a => - ProcessA a (Event b) (Event c) -> - a [b] () -run_ pa = - runOn (const ()) pa - - --- | Represents return values and informations of step executions. -data ExecInfo fa = - ExecInfo - { - yields :: fa, -- [a] or Maybe a - hasConsumed :: Bool, - hasStopped :: Bool - } - deriving (Eq, Show) - -instance - Alternative f => Monoid (ExecInfo (f a)) - where - mempty = ExecInfo empty False False - ExecInfo y1 c1 s1 `mappend` ExecInfo y2 c2 s2 = - ExecInfo (y1 <|> y2) (c1 || c2) (s1 || s2) - - --- | Execute until an input consumed and the machine suspended. -stepRun :: - ArrowApply a => - ProcessA a (Event b) (Event c) -> - a b (ExecInfo [c], ProcessA a (Event b) (Event c)) - -stepRun pa0 = unArrowMonad $ \x -> - do - (pa, wer) <- runRM arrowMonad pa0 $ runWriterT $ - do - sweepAll singleton - lift $ feed x - sweepAll singleton - lift $ freeze - return $ (retval wer, pa) - - where - singleton x = Endo (x:) - - retval WithEnd {..} = ExecInfo { - yields = appEndo getRWE [], - hasConsumed = True, - hasStopped = not getContWE - } - --- | Execute until an output produced. -stepYield :: - ArrowApply a => - ProcessA a (Event b) (Event c) -> - a b (ExecInfo (Maybe c), ProcessA a (Event b) (Event c)) - -stepYield pa0 = unArrowMonad $ \x -> runRM arrowMonad pa0 $ evalStateT `flip` mempty $ - do - go x - r <- get - pa <- lift freeze - return (r, pa) - - where - go x = - do - csmd <- lift $ feed x - modify $ \ri -> ri { hasConsumed = csmd } - - evo <- lift sweep - - case evo - of - Event y -> - do - modify $ \ri -> ri { yields = Just y } - - NoEvent -> - do - csmd <- gets hasConsumed - if csmd then return () else go x - - End -> - modify $ \ri -> ri { hasStopped = True } 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 @@ -1,221 +1,1171 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} - -module - Control.Arrow.Machine.Types - -- This file includes internals. Export definitions is at ../Machine.hs -where - -import qualified Control.Category as Cat -import Data.Monoid (Monoid(..)) -import Data.Profunctor (Profunctor, dimap) -import Control.Arrow.Operations (ArrowReader(..)) -import Control.Arrow.Transformer.Reader (runReader, ArrowAddReader(..)) -import Control.Arrow - - --- | To get multiple outputs by one input, the `Phase` parameter is introduced. --- --- Once a value `Feed`ed, the machine is `Sweep`ed until it `Suspend`s. -data Phase = Feed | Sweep | Suspend deriving (Eq, Show) - -instance - Monoid Phase - where - mempty = Sweep - - mappend Feed _ = Feed - mappend _ Feed = Feed - mappend Suspend _ = Suspend - mappend _ Suspend = Suspend - mappend Sweep Sweep = Sweep - - -type StepType a b c = a (Phase, b) (Phase, c, ProcessA a b c) - --- | The stream transducer arrow. --- --- To construct `ProcessA` instances, use `Control.Arrow.Machine.Plan.Plan`, --- `arr`, functions declared in `Control.Arrow.Machine.Utils`, --- or arrow combinations of them. --- --- May use `ArrowChoice` and `ArrowLoop` instance too. --- but there is a limitation that `loop` cannot propagate `Event`s to upstream. --- In such case, use `Control.Arrow.Machine.Utils.feedback` instead. -data ProcessA a b c = ProcessA { - step :: StepType a b c - } - -fit :: (Arrow a, Arrow a') => - (forall p q. a p q -> a' p q) -> - ProcessA a b c -> ProcessA a' b c -fit f (ProcessA af) = ProcessA $ f af >>> arr mod - where - mod (ph, y, next) = (ph, y, fit f next) - - -instance - Arrow a => Profunctor (ProcessA a) - where - dimap f g pa = ProcessA $ dimapStep f g (step pa) - {-# INLINE dimap #-} - -dimapStep :: Arrow a => - (b->c)->(d->e)-> - StepType a c d -> StepType a b e -dimapStep f g stp = proc (ph, x) -> - do - (ph', y, pa') <- stp -< (ph, f x) - returnA -< (ph', g y, dimap f g pa') -{-# INLINE [1] dimapStep #-} - - -instance - ArrowApply a => Cat.Category (ProcessA a) - where - id = ProcessA (arrStep id) - {-# INLINE id #-} - g . f = ProcessA $ compositeStep (step f) (step g) - {-# INLINE (.) #-} - - -instance - ArrowApply a => Arrow (ProcessA a) - where - arr = ProcessA . arrStep - {-# INLINE arr #-} - - first pa = ProcessA $ proc (ph, (x, d)) -> - do - (ph', y, pa') <- step pa -< (ph, x) - returnA -< (ph' `mappend` Suspend, (y, d), first pa') - {-# INLINE first #-} - - pa *** pb = ProcessA $ parStep (step pa) (step pb) - {-# INLINE (***) #-} - - -parStep f g = proc (ph, (x1, x2)) -> - do - (ph1, y1, pa') <- f -< (ph, x1) - (ph2, y2, pb') <- g -< (ph, x2) - returnA -< (ph1 `mappend` ph2, (y1, y2), pa' *** pb') -{-# INLINE [1] parStep #-} - -arrStep :: ArrowApply a => (b->c) -> StepType a b c -arrStep f = proc (ph, x) -> - returnA -< (ph `mappend` Suspend, f x, ProcessA $ arrStep f) -{-# INLINE [1] arrStep #-} - - --- |Composition is proceeded by the backtracking strategy. -compositeStep :: ArrowApply a => - StepType a b d -> StepType a d c -> StepType a b c -compositeStep f g = proc (ph, x) -> compositeStep' ph f g -<< (ph, x) -{-# INLINE [1] compositeStep #-} - -compositeStep' :: ArrowApply a => - Phase -> - StepType a b d -> StepType a d c -> StepType a b c - -compositeStep' Sweep f g = proc (_, x) -> - do - (ph1, r1, pa') <- f -< (Suspend, x) - (ph2, r2, pb') <- g -<< (Sweep, r1) - cont ph2 x -<< (r2, pa', pb') - where - cont Feed x = arr $ \(r, pa, pb) -> (Feed, r, pa >>> pb) - cont Sweep x = arr $ \(r, pa, pb) -> (Sweep, r, pa >>> pb) - cont Suspend x = proc (_, pa, pb) -> - do - (ph1, r1, pa') <- step pa -<< (Sweep, x) - (ph2, r2, pb') <- step pb -<< (ph1, r1) - returnA -< (ph2, r2, pa' >>> pb') - -compositeStep' ph f g = proc (_, x) -> - do - (ph1, r1, pa') <- f -< (ph, x) - (ph2, r2, pb') <- g -<< (ph1, r1) - returnA -< (ph2, r2, pa' >>> pb') - --- rules -{-# RULES -"ProcessA: concat/concat" - forall f g h. compositeStep (compositeStep f g) h = compositeStep f (compositeStep g h) -"ProcessA: arr/arr" - forall f g. compositeStep (arrStep f) (arrStep g) = arrStep (g . f) -"ProcessA: arr/*" - forall f g. compositeStep (arrStep f) g = dimapStep f id g -"ProcessA: */arr" - forall f g. compositeStep f (arrStep g) = dimapStep id g f -"ProcessA: dimap/dimap" - forall f g h i j. dimapStep f j (dimapStep g i h) = dimapStep (g . f) (j . i) h -"ProcessA: dimap/arr" - forall f g h. dimapStep f h (arrStep g) = arrStep (h . g . f) -"ProcessA: par/par" - forall f1 f2 g1 g2 h. compositeStep (parStep f1 f2) (compositeStep (parStep g1 g2) h) = - compositeStep (parStep (compositeStep f1 g1) (compositeStep f2 g2)) h -"ProcessA: par/par-2" - forall f1 f2 g1 g2. compositeStep (parStep f1 f2) (parStep g1 g2) = - parStep (compositeStep f1 g1) (compositeStep f2 g2) - #-} - - - -instance - ArrowApply a => ArrowChoice (ProcessA a) - where - left pa@(ProcessA a) = ProcessA $ proc (ph, eth) -> go ph eth -<< () - where - go ph (Left x) = proc _ -> - do - (ph', y, pa') <- a -< (ph, x) - returnA -< (ph', Left y, left pa') - go ph (Right d) = proc _ -> - returnA -< (ph `mappend` Suspend, Right d, left pa) - -instance - (ArrowApply a, ArrowLoop a) => ArrowLoop (ProcessA a) - where - loop pa = ProcessA $ proc (ph, x) -> loop $ go ph -<< x - where - go ph = proc (x, d) -> - do - (ph', (y, d'), pa') <- step pa -< (ph, (x, d)) - returnA -< ((ph', y, loop pa'), d') - - -instance - (ArrowApply a, ArrowReader r a) => - ArrowReader r (ProcessA a) - where - readState = ProcessA $ proc (ph, dm) -> - do - r <- readState -< dm - returnA -< (ph `mappend` Suspend, r, readState) - - newReader pa = ProcessA $ proc (ph, (e, r)) -> - do - (ph', y, pa') <- newReader (step pa) -< ((ph, e), r) - returnA -< (ph', y, newReader pa') - -instance - (ArrowApply a, ArrowApply a', ArrowAddReader r a a') => - ArrowAddReader r (ProcessA a) (ProcessA a') - where - liftReader pa = ProcessA $ proc (ph, x) -> - do - (ph', y, pa') <- (| liftReader (step pa -< (ph, x)) |) - returnA -< (ph', y, liftReader pa) - - elimReader pra = - ProcessA $ arr pre >>> elimReader (step pra) >>> arr post - where - pre (ph, (x, r)) = ((ph, x), r) - post (ph, x, pra') = (ph, x, elimReader pra') +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} + +module + Control.Arrow.Machine.Types + ( + -- * Basic types + ProcessA(), + + Occasional' (..), + Occasional (..), + Event (), + condEvent, + filterEvent, + evMap, + + -- * Plan monads + PlanT, + Plan, + + await, + yield, + stop, + catchP, + + stopped, + muted, + + -- * Constructing machines from plans + constructT, + repeatedlyT, + + construct, + repeatedly, + + -- * Running machines (at once) + run, + runOn, + run_, + + -- * Running machines (step-by-step) + ExecInfo(..), + stepRun, + stepYield, + + -- * Primitive machines - switches + -- | Switches inspired by Yampa library. + -- Signature is almost same, but collection requirement is not only 'Functor', + -- but 'Tv.Traversable'. This is because of side effects. + switch, + dSwitch, + rSwitch, + drSwitch, + kSwitch, + dkSwitch, + pSwitch, + pSwitchB, + rpSwitch, + rpSwitchB, + par, + parB, + + + -- * Primitive machines - other safe primitives + fit, + loop', + + -- * Primitive machines - unsafe + fitEx, + unsafeSteady, + unsafeExhaust, + ) +where + +import qualified Control.Category as Cat +import Data.Profunctor (Profunctor, dimap, rmap) +import Control.Arrow.Operations (ArrowReader(..)) +import Control.Arrow.Transformer.Reader (ArrowAddReader(..)) +import Control.Arrow +import Control.Monad hiding (join) +import Control.Monad.Trans +import Control.Monad.State hiding (join) +import Control.Monad.Writer hiding ((<>), join) +import Control.Applicative hiding (pure) +import qualified Control.Applicative as Ap +import Data.Foldable as Fd +import Data.Traversable as Tv +import Data.Semigroup (Semigroup, (<>)) +import qualified Control.Monad.Trans.Free as F +import qualified Control.Monad.Trans.Free.Church as F +import Control.Arrow.Machine.ArrowUtil +import GHC.Exts (build) + + +-- | To get multiple outputs by one input, the `Phase` parameter is introduced. +-- +-- Once a value `Feed`ed, the machine is `Sweep`ed until it `Suspend`s. +data Phase = Feed | Sweep | Suspend deriving (Eq, Show) + +instance + Monoid Phase + where + mempty = Sweep + + mappend Feed _ = Feed + mappend _ Feed = Feed + mappend Suspend _ = Suspend + mappend _ Suspend = Suspend + mappend Sweep Sweep = Sweep + + +type StepType a b c = a (Phase, b) (Phase, c, ProcessA a b c) + +-- | The stream transducer arrow. +-- +-- To construct `ProcessA` instances, use `Control.Arrow.Machine.Plan.Plan`, +-- `arr`, functions declared in `Control.Arrow.Machine.Utils`, +-- or arrow combinations of them. +newtype ProcessA a b c = ProcessA { + step :: StepType a b c + } + + +fitEx :: (Arrow a, Arrow a') => + (forall p q. a (p, b) (q, c) -> a' (p, b') (q, c')) -> + ProcessA a b c -> + ProcessA a' b' c' +fitEx f k = ProcessA $ proc (ph, x) -> + do + ((ph', k'), y) <- f (step k >>> arr (\(ph', y, k') -> ((ph', k'), y))) -< (ph, x) + returnA -< (ph', y, fitEx f k') + + +fit :: (Arrow a, Arrow a') => + (forall p q. a p q -> a' p q) -> + ProcessA a b c -> ProcessA a' b c +fit f = fitEx f + + +loop' :: ArrowApply a => + d -> + ProcessA a (b, d) (c, d) -> + ProcessA a b c +loop' i pa = ProcessA $ proc (ph, x) -> + do + (ph', (y, n), pa') <- step pa -< (ph, (x, i)) + returnA -< (ph', y, loop' n pa') + +instance + Arrow a => Profunctor (ProcessA a) + where + dimap f g pa = ProcessA $ dimapStep f g (step pa) + {-# INLINE dimap #-} + +dimapStep :: Arrow a => + (b->c)->(d->e)-> + StepType a c d -> StepType a b e +dimapStep f g stp = proc (ph, x) -> + do + (ph', y, pa') <- stp -< (ph, f x) + returnA -< (ph', g y, dimap f g pa') +{-# NOINLINE dimapStep #-} + +instance + Arrow a => Functor (ProcessA a i) + where + fmap = rmap + +instance + ArrowApply a => Applicative (ProcessA a i) + where + pure = arr . const + pf <*> px = (pf &&& px) >>> arr (uncurry ($)) + + +instance + ArrowApply a => Cat.Category (ProcessA a) + where + id = ProcessA idStep + {-# INLINE id #-} + g . f = ProcessA $ compositeStep (step f) (step g) + {-# INLINE (.) #-} + + +instance + ArrowApply a => Arrow (ProcessA a) + where + arr = ProcessA . arrStep + {-# INLINE arr #-} + + first pa = ProcessA $ parStep (step pa) idStep + {-# INLINE first #-} + + second pa = ProcessA $ parStep idStep (step pa) + {-# INLINE second #-} + + pa *** pb = ProcessA $ parStep (step pa) (step pb) + {-# INLINE (***) #-} + + +parStep :: ArrowApply a => + StepType a b c -> + StepType a d e -> + StepType a (b, d) (c, e) +parStep f g = proc (ph, (x1, x2)) -> + do + (ph1, y1, pa') <- f -< (ph, x1) + (ph2, y2, pb') <- g -< (ph, x2) + returnA -< (ph1 `mappend` ph2, (y1, y2), pa' *** pb') +{-# NOINLINE parStep #-} + +idStep :: ArrowApply a => StepType a b b +idStep = proc (ph, x) -> + returnA -< (ph `mappend` Suspend, x, ProcessA $ idStep) +{-# NOINLINE idStep #-} + +arrStep :: ArrowApply a => (b->c) -> StepType a b c +arrStep f = proc (ph, x) -> + returnA -< (ph `mappend` Suspend, f x, ProcessA $ arrStep f) +{-# NOINLINE arrStep #-} + + +-- |Composition is proceeded by the backtracking strategy. +compositeStep :: ArrowApply a => + StepType a b d -> StepType a d c -> StepType a b c +compositeStep f g = proc (ph, x) -> compositeStep' ph f g -<< (ph, x) +{-# NOINLINE compositeStep #-} + +compositeStep' :: ArrowApply a => + Phase -> + StepType a b d -> StepType a d c -> StepType a b c + +compositeStep' Sweep f g = proc (_, x) -> + do + (_, r1, pa') <- f -< (Suspend, x) + (ph2, r2, pb') <- g -<< (Sweep, r1) + cont ph2 -<< (r2, pa', pb', x) + where + cont Feed = arr $ \(r, pa, pb, _) -> (Feed, r, pa >>> pb) + cont Sweep = arr $ \(r, pa, pb, _) -> (Sweep, r, pa >>> pb) + cont Suspend = proc (r, pa, pb, x) -> + do + (ph1, r1, pa') <- step pa -<< (Sweep, x) + (ph2, r2, pb') <- + (if ph1 == Feed + then + step pb + else + arr $ const (Suspend, r, pb)) + -<< (ph1, r1) + returnA -< (ph2, r2, pa' >>> pb') + +compositeStep' ph f g = proc (_, x) -> + do + (ph1, r1, pa') <- f -< (ph, x) + (ph2, r2, pb') <- g -<< (ph1, r1) + returnA -< (ph2, r2, pa' >>> pb') + +-- rules +{-# RULES +"ProcessA: id/*" + forall g. compositeStep idStep g = g +"ProcessA: */id" + forall f. compositeStep f idStep = f + +"ProcessA: concat/concat" + forall f g h. compositeStep (compositeStep f g) h = compositeStep f (compositeStep g h) + +"ProcessA: dimap/dimap" + forall f g h i j. dimapStep f j (dimapStep g i h) = dimapStep (g . f) (j . i) h +"ProcessA: dimap/arr" + forall f g h. dimapStep f h (arrStep g) = arrStep (h . g . f) + +"ProcessA: arr***/par" + forall f1 f2 g1 g2 h. compositeStep (parStep f1 (arrStep f2)) (compositeStep (parStep g1 g2) h) = + compositeStep (parStep (compositeStep f1 g1) (dimapStep f2 id g2)) h +"ProcessA: arr***/par-2" + forall f1 f2 g1 g2. compositeStep (parStep f1 (arrStep f2)) (parStep g1 g2) = + parStep (compositeStep f1 g1) (dimapStep f2 id g2) +"ProcessA: par/***arr" + forall f1 f2 g1 g2 h. compositeStep (parStep f1 f2) (compositeStep (parStep (arrStep g1) g2) h) = + compositeStep (parStep (dimapStep id g1 f1) (compositeStep f2 g2)) h +"ProcessA: par/***arr-2" + forall f1 f2 g1 g2. compositeStep (parStep f1 f2) (parStep (arrStep g1) g2) = + parStep (dimapStep id g1 f1) (compositeStep f2 g2) + +"ProcessA: first/par" + forall f1 g1 g2 h. compositeStep (parStep f1 idStep) (compositeStep (parStep g1 g2) h) = + compositeStep (parStep (compositeStep f1 g1) g2) h +"ProcessA: first/par-2" + forall f1 g1 g2. compositeStep (parStep f1 idStep) (parStep g1 g2) = + parStep (compositeStep f1 g1) g2 +"ProcessA: par/second" + forall f1 f2 g2 h. compositeStep (parStep f1 f2) (compositeStep (parStep idStep g2) h) = + compositeStep (parStep f1 (compositeStep f2 g2)) h +"ProcessA: par/second-2" + forall f1 f2 g2. compositeStep (parStep f1 f2) (parStep idStep g2) = + parStep f1 (compositeStep f2 g2) + +"ProcessA: arr/arr" + forall f g h. compositeStep (arrStep f) (compositeStep (arrStep g) h) = + compositeStep (arrStep (g . f)) h +"ProcessA: arr/arr-2" + forall f g. compositeStep (arrStep f) (arrStep g) = arrStep (g . f) +"ProcessA: arr/*" [1] + forall f g. compositeStep (arrStep f) g = dimapStep f id g +"ProcessA: */arr" [1] + forall f g. compositeStep f (arrStep g) = dimapStep id g f +"ProcessA: arr***arr" [0] + forall f g. parStep (arrStep f) (arrStep g) = arrStep (f *** g) + #-} + +instance + ArrowApply a => ArrowChoice (ProcessA a) + where + left pa@(ProcessA a) = ProcessA $ proc (ph, eth) -> go ph eth -<< () + where + go ph (Left x) = proc _ -> + do + (ph', y, pa') <- a -< (ph, x) + returnA -< (ph', Left y, left pa') + go ph (Right d) = proc _ -> + returnA -< (ph `mappend` Suspend, Right d, left pa) + +instance + (ArrowApply a, ArrowLoop a) => ArrowLoop (ProcessA a) + where + loop = fitEx (\f -> loop (lp f)) + where + lp f = proc ((p, x), d) -> + do + (q, (y, d')) <- f -< (p, (x, d)) + returnA -< ((q, y), d') + + +instance + (ArrowApply a, ArrowReader r a) => + ArrowReader r (ProcessA a) + where + readState = ProcessA $ proc (ph, dm) -> + do + r <- readState -< dm + returnA -< (ph `mappend` Suspend, r, readState) + + newReader = fitEx nr + where + nr f = proc (p, (x, r)) -> newReader f -< ((p, x), r) + +instance + (ArrowApply a, ArrowApply a', ArrowAddReader r a a') => + ArrowAddReader r (ProcessA a) (ProcessA a') + where + liftReader pa = ProcessA $ proc (ph, x) -> + do + (ph', y, pa') <- (| liftReader (step pa -< (ph, x)) |) + returnA -< (ph', y, liftReader pa') + + elimReader pra = + ProcessA $ arr pre >>> elimReader (step pra) >>> arr post + where + pre (ph, (x, r)) = ((ph, x), r) + post (ph, x, pra') = (ph, x, elimReader pra') + + + +data Event a = Event a | NoEvent | End deriving (Eq, Show) + + +instance + Functor Event + where + fmap _ NoEvent = NoEvent + fmap _ End = End + fmap f (Event x) = Event (f x) + + +instance + Semigroup a => Monoid (Event a) + where + mempty = End + Event x `mappend` Event y = Event (x <> y) + Event x `mappend` _ = Event x + _ `mappend` Event y = Event y + NoEvent `mappend` _ = NoEvent + _ `mappend` NoEvent = NoEvent + _ `mappend` _ = End + + + +-- | Signals that can be absent(`NoEvent`) or end. +-- For composite structure, `collapse` can be defined as monoidal sum of all member occasionals. +class + Occasional' a + where + collapse :: a -> Event () + +-- | Occasional signals with creation methods. +class + Occasional' a => Occasional a + where + noEvent :: a + end :: a + + +isNoEvent :: Occasional' a => a -> Bool +isNoEvent = collapse >>> \case { NoEvent -> True; _ -> False } + +isEnd :: Occasional' a => a -> Bool +isEnd = collapse >>> \case { End -> True; _ -> False } + +{- +isOccasion :: Occasional' a => a -> Bool +isOccasion = collapse >>> \case { Event () -> True; _ -> False } +-} + +instance + (Occasional' a, Occasional' b) => Occasional' (a, b) + where + collapse (x, y) = collapse x `mappend` collapse y + +instance + (Occasional a, Occasional b) => Occasional (a, b) + where + noEvent = (noEvent, noEvent) + end = (end, end) + +instance + Occasional' (Event a) + where + collapse = (() <$) + +instance + Occasional (Event a) + where + noEvent = NoEvent + end = End + + + +-- TODO: テスト +condEvent :: Bool -> Event a -> Event a +condEvent _ End = End +condEvent True ev = ev +condEvent False _ = NoEvent + +-- TODO: テスト +filterEvent :: (a -> Bool) -> Event a -> Event a +filterEvent cond ev@(Event x) = condEvent (cond x) ev +filterEvent _ ev = ev + +-- | Alias of "arr . fmap" +-- +-- While "ProcessA a (Event b) (Event c)" means a transducer from b to c, +-- function b->c can be lifted into a transducer by fhis function. +-- +-- But in most cases you needn't call this function in proc-do notations, +-- because `arr`s are completed automatically while desugaring. +-- +-- For example, +-- +-- @ +-- proc x -> returnA -\< f \<$\> x +-- @ +-- +-- is equivalent to +-- +-- @ +-- evMap f +-- @ +evMap :: Arrow a => (b->c) -> a (Event b) (Event c) +evMap = arr . fmap + + +stopped :: + (ArrowApply a, Occasional c) => ProcessA a b c +stopped = arr (const end) + + +muted :: + (ArrowApply a, Occasional' b, Occasional c) => ProcessA a b c +muted = proc x -> + do + rSwitch (arr $ const noEvent) -< ((), stopped <$ collapse x) + + + +data PlanF i o a where + AwaitPF :: (i->a) -> a -> PlanF i o a + YieldPF :: o -> a -> PlanF i o a + StopPF :: PlanF i o a + +instance (Functor (PlanF i o)) where + fmap g (AwaitPF f ff) = AwaitPF (g . f) (g ff) + fmap g (YieldPF x r) = YieldPF x (g r) + fmap _ StopPF = StopPF + + +type PlanT i o m a = F.FT (PlanF i o) m a +type Plan i o a = forall m. Monad m => PlanT i o m a + + +yield :: o -> Plan i o () +yield x = F.liftF $ YieldPF x () + +await :: Plan i o i +await = F.FT $ \pure free -> free (AwaitPF pure (free StopPF)) + +stop :: Plan i o a +stop = F.liftF $ StopPF + + +catchP:: Monad m => + PlanT i o m a -> PlanT i o m a -> PlanT i o m a + +catchP pl cont = + F.toFT $ catch' (F.fromFT pl) (F.fromFT cont) + +catch' :: + Monad m => + F.FreeT (PlanF t o) m a -> + F.FreeT (PlanF t o) m a -> + F.FreeT (PlanF t o) m a + +catch' (F.FreeT mf) cont@(F.FreeT mcont) = + F.FreeT $ mf >>= go + where + go (F.Pure a) = return $ F.Pure a + go (F.Free StopPF) = mcont + go (F.Free (AwaitPF f ff)) = + return $ F.Free $ + AwaitPF (\i -> f i `catch'` cont) (ff `catch'` cont) + go (F.Free fft) = + return $ F.Free $ (`catch'` cont) <$> fft + + + + +constructT :: (Monad m, ArrowApply a) => + (forall b. m b -> a () b) -> + PlanT i o m r -> + ProcessA a (Event i) (Event o) + +constructT fit0 pl = ProcessA $ fit' $ F.runFT pl pure free + where + fit' ma = proc arg -> do { (evx, pa) <- fit0 ma -< (); modFit evx pa -<< arg } + + modFit :: ArrowApply a => Event c -> StepType a b (Event c) -> StepType a b (Event c) + modFit (Event x) stp = retArrow Feed (Event x) (ProcessA stp) + modFit End stp = retArrow Feed End (ProcessA stp) + modFit _ stp = stp + + retArrow ph' evx cont = arr $ \(ph, _) -> + case ph of + Suspend -> + (ph `mappend` Suspend, + if isEnd evx then End else NoEvent, + ProcessA $ retArrow ph' evx cont) + _ -> + (ph `mappend` ph', evx, cont) + + pure _ = return $ (End, retArrow Suspend End stopped) + + free (AwaitPF f ff) = + do + return $ (NoEvent, arr (uncurry (awaitIt f ff)) >>> proc pc -> pc -<< ()) + + free (YieldPF y fc) = return $ (Event y, fit' fc) + + free StopPF = return $ (End, retArrow Suspend End stopped) + + + awaitIt f _ Feed (Event x) = proc _ -> + do + (evy, stp) <- fit0 (f x) -< () + returnA -< (Feed, evy, ProcessA stp) + + awaitIt _ ff Feed End = proc _ -> + do + (evy, stp) <- fit0 ff -< () + returnA -< (Feed, evy, ProcessA stp) + + awaitIt _ ff Sweep End = proc _ -> + do + (evy, stp) <- fit0 ff -< () + returnA -< (if not $ isNoEvent evy then Feed else Suspend, evy, ProcessA stp) + + awaitIt f ff ph _ = proc _ -> + returnA -< (ph `mappend` Suspend, NoEvent, + ProcessA $ arr (uncurry (awaitIt f ff)) >>> proc pc -> pc -<< ()) + + +repeatedlyT :: (Monad m, ArrowApply a) => + (forall b. m b -> a () b) -> + PlanT i o m r -> + ProcessA a (Event i) (Event o) + +repeatedlyT f pl = constructT f $ forever pl + + +-- for pure +construct :: ArrowApply a => + Plan i o t -> + ProcessA a (Event i) (Event o) +construct pl = constructT (ary0 unArrowMonad) pl + +repeatedly :: ArrowApply a => + Plan i o t -> + ProcessA a (Event i) (Event o) +repeatedly pl = construct $ forever pl + + +-- +-- Switches +-- +evMaybePh :: b -> (a->b) -> (Phase, Event a) -> b +evMaybePh _ f (Feed, Event x) = f x +evMaybePh _ f (Sweep, Event x) = f x +evMaybePh d _ _ = d + + +{- +type KSwitchLike a b c t = + ProcessA a b c -> + ProcessA a (b, ) (Event t) -> + (ProcessA a b c -> t -> ProcessA a b c) -> + ProcessA a b c + +switchCore :: + ArrowApply a => + KSwitchLike a b c t -> + ProcessA a b (c, Event t) -> + (t -> ProcessA a b c) -> + ProcessA a b c +-} +switchCore :: + (Arrow cat, Arrow a2, Arrow cat1, Occasional t3) => + (t4 + -> a2 (t5, (t6, c1)) c1 + -> (t -> t1 -> cat a (t2, t3)) + -> cat1 a1 (c, b)) + -> t4 -> (t1 -> cat a t2) -> cat1 a1 c + +switchCore sw cur cont = sw cur (arr test) cont' >>> arr fst + where + test (_, (_, evt)) = evt + cont' _ t = cont t >>> arr (\y -> (y, noEvent)) + +switch :: + ArrowApply a => + ProcessA a b (c, Event t) -> + (t -> ProcessA a b c) -> + ProcessA a b c + +switch = switchCore kSwitch + + +dSwitch :: + ArrowApply a => + ProcessA a b (c, Event t) -> + (t -> ProcessA a b c) -> + ProcessA a b c + +dSwitch = switchCore dkSwitch + + +rSwitch :: + ArrowApply a => ProcessA a b c -> + ProcessA a (b, Event (ProcessA a b c)) c + +rSwitch cur = ProcessA $ proc (ph, (x, eva)) -> + do + let now = evMaybePh cur id (ph, eva) + (ph', y, new) <- step now -<< (ph, x) + returnA -< (ph', y, rSwitch new) + + +drSwitch :: + ArrowApply a => ProcessA a b c -> + ProcessA a (b, Event (ProcessA a b c)) c + +drSwitch cur = ProcessA $ proc (ph, (x, eva)) -> + do + (ph', y, new) <- step cur -< (ph, x) + returnA -< (ph', y, drSwitch (evMaybePh new id (ph, eva))) + +kSwitch :: + ArrowApply a => + ProcessA a b c -> + ProcessA a (b, c) (Event t) -> + (ProcessA a b c -> t -> ProcessA a b c) -> + ProcessA a b c + +kSwitch sf test k = ProcessA $ proc (ph, x) -> + do + (ph', y, sf') <- step sf -< (ph, x) + (phT, evt, test') <- step test -< (ph', (x, y)) + + evMaybePh + (arr $ const (phT, y, kSwitch sf' test' k)) + (step . (k sf')) + (phT, evt) + -<< (phT, x) + + +dkSwitch :: + ArrowApply a => + ProcessA a b c -> + ProcessA a (b, c) (Event t) -> + (ProcessA a b c -> t -> ProcessA a b c) -> + ProcessA a b c + +dkSwitch sf test k = ProcessA $ proc (ph, x) -> + do + (ph', y, sf') <- step sf -< (ph, x) + (phT, evt, test') <- step test -< (ph', (x, y)) + + let + nextA t = k sf' t + nextB = dkSwitch sf' test' k + + returnA -< (phT, y, evMaybePh nextB nextA (ph, evt)) + + +broadcast :: + Functor col => + b -> col sf -> col (b, sf) + +broadcast x sfs = fmap (\sf -> (x, sf)) sfs + + +par :: + (ArrowApply a, Tv.Traversable col) => + (forall sf. (b -> col sf -> col (ext, sf))) -> + col (ProcessA a ext c) -> + ProcessA a b (col c) + +par r sfs = ProcessA $ parCore r sfs >>> arr cont + where + cont (ph, ys, sfs') = (ph, ys, par r sfs') + +parB :: + (ArrowApply a, Tv.Traversable col) => + col (ProcessA a b c) -> + ProcessA a b (col c) + +parB = par broadcast + +parCore :: + (ArrowApply a, Tv.Traversable col) => + (forall sf. (b -> col sf -> col (ext, sf))) -> + col (ProcessA a ext c) -> + a (Phase, b) (Phase, col c, col (ProcessA a ext c)) + +parCore r sfs = proc (ph, x) -> + do + let input = r x sfs + + ret <- unwrapArrow (Tv.sequenceA (fmap (WrapArrow . appPh) input)) -<< ph + + let ph' = Fd.foldMap getPh ret + zs = fmap getZ ret + sfs' = fmap getSf ret + + returnA -< (ph', zs, sfs') + + where + appPh (y, sf) = proc ph -> step sf -< (ph, y) + + getPh (ph, _, _) = ph + getZ (_, z, _) = z + getSf (_, _, sf) = sf + + +pSwitch :: + (ArrowApply a, Tv.Traversable col) => + (forall sf. (b -> col sf -> col (ext, sf))) -> + col (ProcessA a ext c) -> + ProcessA a (b, col c) (Event mng) -> + (col (ProcessA a ext c) -> mng -> ProcessA a b (col c)) -> + ProcessA a b (col c) + +pSwitch r sfs test k = ProcessA $ proc (ph, x) -> + do + (ph', zs, sfs') <- parCore r sfs -<< (ph, x) + (phT, evt, test') <- step test -< (ph', (x, zs)) + + evMaybePh + (arr $ const (ph' `mappend` phT, zs, pSwitch r sfs' test' k)) + (step . (k sfs') ) + (phT, evt) + -<< (ph, x) + +pSwitchB :: + (ArrowApply a, Tv.Traversable col) => + col (ProcessA a b c) -> + ProcessA a (b, col c) (Event mng) -> + (col (ProcessA a b c) -> mng -> ProcessA a b (col c)) -> + ProcessA a b (col c) + +pSwitchB = pSwitch broadcast + + +rpSwitch :: + (ArrowApply a, Tv.Traversable col) => + (forall sf. (b -> col sf -> col (ext, sf))) -> + col (ProcessA a ext c) -> + ProcessA a (b, Event (col (ProcessA a ext c) -> col (ProcessA a ext c))) + (col c) + +rpSwitch r sfs = ProcessA $ proc (ph, (x, evCont)) -> + do + let sfsNew = evMaybePh sfs ($sfs) (ph, evCont) + (ph', ws, sfs') <- parCore r sfsNew -<< (ph, x) + returnA -< (ph' `mappend` Suspend, ws, rpSwitch r sfs') + + +rpSwitchB :: + (ArrowApply a, Tv.Traversable col) => + col (ProcessA a b c) -> + ProcessA a (b, Event (col (ProcessA a b c) -> col (ProcessA a b c))) + (col c) + +rpSwitchB = rpSwitch broadcast + +-- `dpSwitch` and `drpSwitch` are not implemented. + + +-- +-- Unsafe primitives +-- + +-- | Repeatedly call `p`. +-- +-- How many times `p` is called is indefinite. +-- So `p` must satisfy the equation below; +-- +-- @p &&& p === p >>> (id &&& id)@ +unsafeSteady :: + ArrowApply a => + a b c -> + ProcessA a b c +unsafeSteady f = + fitEx + (\id' -> + arr (\(p, x)->((p, ()), x)) >>> + (id' *** f) >>> + arr (\((q, ()), y)->(q, y))) + Cat.id + + +-- | Repeatedly call `p`. +-- +-- How many times `p` is called is indefinite. +-- So `p` must satisfy the equation below; +-- +-- @p &&& (p >>> arr null) === p &&& arr (const True)@ +-- +-- where +-- +-- @null = getAll . foldMap (\_ -> All False)@ +unsafeExhaust :: + (ArrowApply a, Fd.Foldable f) => + a b (f c) -> + ProcessA a b (Event c) +unsafeExhaust p = + go >>> fork + where + go = ProcessA $ proc (ph, x) -> handle ph -<< x + + handle Suspend = + arr $ const (Suspend, NoEvent, go) + + handle ph = proc x -> + do + ys <- p -< x + let ph' = if nullFd ys then Suspend else Feed + returnA -< (ph `mappend` ph', Event ys, go) + + fork = repeatedly $ await >>= Fd.mapM_ yield + + nullFd = getAll . Fd.foldMap (\_ -> All False) + + + +-- +-- Running +-- +-- +-- Utilities +-- +while_ :: + Monad m => + m Bool -> m a -> m () +while_ cond body = + do + b <- cond + if b + then body >> while_ cond body + else return () + +-- | Monoid wrapper +data WithEnd r = WithEnd { + getRWE :: r, + getContWE :: Bool + } + +instance + Monoid r => Monoid (WithEnd r) + where + mempty = WithEnd mempty True + WithEnd x True `mappend` WithEnd y b = WithEnd (x `mappend` y) b + mx@(WithEnd _ False) `mappend` _ = mx + + +-- +-- Running Monad (To be exported) +-- +data RunInfo a i o m = RunInfo { + freezeRI :: ProcessA a i o, + getInputRI :: i, + getPaddingRI :: i, + getPhaseRI :: Phase, + getFitRI :: forall p q. a p q -> p -> m q + } + +type RM a i o m = StateT (RunInfo a i o m) m + +runRM :: + (Monad m, ArrowApply a) => + (forall p q. a p q -> p -> m q) -> + ProcessA a (Event i) o -> + RM a (Event i) o m x -> + m x +runRM f pa mx = + evalStateT mx $ + RunInfo { + freezeRI = pa, + getInputRI = NoEvent, + getPaddingRI = NoEvent, + getPhaseRI = Sweep, + getFitRI = f + } + + + +feed_ :: + Monad m => + i -> i -> RM a i o m Bool +feed_ input padding = + do + ph <- gets getPhaseRI + if ph == Suspend + then + do + ri <- get + put $ ri { + getInputRI = input, + getPaddingRI = padding, + getPhaseRI = Feed + } + return True + else + return False + +feed :: + Monad m => + i -> RM a (Event i) o m Bool +feed x = feed_ (Event x) NoEvent + + +{- +finalizeE :: + Monad m => + RM a (Event i) o m Bool +finalizeE = feed_ End End +-} + +freeze :: + Monad m => + RM a i o m (ProcessA a i o) +freeze = gets freezeRI + + +sweep :: + Monad m => + RM a i o m o +sweep = + do + pa <- freeze + fit0 <- gets getFitRI + ph <- gets getPhaseRI + x <- if ph == Feed + then gets getInputRI + else gets getPaddingRI + + (ph', y, pa') <- lift $ fit0 (step pa) (ph, x) + + ri <- get + put $ ri { + freezeRI = + pa', + getPhaseRI = + if ph' == Feed then Sweep else ph' + } + + return y + + +sweepAll :: + (ArrowApply a, Monoid r, Monad m) => + (o->r) -> + WriterT (WithEnd r) (RM a i (Event o) m) () +sweepAll outpre = + while_ + ((not . (== Suspend)) `liftM` lift (gets getPhaseRI)) $ + do + evx <- lift sweep + case evx + of + Event x -> + tell (WithEnd (outpre x) True) + NoEvent -> + return () + End -> + tell (WithEnd mempty False) + + +-- | Run a machine with results concatenated in terms of a monoid. +runOn :: + (ArrowApply a, Monoid r) => + (c -> r) -> + ProcessA a (Event b) (Event c) -> + a [b] r +runOn outpre pa0 = unArrowMonad $ \xs -> + do + wer <- runRM arrowMonad pa0 $ execWriterT $ + do + go xs + _ <- lift (feed_ End End) + sweepAll outpre + return $ getRWE wer + + where + go xs = + do + (_, wer) <- listen $ sweepAll outpre + if getContWE wer then cont xs else return () + + cont [] = return () + + cont (x:xs) = + do + _ <- lift $ feed x + go xs + + +-- | Run a machine. +newtype Builder a = Builder { + unBuilder :: forall b. (a -> b -> b) -> b -> b + } +instance + Monoid (Builder a) + where + mempty = Builder $ \_ e -> e + Builder g `mappend` Builder f = + Builder $ \c e -> g c (f c e) + +run :: + ArrowApply a => + ProcessA a (Event b) (Event c) -> + a [b] [c] +run pa = + runOn (\x -> Builder $ \c e -> c x e) pa >>> + arr (\b -> build (unBuilder b)) + +-- | Run a machine discarding all results. +run_ :: + ArrowApply a => + ProcessA a (Event b) (Event c) -> + a [b] () +run_ pa = + runOn (const ()) pa + + +-- | Represents return values and informations of step executions. +data ExecInfo fa = + ExecInfo + { + yields :: fa, -- [a] or Maybe a + hasConsumed :: Bool, + hasStopped :: Bool + } + deriving (Eq, Show) + +instance + Alternative f => Monoid (ExecInfo (f a)) + where + mempty = ExecInfo empty False False + ExecInfo y1 c1 s1 `mappend` ExecInfo y2 c2 s2 = + ExecInfo (y1 <|> y2) (c1 || c2) (s1 || s2) + + +-- | Execute until an input consumed and the machine suspended. +stepRun :: + ArrowApply a => + ProcessA a (Event b) (Event c) -> + a b (ExecInfo [c], ProcessA a (Event b) (Event c)) + +stepRun pa0 = unArrowMonad $ \x -> + do + (pa, wer) <- runRM arrowMonad pa0 $ runWriterT $ + do + sweepAll singleton + _ <- lift $ feed x + sweepAll singleton + lift $ freeze + return $ (retval wer, pa) + + where + singleton x = Endo (x:) + + retval WithEnd {..} = ExecInfo { + yields = appEndo getRWE [], + hasConsumed = True, + hasStopped = not getContWE + } + +-- | Execute until an output produced. +stepYield :: + ArrowApply a => + ProcessA a (Event b) (Event c) -> + a b (ExecInfo (Maybe c), ProcessA a (Event b) (Event c)) + +stepYield pa0 = unArrowMonad $ \x -> runRM arrowMonad pa0 $ evalStateT `flip` mempty $ + do + go x + r <- get + pa <- lift freeze + return (r, pa) + + where + go x = + do + csmd <- lift $ feed x + modify $ \ri -> ri { hasConsumed = csmd } + + evo <- lift sweep + + case evo + of + Event y -> + do + modify $ \ri -> ri { yields = Just y } + + NoEvent -> + do + csmd' <- gets hasConsumed + if csmd' then return () else go x + + End -> + modify $ \ri -> ri { hasStopped = True } 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 @@ -2,20 +2,18 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} module Control.Arrow.Machine.Utils ( -- * AFRP-like utilities - delay, hold, accum, edge, passRecent, withRecent, - feedback1, - feedback, -- * Switches -- | Switches inspired by Yampa library. @@ -47,6 +45,7 @@ anytime, par, parB, + now, onEnd, cycleDelay ) @@ -54,43 +53,24 @@ import Prelude hiding (filter) -import Data.Monoid (mappend, mconcat) -import Data.Tuple (swap) +import Data.Maybe (fromMaybe) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Foldable as Fd -import qualified Data.Traversable as Tv import qualified Control.Category as Cat -import Control.Monad.Reader (ask) -import Control.Monad (liftM, forever) import Control.Monad.Trans +import Control.Monad.State import Control.Arrow import Control.Arrow.Operations (ArrowState(..)) -import Control.Arrow.Transformer.State (ArrowAddState(..)) +import Control.Arrow.Transformer.State (ArrowAddState(..), StateArrow()) import Control.Applicative -import Debug.Trace -import Control.Arrow.Machine.Types -import Control.Arrow.Machine.Event -import Control.Arrow.Machine.Event.Internal (Event(..)) import Control.Arrow.Machine.ArrowUtil +import Control.Arrow.Machine.Types -import qualified Control.Arrow.Machine.Plan as Pl -import Control.Arrow.Machine.Exception -delay :: - (ArrowApply a, Occasional b) => ProcessA a b b -delay = join >>> delayImpl >>> split - where - delayImpl = Pl.repeatedly $ - do - mx <- liftM Just Pl.await `catch` return Nothing - Pl.yield noEvent - maybe Pl.stop Pl.yield mx - - hold :: ArrowApply a => b -> ProcessA a (Event b) b {- @@ -101,34 +81,36 @@ -} hold old = proc evx -> do - rSwitch (arr $ const old) -< ((), arr . const <$> evx) + rSwitch (pure old) -< ((), pure <$> evx) accum :: ArrowApply a => b -> ProcessA a (Event (b->b)) b -accum old = ProcessA $ proc (ph, evf) -> - do - let new = fromEvent id evf old - returnA -< (ph `mappend` Suspend, new, accum new) +accum x = switch (pure x &&& arr (($x)<$>)) accum' + where + accum' y = dSwitch (pure y &&& Cat.id) (const (accum y)) + edge :: (ArrowApply a, Eq b) => ProcessA a b (Event b) -edge = ProcessA $ impl Nothing +edge = encloseState (unsafeExhaust impl) Nothing where - impl mvx = proc (ph, x) -> + impl :: + (ArrowApply a, Eq b) => + StateArrow (Maybe b) a b (Maybe b) + impl = proc x -> do - let equals = maybe False (==x) mvx - isActive = not $ ph == Suspend - returnA -< if (not equals) && isActive - then - (Feed, Event x, ProcessA $ impl (Just x)) - else - (ph `mappend` Suspend, NoEvent, ProcessA $ impl mvx) + mprv <- fetch -< () + store -< Just x + returnA -< + case mprv + of + Just prv -> if prv == x then Nothing else Just x + Nothing -> Just x {-# DEPRECATED passRecent, withRecent "Use `hold` instead" #-} infixr 9 `passRecent` -infixr 9 `feedback` passRecent :: (ArrowApply a, Occasional o) => @@ -156,316 +138,75 @@ _ -> returnA -< noEvent -{-# DEPRECATED feedback1, feedback "Use Pump instead" #-} --- |Event version of loop (member of `ArrowLoop`). --- Yielding an event to feedback output always creates a new process cycle. --- So be careful to make an infinite loop. -feedback1 :: - (ArrowApply a, Occasional d) => - ProcessA a (e, AS d) (c, d) -> - ProcessA a (AS e) c -feedback1 pa = ProcessA $ proc (ph, ase) -> - do - (ph', (y, d), pa') <- step pa -< (ph, (fromAS ase, toAS noEvent)) - returnA -< (ph', y, cont ph' d pa') - where - cont phPrev d paC - | isOccasion d = ProcessA $ proc (ph, ase) -> - do - let - (dIn, dOut, phPv2, phCur) = - if ph == Suspend - then - (noEvent, const d, const phPrev, Suspend) - else - (d, id, id, ph `mappend` Feed) - (ph', (y, d'), pa') <- step paC -< (phCur, (fromAS ase, toAS dIn)) - returnA -< (ph', y, cont (phPv2 ph') (dOut d') pa') - | isEnd d && phPrev == Feed = ProcessA $ proc (ph, ase) -> - do - (ph', (y, _), pa') <- step paC -< (ph, (fromAS ase, toAS end)) - returnA -< (ph', y, proc asx -> arr fst <<< pa' -< (fromAS asx, toAS end)) - | otherwise = feedback1 paC - --- |Artificially split into two arrow to use binary operator notation --- rather than banana brackets. -feedback :: - (ArrowApply a, Occasional d) => - ProcessA a (e, AS d) b -> - ProcessA a (e, AS b) (c, d) -> - ProcessA a (AS e) c -feedback pa pb = - feedback1 $ proc (ase, x) -> - do - y <- pa -< (ase, x) - pb -< (ase, toAS y) - - -- --- Switches --- -evMaybePh :: b -> (a->b) -> (Phase, Event a) -> b -evMaybePh _ f (Feed, Event x) = f x -evMaybePh _ f (Sweep, Event x) = f x -evMaybePh d _ _ = d - - -switchCore sw cur cont = sw cur (arr test) cont' >>> arr fst - where - test (_, (_, evt)) = evt - cont' _ t = cont t >>> arr (\y -> (y, noEvent)) - -switch :: - ArrowApply a => - ProcessA a b (c, Event t) -> - (t -> ProcessA a b c) -> - ProcessA a b c - -switch = switchCore kSwitch - - -dSwitch :: - ArrowApply a => - ProcessA a b (c, Event t) -> - (t -> ProcessA a b c) -> - ProcessA a b c - -dSwitch = switchCore dkSwitch - - -rSwitch :: - ArrowApply a => ProcessA a b c -> - ProcessA a (b, Event (ProcessA a b c)) c - -rSwitch cur = ProcessA $ proc (ph, (x, eva)) -> - do - let now = evMaybePh cur id (ph, eva) - (ph', y, new) <- step now -<< (ph, x) - returnA -< (ph', y, rSwitch new) - - -drSwitch :: - ArrowApply a => ProcessA a b c -> - ProcessA a (b, Event (ProcessA a b c)) c - -drSwitch cur = ProcessA $ proc (ph, (x, eva)) -> - do - (ph', y, new) <- step cur -< (ph, x) - - returnA -< (ph', y, next new eva) - - where - next _ (Event af) = drSwitch af - next af _ = drSwitch af - - -kSwitch :: - ArrowApply a => - ProcessA a b c -> - ProcessA a (b, c) (Event t) -> - (ProcessA a b c -> t -> ProcessA a b c) -> - ProcessA a b c - -kSwitch sf test k = ProcessA $ proc (ph, x) -> - do - (ph', y, sf') <- step sf -< (ph, x) - (phT, evt, test') <- step test -< (ph', (x, y)) - - evMaybePh - (arr $ const (phT, y, kSwitch sf' test' k)) - (step . (k sf')) - (phT, evt) - -<< (phT, x) - - -dkSwitch :: - ArrowApply a => - ProcessA a b c -> - ProcessA a (b, c) (Event t) -> - (ProcessA a b c -> t -> ProcessA a b c) -> - ProcessA a b c - -dkSwitch sf test k = ProcessA $ proc (ph, x) -> - do - (ph', y, sf') <- step sf -< (ph, x) - (phT, evt, test') <- step test -< (ph', (x, y)) - - let - nextA t = k sf' t - nextB = dkSwitch sf' test' k - - returnA -< (phT, y, evMaybe nextB nextA evt) - - -broadcast :: - Functor col => - b -> col sf -> col (b, sf) - -broadcast x sfs = fmap (\sf -> (x, sf)) sfs - - -par :: - (ArrowApply a, Tv.Traversable col) => - (forall sf. (b -> col sf -> col (ext, sf))) -> - col (ProcessA a ext c) -> - ProcessA a b (col c) - -par r sfs = ProcessA $ parCore r sfs >>> arr cont - where - cont (ph, ys, sfs') = (ph, ys, par r sfs') - -parB :: - (ArrowApply a, Tv.Traversable col) => - col (ProcessA a b c) -> - ProcessA a b (col c) - -parB = par broadcast - -parCore :: - (ArrowApply a, Tv.Traversable col) => - (forall sf. (b -> col sf -> col (ext, sf))) -> - col (ProcessA a ext c) -> - a (Phase, b) (Phase, col c, col (ProcessA a ext c)) - -parCore r sfs = proc (ph, x) -> - do - let input = r x sfs - - ret <- unwrapArrow (Tv.sequenceA (fmap (WrapArrow . appPh) input)) -<< ph - - let ph' = Fd.foldMap getPh ret - zs = fmap getZ ret - sfs' = fmap getSf ret - - returnA -< (ph', zs, sfs') - - where - appPh (y, sf) = proc ph -> step sf -< (ph, y) - - getPh (ph, _, _) = ph - getZ (_, z, _) = z - getSf (_, _, sf) = sf - - -pSwitch :: - (ArrowApply a, Tv.Traversable col) => - (forall sf. (b -> col sf -> col (ext, sf))) -> - col (ProcessA a ext c) -> - ProcessA a (b, col c) (Event mng) -> - (col (ProcessA a ext c) -> mng -> ProcessA a b (col c)) -> - ProcessA a b (col c) - -pSwitch r sfs test k = ProcessA $ proc (ph, x) -> - do - (ph', zs, sfs') <- parCore r sfs -<< (ph, x) - (phT, evt, test') <- step test -< (ph', (x, zs)) - - evMaybePh - (arr $ const (ph' `mappend` phT, zs, pSwitch r sfs' test' k)) - (step . (k sfs') ) - (phT, evt) - -<< (ph, x) - -pSwitchB :: - (ArrowApply a, Tv.Traversable col) => - col (ProcessA a b c) -> - ProcessA a (b, col c) (Event mng) -> - (col (ProcessA a b c) -> mng -> ProcessA a b (col c)) -> - ProcessA a b (col c) - -pSwitchB = pSwitch broadcast - - -rpSwitch :: - (ArrowApply a, Tv.Traversable col) => - (forall sf. (b -> col sf -> col (ext, sf))) -> - col (ProcessA a ext c) -> - ProcessA a (b, Event (col (ProcessA a ext c) -> col (ProcessA a ext c))) - (col c) - -rpSwitch r sfs = ProcessA $ proc (ph, (x, evCont)) -> - do - let sfsNew = evMaybePh sfs ($sfs) (ph, evCont) - (ph', ws, sfs') <- parCore r sfsNew -<< (ph, x) - returnA -< (ph' `mappend` Suspend, ws, rpSwitch r sfs') - - -rpSwitchB :: - (ArrowApply a, Tv.Traversable col) => - col (ProcessA a b c) -> - ProcessA a (b, Event (col (ProcessA a b c) -> col (ProcessA a b c))) - (col c) - -rpSwitchB = rpSwitch broadcast - --- `dpSwitch` and `drpSwitch` are not implemented. - - --- -- State arrow -- peekState :: (ArrowApply a, ArrowState s a) => ProcessA a e s -peekState = ProcessA $ proc (ph, dm) -> - do - s <- fetch -< dm - returnA -< (ph `mappend` Suspend, s, peekState) +peekState = unsafeSteady fetch +-- Should be exported? +exposeState :: + (ArrowApply a, ArrowApply a', ArrowAddState s a a') => + ProcessA a b c -> + ProcessA a' (b, s) (c, s) +exposeState = fitEx es + where + es f = proc (p, (x, s)) -> + do + ((q, y), s') <- elimState f -< ((p, x), s) + returnA -< (q, (y, s')) + encloseState :: - (ArrowApply a, ArrowAddState s a a') => + (ArrowApply a, ArrowApply a', ArrowAddState s a a') => ProcessA a b c -> s -> ProcessA a' b c -encloseState pa s = ProcessA $ proc (ph, x) -> - do - ((ph', y, pa'), s') <- elimState (step pa) -< ((ph, x), s) - returnA -< (ph', y, encloseState pa' s') +encloseState pa s = loop' s (exposeState pa) -- -- other utility arrow -- |Make two event streams into one. -- Actually `gather` is more general and convenient; --- @ --- ... <- tee -< (e1, e2) --- @ +-- +-- @... \<- tee -\< (e1, e2)@ +-- -- is equivalent to --- @ --- ... <- gather -< [Left <$> e1, Right <$> e2] --- @ +-- +-- @... \<- gather -\< [Left \<$\> e1, Right \<$\> e2]@ +-- tee :: ArrowApply a => ProcessA a (Event b1, Event b2) (Event (Either b1 b2)) -tee = join >>> go - where - go = Pl.repeatedly $ - do - (evx, evy) <- Pl.await - evMaybe (return ()) (Pl.yield . Left) evx - evMaybe (return ()) (Pl.yield . Right) evy +tee = proc (e1, e2) -> gather -< [Left <$> e1, Right <$> e2] + sample :: ArrowApply a => ProcessA a (Event b1, Event b2) [b1] -sample = join >>> Pl.construct (go id) >>> hold [] +{- +sample = join >>> construct (go id) >>> hold [] where go l = do - (evx, evy) <- Pl.await `catch` return (NoEvent, End) + (evx, evy) <- await `catch` return (NoEvent, End) let l2 = evMaybe l (\x -> l . (x:)) evx if isEnd evy then do - Pl.yield $ l2 [] - Pl.stop + yield $ l2 [] + stop else return () - evMaybe (go l2) (\_ -> Pl.yield (l2 []) >> go id) evy + evMaybe (go l2) (\_ -> yield (l2 []) >> go id) evy +-} +sample = undefined -- |Make multiple event channels into one. -- If simultaneous events are given, lefter one is emitted earlier. @@ -477,28 +218,31 @@ singleton x = x NonEmpty.:| [] -- | Provides a source event stream. --- A dummy input event stream is needed. +-- A dummy input event stream is needed. +-- -- @ -- run af [...] -- @ +-- -- is equivalent to +-- -- @ -- run (source [...] >>> af) (repeat ()) -- @ source :: (ArrowApply a, Fd.Foldable f) => f c -> ProcessA a (Event b) (Event c) -source l = Pl.construct $ Fd.mapM_ yd l +source l = construct $ Fd.mapM_ yd l where - yd x = Pl.await >> Pl.yield x + yd x = await >> yield x -- |Given an array-valued event and emit it's values as inidvidual events. fork :: (ArrowApply a, Fd.Foldable f) => ProcessA a (Event (f b)) (Event b) -fork = Pl.repeatedly $ - Pl.await >>= Fd.mapM_ Pl.yield +fork = repeatedly $ + await >>= Fd.mapM_ yield -- |Executes an action once per an input event is provided. anytime :: @@ -506,18 +250,22 @@ a b c -> ProcessA a (Event b) (Event c) -anytime action = Pl.repeatedlyT (ary0 unArrowMonad) $ +anytime action = repeatedlyT (ary0 unArrowMonad) $ do - x <- Pl.await + x <- await ret <- lift $ arrowMonad action x - Pl.yield ret + yield ret -filter cond = Pl.repeatedlyT (ary0 unArrowMonad) $ +filter :: + ArrowApply a => + a b Bool -> + ProcessA a (Event b) (Event b) +filter cond = repeatedlyT (ary0 unArrowMonad) $ do - x <- Pl.await + x <- await b <- lift $ arrowMonad cond x - if b then Pl.yield x else return () + if b then yield x else return () echo :: @@ -526,23 +274,42 @@ echo = filter (arr (const True)) +now :: + ArrowApply a => + ProcessA a b (Event ()) +now = arr (const noEvent) >>> go + where + go = construct $ + yield () >> forever await onEnd :: - (ArrowApply a, Occasional b) => + (ArrowApply a, Occasional' b) => ProcessA a b (Event ()) -onEnd = join >>> go +onEnd = arr collapse >>> go where - go = Pl.repeatedly $ - Pl.await `catch` (Pl.yield () >> Pl.stop) + go = repeatedly $ + await `catchP` (yield () >> stop) -- |Observe a previous value of a signal. -- Tipically used with rec statement. cycleDelay :: ArrowApply a => ProcessA a b b -cycleDelay = ProcessA $ arr begin +cycleDelay = + encloseState impl (Nothing, Nothing) where - begin (ph, x) = (ph `mappend` Suspend, x, ProcessA $ arr (go x)) - go cur (Sweep, x) = (Suspend, cur, ProcessA $ arr (go x)) - go cur (ph, _) = (ph, cur, ProcessA $ arr (go cur)) + impl :: ArrowApply a => ProcessA (StateArrow (Maybe b, Maybe b) a) b b + impl = proc x -> + do + -- Load stored value when backtracking reaches here. + (_, stored) <- peekState -< () + unsafeExhaust (app >>> arr (const Nothing)) -< appStore stored + -- Repeat current value. + (current, _) <- peekState -< () + let x0 = fromMaybe x current + unsafeSteady store -< (Just x0, Just x) + returnA -< x0 + + appStore (Just x) = (proc _ -> store -< (Just x, Nothing), ()) + appStore _ = (Cat.id, ()) diff --git a/test/RandomProc.hs b/test/RandomProc.hs --- a/test/RandomProc.hs +++ b/test/RandomProc.hs @@ -16,6 +16,8 @@ import Control.Monad.State import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized) import Data.Maybe (fromJust) +import Data.Monoid (Sum(..), getSum, mappend) +import Data.Foldable (foldMap) data ProcJoin = PjFst ProcGen | PjSnd ProcGen | PjSum ProcGen @@ -104,9 +106,8 @@ mkProcJ (PjFst pg) = arr fst mkProcJ (PjSnd pg) = arr snd -mkProcJ (PjSum pg) = arr go - where - go (evx, evy) = (+ fromEvent 0 evy) <$> evx +mkProcJ (PjSum pg) = proc (evx, evy) -> + returnA -< getSum <$> foldMap (Sum <$>) [evx, evy] stateProc :: MyProcT (Event a) (Event b) -> [a] -> ([b], [Int]) @@ -159,13 +160,11 @@ instance (TestOut a, TestOut b) => TestOut (a, b) where - output = output *** output >>> P.join >>> mc >>> P.split - where - mc = repeatedly $ - do - (x, y) <- await - yield x - yield y + output = proc (x1, x2) -> + do + y1 <- output -< x1 + y2 <- output -< x2 + gather -< [y1, y2] instance (TestIn a, TestIn b) => @@ -174,7 +173,7 @@ input = proc evx -> do -- 一個前の値で分岐してみる - b <- hold True <<< delay -< + b <- cycleDelay <<< hold True -< (\x -> x `mod` 2 == 0) <$> evx if b @@ -182,7 +181,6 @@ arr Left <<< input -< evx else arr Right <<< input -< evx - instance (TestOut a, TestOut b) => TestOut (Either a b) diff --git a/test/spec.hs b/test/spec.hs --- a/test/spec.hs +++ b/test/spec.hs @@ -4,6 +4,8 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleContexts #-} + module Main where @@ -37,7 +39,6 @@ plans utility switches - operator execution loopUtil @@ -220,14 +221,16 @@ do it "can be used with rec statement(pure)" $ let - a = proc x -> + a = proc ev -> do - rec l <- returnA -< evMaybe [] (:l) x - returnA -< l <$ x + x <- hold 0 -< ev + rec l <- returnA -< x:l + returnA -< l <$ ev result = fst $ stateProc a [2, 5] in take 3 (result!!1) `shouldBe` [5, 5, 5] +{- it "can be used with rec statement(macninery)" $ let mc = anytime Cat.id @@ -254,6 +257,7 @@ z <- hold 0 <<< delay -< y returnA -< y run pa [1, 10] `shouldBe` [1, 2, 12, 24] +-} describe "Rules for ArrowLoop" $ do @@ -340,7 +344,7 @@ do let pl2 = do - x <- await `catch` (yield 1 >> stop) + x <- await `catchP` (yield 1 >> stop) yield x y <- await yield y @@ -351,12 +355,12 @@ utility = do - describe "delay" $ + describe "edge" $ do - it "delays input" $ + it "detects edges of input behaviour" $ do - run (arr (\x->(x,x)) >>> first delay >>> arr fst) [0, 1, 2] `shouldBe` [0, 1, 2] - run (arr (\x->(x,x)) >>> first delay >>> arr snd) [0, 1, 2] `shouldBe` [0, 1, 2] + run (hold 0 >>> edge) [1, 1, 2, 2, 2, 3] `shouldBe` [0, 1, 2, 3] + run (hold 0 >>> edge) [0, 1, 1, 2, 2, 2, 3] `shouldBe` [0, 1, 2, 3] describe "accum" $ do @@ -382,29 +386,6 @@ returnA -< x <$ ed run pa [1..4] `shouldBe` [4] - describe "sample" $ - do - it "samples events in terms of the 2nd input." $ - do - let - pa = proc evx -> - do - evy <- fork -< (\x -> [x, x]) <$> evx - ys <- sample -< (evy, evx) - ed <- onEnd -< evy - outEv <- gather -< [() <$ evx, ed] - returnA -< ys <$ outEv - Control.Monad.join (run pa [1..3]) `shouldBe` [1, 1, 2, 2, 3, 3] - - it "correctly pushes simultaneous events into the same time." $ - do - let - pa = proc evx -> - do - l <- sample -< (evx, evx) - returnA -< l <$ evx - run pa [1..3] `shouldBe` [[1], [2], [3]] - describe "gather" $ do it "correctly handles the end" $ @@ -470,46 +451,6 @@ ret `shouldBe` [7, 2, 6, 18, 21] retD `shouldBe` [7, 3, 6, 12, 21] - -operator = describe "Operators on ProcessA"$ - do - describe "feedback" $ - do - it "acts like local variable with hold." $ - do - let - pa = proc evx -> - do - (\evy -> hold 10 -< evy) - `feedback` \y -> - do - returnA -< ((+y) <$> evx, (y+1) <$ evx) - run pa [1, 2, 3] `shouldBe` [11, 13, 15] - - it "correctly handles stream end." $ - do - let - pa = proc x -> - (\asx -> returnA -< asx) - `feedback` - (\asy -> returnA -< (asy::Event Int, x)) - comp = mkProc (PgPush PgStop) >>> pa - stateProc comp [0, 0] `shouldBe` ([], [0]) - - it "correctly handles stream end.(2)" $ - do - pendingWith "now many utilities behave incorrectly at the end of stream." -{- - let pa = proc x -> (| feedback1 (\y -> returnA -< (y::Event Int, x)) |) - let comp = mkProc (PgPush PgStop) >>> pa >>> mkProc (PgDouble PgNop) - stateProc comp [0, 0] `shouldBe` ([], [0]) - - prop "delays the feedback input." $ \cond -> - let - equiv = mkEquivTest cond - in - delay `equiv` proc x -> (| feedback1 (\y -> returnA -< (y::Event Int, x)) |) --} execution = describe "Execution of ProcessA" $ do