machinecell 1.2.0 → 1.3.0
raw patch · 11 files changed
+650/−371 lines, 11 filesdep +semigroupsdep ~QuickCheckdep ~arrowsdep ~free
Dependencies added: semigroups
Dependency ranges changed: QuickCheck, arrows, free, hspec, mtl, profunctors
Files
- CHANGELOG.md +6/−0
- machinecell.cabal +6/−6
- src/Control/Arrow/Machine/ArrowUtil.hs +82/−8
- src/Control/Arrow/Machine/Event.hs +5/−127
- src/Control/Arrow/Machine/Event/Internal.hs +132/−5
- src/Control/Arrow/Machine/Misc/Pump.hs +61/−0
- src/Control/Arrow/Machine/Plan.hs +7/−65
- src/Control/Arrow/Machine/Running.hs +221/−99
- src/Control/Arrow/Machine/Types.hs +3/−7
- src/Control/Arrow/Machine/Utils.hs +93/−47
- test/spec.hs +34/−7
CHANGELOG.md view
@@ -1,3 +1,9 @@+1.3.0+------------+* Support of `ArrowState`.+* Added utilities related to `ArrowLoop` (cycleDelay, Pump)+* Correct EOS behaviour of some utilities.+ 1.2.0 ------------ * Support of `ArrowReader`.
machinecell.cabal view
@@ -1,5 +1,5 @@ name: machinecell-version: 1.2.0+version: 1.3.0 synopsis: Arrow based stream transducers license: BSD3 license-file: LICENSE@@ -9,7 +9,7 @@ homepage: http://github.com/as-capabl/machinecell bug-reports: http://github.com/as-capabl/machinecell/issues copyright: Copyright (c) 2014 Hidenori Azuma-category: Control+category: Control, FRP, Reactivity build-type: Simple extra-source-files: README.md, CHANGELOG.md .gitignore cabal-version: >=1.10@@ -21,10 +21,10 @@ 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+ 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 other-extensions: FlexibleInstances, Arrows, RankNTypes, TypeSynonymInstances, MultiParamTypeClasses, GADTs, FlexibleContexts, NoMonomorphismRestriction, RecursiveDo- build-depends: base >=4.0 && < 5.0, mtl >=2.0, free >=3.0 && < 5.0, profunctors >=3.0, arrows >= 0.4+ 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 hs-source-dirs: src default-language: Haskell2010 @@ -34,7 +34,7 @@ hs-source-dirs: test main-is: spec.hs other-modules: RandomProc- Build-depends: base >=4.0 && < 5.0, mtl >=2.0, profunctors >=3.0, QuickCheck >=2.0, hspec >=1.0, machinecell+ Build-depends: base >=4.0 && <5.0, mtl >=2.0.1.1, profunctors >=4.0, QuickCheck >=1.0, hspec >=0.2.0, machinecell -any source-repository head type: git@@ -44,4 +44,4 @@ source-repository this type: git location: https://github.com/as-capabl/machinecell.git- tag: release-1.2.0+ tag: release-1.3.0
src/Control/Arrow/Machine/ArrowUtil.hs view
@@ -7,6 +7,13 @@ module Control.Arrow.Machine.ArrowUtil ( -- * Arrow construction helper+ ary0,+ ary1,+ ary2,+ ary3,+ ary4,+ ary5,+ kleisli, kleisli0, kleisli2,@@ -14,7 +21,11 @@ kleisli4, kleisli5, + unArrowMonad,+ arrowMonad,+ reading,+ statefully, -- * To absorve arrow stack signature difference bettween ghc 7.8 and older. AS,@@ -26,9 +37,11 @@ where import Control.Arrow-import Control.Arrow.Operations (readState)+import Control.Arrow.Operations (readState, store, fetch) import Control.Arrow.Transformer.Reader+import Control.Arrow.Transformer.State import Control.Monad.Reader (ReaderT, runReaderT)+import Control.Monad.State (StateT, runStateT) #if __GLASGOW_HASKELL__ >= 708 @@ -52,34 +65,95 @@ #endif +ary0 ::+ (forall p q. (p -> m q) -> a p q) ->+ m b ->+ a () b+ary0 f = f . const +ary1 ::+ (forall p q. (p -> m q) -> a p q) ->+ (a1 -> m b) ->+ a a1 b+ary1 f = f++ary2 ::+ (forall p q. (p -> m q) -> a p q) ->+ (a1 -> a2 -> m b) ->+ a (a1, a2) b+ary2 f fmx = f $ \(x1, x2) -> fmx x1 x2++ary3 ::+ (forall p q. (p -> m q) -> a p q) ->+ (a1 -> a2 -> a3 -> m b) ->+ a (a1, a2, a3) b+ary3 f fmx = f $ \(x1, x2, x3) -> fmx x1 x2 x3++ary4 ::+ (forall p q. (p -> m q) -> a p q) ->+ (a1 -> a2 -> a3 -> a4 -> m b) ->+ a (a1, a2, a3, a4) b+ary4 f fmx = f $ \(x1, x2, x3, x4) -> fmx x1 x2 x3 x4++ary5 ::+ (forall p q. (p -> m q) -> a p q) ->+ (a1 -> a2 -> a3 -> a4 -> a5 -> m b) ->+ a (a1, a2, a3, a4, a5) b+ary5 f fmx = f $ \(x1, x2, x3, x4, x5) -> fmx x1 x2 x3 x4 x5++ kleisli :: Monad m => (a->m b) -> Kleisli m a b-kleisli = Kleisli+kleisli = ary1 Kleisli kleisli0 :: Monad m => m b -> Kleisli m () b-kleisli0 = Kleisli . const+kleisli0 = ary0 Kleisli kleisli2 :: Monad m => (a1 -> a2 -> m b) -> Kleisli m (a1, a2) b-kleisli2 fmx = Kleisli $ \(x1, x2) -> fmx x1 x2+kleisli2 = ary2 Kleisli kleisli3 :: Monad m => (a1 -> a2 -> a3 -> m b) -> Kleisli m (a1, a2, a3) b-kleisli3 fmx = Kleisli $ \(x1, x2, x3) -> fmx x1 x2 x3+kleisli3 = ary3 Kleisli kleisli4 :: Monad m => (a1 -> a2 -> a3 -> a4 -> m b) -> Kleisli m (a1, a2, a3, a4) b-kleisli4 fmx = Kleisli $ \(x1, x2, x3, x4) -> fmx x1 x2 x3 x4+kleisli4 = ary4 Kleisli kleisli5 :: Monad m => (a1 -> a2 -> a3 -> a4 -> a5 -> m b) -> Kleisli m (a1, a2, a3, a4, a5) b-kleisli5 fmx = Kleisli $ \(x1, x2, x3, x4, x5) -> fmx x1 x2 x3 x4 x5+kleisli5 = ary5 Kleisli +unArrowMonad ::+ ArrowApply a =>+ (p -> ArrowMonad a q) -> a p q+unArrowMonad fmx = proc x -> case fmx x of { ArrowMonad a -> a } -<< ()++arrowMonad ::+ ArrowApply a =>+ a p q -> p -> ArrowMonad a q+arrowMonad af x = ArrowMonad $ arr (const x) >>> af++ reading :: (Monad m, Arrow a) => (forall p q. (p->m q)->a p q) -> - (b -> ReaderT r m c) -> ReaderArrow r a b c+ (b -> ReaderT r m c) ->+ ReaderArrow r a b c reading f mr = proc x -> do r <- readState -< () liftReader (f $ \(x, r) -> runReaderT (mr x) r) -< (x, r)++statefully ::+ (Monad m, Arrow a) =>+ (forall p q. (p->m q)->a p q) -> + (b -> StateT s m c) ->+ StateArrow s a b c+statefully f ms = proc x ->+ do+ s <- fetch -< ()+ (y, s') <- liftState (f $ \(x, s) -> runStateT (ms x) s) -< (x, s)+ store -< s'+ returnA -< y+ -- |Alternate for `elimReader` that can be used with both ghc 7.8 and older. elimR ::
src/Control/Arrow/Machine/Event.hs view
@@ -1,22 +1,16 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Arrows #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GADTs #-} module Control.Arrow.Machine.Event ( Occasional (..),- Event (), + Event (),++ -- * Deprecated+ -- |They should be used only for internal use. hEv, hEv', evMaybe, fromEvent, evMap,-- -- * Deprecated- -- | To be renamed. split, join, split2,@@ -24,120 +18,4 @@ ) where --import Control.Monad (liftM, MonadPlus(..))-import Control.Arrow-import Control.Applicative (Applicative(..), Alternative(..), (<$>))-import Data.Foldable (Foldable(..))-import Data.Traversable (Traversable(..))-import Data.Monoid (mempty)-import Control.Arrow.Machine.Event.Internal (Event(..))----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+import Control.Arrow.Machine.Event.Internal
src/Control/Arrow/Machine/Event/Internal.hs view
@@ -1,15 +1,22 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}+ module Control.Arrow.Machine.Event.Internal- (- Event (..), - ) where +import Control.Arrow import Control.Applicative import Data.Foldable import Data.Traversable-import Data.Monoid (mappend, mconcat, mempty)-+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) @@ -47,6 +54,16 @@ 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@@ -75,3 +92,113 @@ 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
+ src/Control/Arrow/Machine/Misc/Pump.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module+ Control.Arrow.Machine.Misc.Pump+ (+ -- *Pump+ -- | This module should be imported manually.+ --+ -- `intake` records events and `outlet` emits recorded events.+ --+ -- Tipically they are used with rec statement.+ --+ -- `clock` arguments are needed to drive a `Pump`.+ -- For a pair of `intake` and `outlet`, `clock` arguments must point the+ -- same event stream.+ Duct(),+ intake,+ outlet+ )+where++import Prelude hiding (id, (.))+import Data.Functor+import Control.Category+import Control.Arrow+import qualified Control.Arrow.Machine as P+import Data.Monoid (Endo(Endo), mappend, appEndo)++newtype Duct a = Duct { unDuct :: Endo [a] }++oneMore ::+ ArrowApply a =>+ P.ProcessA a (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)+intake = proc (ev, clock) ->+ do+ cl2 <- oneMore -< clock+ append <- returnA -< (\x y -> y `mappend` Endo (x:)) <$> ev+ e <- P.accum (Endo id) <<< P.gather -< [ (const $ Endo id) <$ cl2, append ]+ returnA -< Duct e++outlet ::+ ArrowApply a =>+ P.ProcessA a (Duct b, P.Event ()) (P.Event b)+outlet = proc (~(Duct dct), clock) ->+ do+ cl2 <- oneMore -< clock+ dct' <- P.cycleDelay -< dct+ P.fork -< appEndo dct' [] <$ cl2+
src/Control/Arrow/Machine/Plan.hs view
@@ -41,6 +41,7 @@ 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(..))@@ -80,12 +81,15 @@ 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, NoEvent, ProcessA $ retArrow ph' evx cont)+ (ph `mappend` Suspend,+ if isEnd evx then End else NoEvent,+ ProcessA $ retArrow ph' evx cont) _ -> (ph `mappend` ph', evx, cont) @@ -113,69 +117,13 @@ awaitIt _ ff Sweep End = proc _ -> do (evy, stp) <- fit ff -< ()- returnA -< (if isOccasion evy then Feed else Suspend, evy, ProcessA stp)+ 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 -<< ()) -{--ProcessA $ proc (ph, evx) ->- do- probe ph pl -<< evx- - where- runAndYield fx = proc _ ->- do- ff2 <- fit (F.runFreeT fx) -<< ()- oneYieldPF fit Feed ff2 -<< () - probe Suspend pl = proc _ ->- returnA -< (Suspend, NoEvent, constructT fit pl)- - probe ph pl = proc evx ->- do- pfr <- fit (F.runFreeT pl) -< ()- go ph pfr -<< evx-- go Feed (F.Free (AwaitPF f ff)) = arr (\evx -> ((), evx)) >>>- hEv' (proc (_, x) -> runAndYield (f x) -<< ()) - (arr $ const (Feed, NoEvent, constructT fit (await_ f))) - (proc _ -> runAndYield ff -<< ())-- go ph pfr = proc evx ->- do- let action = case (evx, pfr) of {(End, F.Free (AwaitPF _ ff)) -> ff; _ -> F.FreeT $ return pfr}- pfr' <- fit (F.runFreeT action) -<< ()- oneYieldPF fit ph pfr' -<< ()---oneYieldPF :: (Monad m, ArrowApply a) => - (forall b. m b -> a () b) ->- Phase -> - F.FreeF (PlanF i o) r (PlanT i o m r) -> - a () (Phase, - Event o, - ProcessA a (Event i) (Event o))--oneYieldPF f Suspend pfr = proc _ ->- returnA -< (Suspend, NoEvent, constructT f $ F.FreeT $ return pfr)--oneYieldPF f ph (F.Free (YieldPF x cont)) = proc _ ->- returnA -< (Feed, Event x, constructT f cont)--oneYieldPF f ph (F.Free StopPF) = proc _ ->- returnA -< (ph `mappend` Suspend, End, stopped)--oneYieldPF f ph (F.Free pf) = proc _ ->- returnA -< (ph `mappend` Suspend, - NoEvent, - constructT f $ F.FreeT $ return $ F.Free pf)--oneYieldPF f ph (F.Pure x) = proc _ ->- returnA -< (ph `mappend` Suspend, End, stopped)--}- repeatedlyT :: (Monad m, ArrowApply a) => (forall b. m b -> a () b) -> PlanT i o m r -> @@ -188,13 +136,7 @@ construct :: ArrowApply a => Plan i o t -> ProcessA a (Event i) (Event o)-construct pl = constructT kleisli pl- where- kleisli (ArrowMonad a) = a-{-- unKleisli (Kleisli f) = proc x -> - case f x of {ArrowMonad af -> af} -<< ()--} +construct pl = constructT (ary0 unArrowMonad) pl repeatedly :: ArrowApply a => Plan i o t ->
src/Control/Arrow/Machine/Running.hs view
@@ -1,12 +1,16 @@ {-# 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,@@ -16,56 +20,203 @@ import Control.Arrow import Control.Applicative (Alternative (..))-import Data.Monoid (Monoid (..))+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(..)) -adv Feed = Sweep-adv Suspend = Feed+--+-- 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+ } -handle f1 f2 f3 = proc (e, (ph, ev)) ->- handleImpl ph ev -<< e+instance+ Monoid r => Monoid (WithEnd r) where- handleImpl Feed (Event x) = proc e -> f1 -< (e, x)- handleImpl Suspend _ = f3- handleImpl _ End = f3- handleImpl _ _ = f2+ mempty = WithEnd mempty True+ WithEnd x True `mappend` WithEnd y b = WithEnd (x `mappend` y) b+ mx@(WithEnd x False) `mappend` _ = mx -run :: ArrowApply a => ProcessA a (Event b) (Event c) -> a [b] [c]-run pa = proc xs -> +--+-- 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- ys <- go Sweep pa xs id -<< ()- returnA -< ys []+ 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 Sweep pa [] ys = proc _ ->+ go xs = do- (ph', y, pa') <- step pa -< (Sweep, End)- react y ph' pa' [] ys -<< ()+ (_, wer) <- listen $ sweepAll outpre+ if getContWE wer then cont xs else return () - go Feed pa [] ys = arr $ const ys+ cont [] = return () - go ph pa (x:xs) ys = proc _ ->- do- let (evx, xs') = if ph == Feed then (Event x, xs) else (NoEvent, x:xs)- (ph', y, pa') <- step pa -< (ph, evx)- react y ph' pa' xs' ys -<< ()- - react End ph pa xs ys =+ cont (x:xs) = do- go (adv ph) pa [] ys+ lift $ feed x+ go xs - react (Event y) ph pa xs ys =- go (adv ph) pa xs (\cont -> ys (y:cont)) - react NoEvent ph pa xs ys =- go (adv ph) pa xs ys+-- | 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@@ -83,92 +234,63 @@ 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 pa = proc x ->+stepRun pa0 = unArrowMonad $ \x -> do- (ys1, pa', _) <- go pa id -<< (Sweep, NoEvent)- (ys2, pa'', hsS) <- go pa' ys1 -<< (Feed, (Event x))- returnA -< (ExecInfo { yields = ys2 [], hasConsumed = True, hasStopped = hsS } , pa'')+ (pa, wer) <- runRM arrowMonad pa0 $ runWriterT $ + do+ sweepAll singleton+ lift $ feed x+ sweepAll singleton+ lift $ freeze+ return $ (retval wer, pa) where-{-- -- Converted code below with arrowp.- -- Need refactoring overall this file, rather than rewrite here.+ singleton x = Endo (x:) - go pa ys = step pa >>> proc (ph', evy, pa') ->- do- (| handle- (\y -> go pa' (\cont -> ys (y:cont)) -<< (adv ph', NoEvent))- (go pa' ys -<< (adv ph', NoEvent))- (returnA -< (ys, pa', case evy of {End->True; _->False}))- |)- (ph', evy)--}- go pa ys- = step pa >>>- (arr (\ (ph', evy, pa') -> ((evy, pa', ph'), (ph', evy))) >>>- handle- (arr- (\ ((evy, pa', ph'), y) ->- (go pa' (\ cont -> ys (y : cont)), (adv ph', NoEvent)))- >>> app)- (arr (\ (evy, pa', ph') -> (go pa' ys, (adv ph', NoEvent))) >>>- app)- (arr- (\ (evy, pa', ph') ->- (ys, pa',- case evy of- End -> True- _ -> False))))+ 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 pa = proc x ->+stepYield pa0 = unArrowMonad $ \x -> runRM arrowMonad pa0 $ evalStateT `flip` mempty $ do- (my, pa', hsS) <- go pa -<< (Sweep, NoEvent)- cont my pa' hsS -<< x-- where- cont (Just y) pa' hsS = proc _ ->- returnA -< (ExecInfo { yields = Just y, hasConsumed = False, hasStopped = hsS}, pa')-- cont Nothing pa' hsS = proc x ->- do- (my2, pa'', hsS') <- go pa' -<< (Feed, (Event x))- returnA -< (ExecInfo { yields = my2, hasConsumed = True, hasStopped = hsS}, pa'')-{-- -- Converted code below with arrowp.- -- Need refactoring overall this file, rather than rewrite here.+ go x+ r <- get+ pa <- lift freeze+ return (r, pa) - go pa = step pa >>> proc (ph', evy, pa') ->+ where + go x = do- (| handle- (\y -> returnA -<< (Just y, pa', False))- (go pa' -<< (adv ph', NoEvent))- (returnA -< (Nothing, pa', case evy of {End->True; _->False}))- |)- (ph', evy)--}- go pa = step pa >>>- (arr (\ (ph', evy, pa') -> ((evy, pa', ph'), (ph', evy))) >>>- handle (arr (\ ((evy, pa', ph'), y) -> (Just y, pa', False)))- (arr (\ (evy, pa', ph') -> (go pa', (adv ph', NoEvent))) >>> app)- (arr- (\ (evy, pa', ph') ->- (Nothing, pa',- case evy of- End -> True- _ -> False))))--+ 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 }
src/Control/Arrow/Machine/Types.hs view
@@ -14,7 +14,7 @@ import Data.Monoid (Monoid(..)) import Data.Profunctor (Profunctor, dimap) import Control.Arrow.Operations (ArrowReader(..))-import Control.Arrow.Transformer.Reader (ReaderArrow, runReader, ArrowAddReader(..))+import Control.Arrow.Transformer.Reader (runReader, ArrowAddReader(..)) import Control.Arrow @@ -217,9 +217,5 @@ where pre (ph, (x, r)) = ((ph, x), r) post (ph, x, pra') = (ph, x, elimReader pra')-{-- elimReader pra = ProcessA $ proc (ph, (x, r)) ->- do- (ph', y, pra') <- (| elimReader (step pra -< (ph, x)) |) r- returnA -< (ph', y, elimReader pra')--}++
src/Control/Arrow/Machine/Utils.hs view
@@ -32,6 +32,10 @@ rpSwitch, rpSwitchB, + -- * State arrow+ peekState,+ encloseState,+ -- * Other utility arrows tee, gather,@@ -43,7 +47,8 @@ anytime, par, parB,- onEnd+ onEnd,+ cycleDelay ) where @@ -51,13 +56,16 @@ import Data.Monoid (mappend, mconcat) import Data.Tuple (swap)+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.Arrow-import Control.Arrow.Transformer.Reader (ReaderArrow, runReader)+import Control.Arrow.Operations (ArrowState(..))+import Control.Arrow.Transformer.State (ArrowAddState(..)) import Control.Applicative import Debug.Trace @@ -118,7 +126,7 @@ else (ph `mappend` Suspend, NoEvent, ProcessA $ impl mvx) -+{-# DEPRECATED passRecent, withRecent "Use `hold` instead" #-} infixr 9 `passRecent` infixr 9 `feedback` @@ -148,7 +156,7 @@ _ -> 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.@@ -202,6 +210,7 @@ -- 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 @@ -393,9 +402,42 @@ rpSwitchB = rpSwitch broadcast +-- `dpSwitch` and `drpSwitch` are not implemented.++ ----- other utility arrow+-- 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)++encloseState ::+ (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')++--+-- other utility arrow++-- |Make two event streams into one.+-- Actually `gather` is more general and convenient;+-- @+-- ... <- tee -< (e1, e2)+-- @+-- is equivalent to+-- @+-- ... <- gather -< [Left <$> e1, Right <$> e2]+-- @ tee :: ArrowApply a => ProcessA a (Event b1, Event b2) (Event (Either b1 b2)) tee = join >>> go@@ -414,66 +456,68 @@ where go l = do- (evx, evy) <- Pl.await+ (evx, evy) <- Pl.await `catch` return (NoEvent, End) let l2 = evMaybe l (\x -> l . (x:)) evx+ if isEnd evy+ then+ do+ Pl.yield $ l2 []+ Pl.stop+ else+ return () evMaybe (go l2) (\_ -> Pl.yield (l2 []) >> go id) evy +-- |Make multiple event channels into one.+-- If simultaneous events are given, lefter one is emitted earlier. gather :: (ArrowApply a, Fd.Foldable f) => ProcessA a (f (Event b)) (Event b)-gather = arr Event >>> - Pl.repeatedly - (Pl.await >>= Fd.mapM_ (evMaybe (return ()) Pl.yield))+gather = arr (Fd.foldMap $ fmap singleton) >>> fork+ where+ singleton x = x NonEmpty.:| [] --- |It's also possible that source is defined without any await.--- --- But awaits are useful to synchronize other inputs.+-- | Provides a source event stream.+-- A dummy input event stream is needed. +-- @+-- run af [...]+-- @+-- is equivalent to+-- @+-- run (source [...] >>> af) (repeat ())+-- @ source ::- ArrowApply a =>- [c] -> ProcessA a (Event b) (Event c)-source l = Pl.construct $ mapM_ yd l+ (ArrowApply a, Fd.Foldable f) =>+ f c -> ProcessA a (Event b) (Event c)+source l = Pl.construct $ Fd.mapM_ yd l where yd x = Pl.await >> Pl.yield x -fork :: +-- |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 -+-- |Executes an action once per an input event is provided. anytime :: ArrowApply a => a b c -> ProcessA a (Event b) (Event c) -anytime action = Pl.repeatedlyT arrow $+anytime action = Pl.repeatedlyT (ary0 unArrowMonad) $ do x <- Pl.await- ret <- lift $ (ArrowMonad $ arr (const x) >>> action)+ ret <- lift $ arrowMonad action x Pl.yield ret- where- arrow (ArrowMonad af) = af -{--asNeeded action = ProcessA $ snd action >>> arr post- where- post (ph, y) = (ph `mconcat` Suspend, y, asNeeded action) -asNeeded :: - ArrowApply a =>- a b Bool ->- ProcessA a (Event b) (Event b)--}--filter cond = Pl.repeatedlyT arrow $+filter cond = Pl.repeatedlyT (ary0 unArrowMonad) $ do x <- Pl.await- b <- lift $ (ArrowMonad $ arr (const x) >>> cond)+ b <- lift $ arrowMonad cond x if b then Pl.yield x else return ()- where- arrow (ArrowMonad af) = af echo :: @@ -486,17 +530,19 @@ onEnd :: (ArrowApply a, Occasional b) => ProcessA a b (Event ())-{--onEnd = dSwitch (arr go) id+onEnd = join >>> go where- go ev- | isEnd ev = (undefined, Event Pl.stopped)- | otherwise = noEvent--}-onEnd = ProcessA $ proc (ph, ev) ->- do- returnA -< go ph ev+ go = Pl.repeatedly $+ Pl.await `catch` (Pl.yield () >> Pl.stop)+ +-- |Observe a previous value of a signal.+-- Tipically used with rec statement.+cycleDelay ::+ ArrowApply a => ProcessA a b b+cycleDelay = ProcessA $ arr begin where- go ph ev - | isEnd ev = (Feed, Event (), Pl.stopped)- | otherwise = (ph `mappend` Suspend, noEvent, onEnd)+ 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))++
test/spec.hs view
@@ -8,6 +8,7 @@ Main where +import Prelude hiding (filter) import Data.Maybe (fromMaybe) import Control.Arrow.Machine as P import Control.Applicative ((<$>), (<*>), (<$)) @@ -22,12 +23,23 @@ 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; operator; execution} +main = hspec $ + do + basics + rules + loops + choice + plans + utility + switches + operator + execution + loopUtil basics = @@ -374,18 +386,16 @@ do it "samples events in terms of the 2nd input." $ do - pendingWith "now many utilities behave incorrectly at the end of stream." -{- let pa = proc evx -> do evy <- fork -< (\x -> [x, x]) <$> evx ys <- sample -< (evy, evx) - ed <- onEnd -< evx + ed <- onEnd -< evy outEv <- gather -< [() <$ evx, ed] returnA -< ys <$ outEv - Control.Monad.join (run pa [1..2]) `shouldBe` [1, 1, 2, 2] --} + 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 @@ -394,6 +404,23 @@ l <- sample -< (evx, evx) returnA -< l <$ evx run pa [1..3] `shouldBe` [[1], [2], [3]] + + describe "gather" $ + do + it "correctly handles the end" $ + do + let + pa = proc x -> + do + r1 <- 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