machinecell 1.0.1 → 1.1.0
raw patch · 11 files changed
+267/−105 lines, 11 filesdep −haddockdep ~freedep ~profunctors
Dependencies removed: haddock
Dependency ranges changed: free, profunctors
Files
- .gitignore +10/−0
- CHANGELOG.md +6/−0
- machinecell.cabal +15/−10
- src/Control/Arrow/Machine/Event.hs +4/−72
- src/Control/Arrow/Machine/Event/Internal.hs +77/−0
- src/Control/Arrow/Machine/Plan.hs +1/−2
- src/Control/Arrow/Machine/Running.hs +1/−0
- src/Control/Arrow/Machine/Types.hs +6/−0
- src/Control/Arrow/Machine/Utils.hs +66/−4
- test/RandomProc.hs +8/−6
- test/spec.hs +73/−11
+ .gitignore view
@@ -0,0 +1,10 @@+dist+cabal-dev+*.o+*.hi+*.chi+*.chs.h+.virthualenv+++
CHANGELOG.md view
@@ -1,3 +1,9 @@+1.1.0+------------+* Hide `Event` constructors and some instances (`Applicative`, `Monad`).+* Added `feedback`+* Fixed `accum`+ 1.0,1 ------------ * Fix some bugs of core part.
machinecell.cabal view
@@ -1,25 +1,30 @@--- Initial machinecell.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/- name: machinecell-version: 1.0.1+version: 1.1.0 synopsis: Arrow based stream transducers-description: Stream processing library similar to pipes, couduit, machines. With support of arrow combinatins, or the arrow notation. AFRP-like utilities are also available. license: BSD3 license-file: LICENSE author: Hidenori Azuma maintainer: Hidenori Azuma <as.capabl@gmail.com>+stability: experimental+homepage: http://github.com/as-capabl/machinecell+bug-reports: http://github.com/as-capabl/machinecell/issues copyright: Copyright (c) 2014 Hidenori Azuma category: Control build-type: Simple-extra-source-files: README.md, CHANGELOG.md+extra-source-files: README.md, CHANGELOG.md .gitignore cabal-version: >=1.10 +description:+ Stream processing library similar to pipes, couduit, or machines.+ .+ Arrow combinatins are supported and can be used with the arrow notation.+ 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--- other-modules: + other-modules: Control.Arrow.Machine.Event.Internal other-extensions: FlexibleInstances, Arrows, RankNTypes, TypeSynonymInstances, MultiParamTypeClasses, GADTs, FlexibleContexts, NoMonomorphismRestriction, RecursiveDo- build-depends: base >=4.0 && < 5.0, mtl >=2.0, haddock >= 0.6, free >=4.0 && < 5.0, profunctors >=4.0+ build-depends: base >=4.0 && < 5.0, mtl >=2.0, free >=3.0 && < 5.0, profunctors >=3.0 hs-source-dirs: src default-language: Haskell2010 @@ -29,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 >=4.0, QuickCheck >=2.0, hspec >=1.0, machinecell+ Build-depends: base >=4.0 && < 5.0, mtl >=2.0, profunctors >=3.0, QuickCheck >=2.0, hspec >=1.0, machinecell source-repository head type: git@@ -39,4 +44,4 @@ source-repository this type: git location: https://github.com/as-capabl/machinecell.git- tag: release-1.0.1+ tag: release-1.1.0
src/Control/Arrow/Machine/Event.hs view
@@ -8,7 +8,7 @@ Control.Arrow.Machine.Event ( Occasional (..),- Event (..), + Event (), hEv, hEv', evMaybe,@@ -28,8 +28,10 @@ import Data.Foldable (Foldable(..)) import Data.Traversable (Traversable(..)) import Data.Monoid (mempty)+import Control.Arrow.Machine.Event.Internal (Event(..)) + class Occasional a where@@ -52,8 +54,8 @@ isEnd (x, y) = isEnd x && isEnd y -data Event a = Event a | NoEvent | End deriving (Eq, Show) + instance Occasional (Event a) where@@ -81,76 +83,6 @@ helper End = f3 -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- Alternative Event- where- empty = NoEvent- End <|> _ = End- _ <|> End = End- Event x <|> _ = Event x- NoEvent <|> r = r---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 evMaybe :: Arrow a => c -> (b->c) -> a (Event b) c
+ src/Control/Arrow/Machine/Event/Internal.hs view
@@ -0,0 +1,77 @@+module+ Control.Arrow.Machine.Event.Internal+ (+ Event (..), + )+where++import Control.Applicative+import Data.Foldable+import Data.Traversable+import Data.Monoid (mappend, mconcat, mempty)++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+ 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+-}
src/Control/Arrow/Machine/Plan.hs view
@@ -36,13 +36,12 @@ import Data.Monoid (mappend) import Control.Monad import Control.Arrow-import Control.Applicative import Control.Monad.Trans import Debug.Trace import Control.Arrow.Machine.Types import Control.Arrow.Machine.Event-+import Control.Arrow.Machine.Event.Internal (Event(..)) stopped :: (ArrowApply a, Occasional c) => ProcessA a b c
src/Control/Arrow/Machine/Running.hs view
@@ -20,6 +20,7 @@ import Control.Arrow.Machine.Types import Control.Arrow.Machine.Event+import Control.Arrow.Machine.Event.Internal (Event(..)) adv Feed = Sweep
src/Control/Arrow/Machine/Types.hs view
@@ -36,6 +36,10 @@ -- 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 }@@ -101,6 +105,8 @@ 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)
src/Control/Arrow/Machine/Utils.hs view
@@ -14,6 +14,8 @@ edge, passRecent, withRecent,+ feedback1,+ feedback, -- * Switches -- | Switches inspired by Yampa library.@@ -60,14 +62,14 @@ import Control.Arrow.Machine.Types import Control.Arrow.Machine.Event+import Control.Arrow.Machine.Event.Internal (Event(..)) import qualified Control.Arrow.Machine.Plan as Pl --delay :: +delay :: (ArrowApply a, Occasional b) => ProcessA a b b delay = join >>> delayImpl >>> split where@@ -91,9 +93,10 @@ accum :: ArrowApply a => b -> ProcessA a (Event (b->b)) b-accum old = proc evf ->+accum old = ProcessA $ proc (ph, evf) -> do- rSwitch (arr $ const old) -< ((), arr . const <$> (evf <*> pure old))+ let new = fromEvent id evf old+ returnA -< (ph `mappend` Suspend, new, accum new) edge :: (ArrowApply a, Eq b) =>@@ -113,6 +116,7 @@ infixr 9 `passRecent`+infixr 9 `feedback` passRecent :: (ArrowApply a, Occasional o) =>@@ -134,6 +138,64 @@ ProcessA a (e, Event b) o withRecent af = proc (e, evb) -> (returnA -< evb) `passRecent` (\b -> af -< (e, b))++++-- |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, d) (c, d) ->+ ProcessA a e c+feedback1 pa = ProcessA $ proc (ph, e) ->+ do+ (ph', (y, d), pa') <- step pa -< (ph, (e, noEvent))+ returnA -< (ph', y, cont ph' d pa')+ where+ cont phPrev d paC + | isOccasion d = ProcessA $ proc (ph, e) ->+ 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, (e, dIn))+ returnA -< (ph', y, cont (phPv2 ph') (dOut d') pa')++ | isEnd d && phPrev == Feed = ProcessA $ proc (ph, e) ->+ do+ (ph', (y, _), pa') <- step pa -< (ph, (e, end))+ returnA -< (ph', y, proc x -> arr fst <<< pa' -< (x, end))++ | otherwise = feedback1 paC++{-+proc e ->+ do+ (y, _) <- kSwitch pa test eval -< (e, noEvent)+ returnA -< y+ where+ test = + eval pa' d = switch (yielder >>> +-}++-- |Artificially split into two arrow to use binary operator notation+-- rather than banana brackets.+feedback ::+ (ArrowApply a, Occasional d) =>+ ProcessA a (e, d) b ->+ ProcessA a (e, b) (c, d) ->+ ProcessA a e c+feedback pa pb = + feedback1 $ proc (e, x) -> + do + y <- pa -< (e, x)+ pb -< (e, y) --
test/RandomProc.hs view
@@ -72,7 +72,8 @@ yield x mkProc (PgPop (fx, fy) fz) =- mc >>> P.split >>> (mkProc fx *** mkProc fy) >>> mkProcJ fz+ mc >>> ((evMap fst >>> fork) &&& (evMap snd >>> fork))+ >>> (mkProc fx *** mkProc fy) >>> mkProcJ fz where mc = repeatedlyT kleisli0 $ do@@ -81,11 +82,11 @@ case ys of [] -> - yield (Event x, NoEvent)+ yield (Just x, Nothing) (y:yss) -> do lift $ put yss- yield (Event x, Event y)+ yield (Just x, Just y) mkProc (PgOdd next) = P.filter (arr cond) >>> mkProc next where@@ -105,7 +106,7 @@ mkProcJ (PjSnd pg) = arr snd mkProcJ (PjSum pg) = arr go where- go (evx, evy) = (+) <$> evx <*> evy+ go (evx, evy) = (+ fromEvent 0 evy) <$> evx stateProc :: MyProcT (Event a) (Event b) -> [a] -> ([b], [Int])@@ -146,13 +147,14 @@ instance (TestIn a, TestIn b) => TestIn (a, b) where- input = mc >>> P.split >>> input *** input+ input = mc >>> + ((evMap fst >>> fork >>> input) &&& (evMap snd >>> fork >>> input)) where mc = repeatedly $ do x <- await y <- await- yield (Event x, Event y)+ yield (Just x, Just y) instance (TestOut a, TestOut b) => TestOut (a, b)
test/spec.hs view
@@ -27,8 +27,7 @@ - -main = hspec $ do {basics; rules; loops; choice; plans; utility; switches; execution} +main = hspec $ do {basics; rules; loops; choice; plans; utility; switches; operator; execution} basics = @@ -95,9 +94,7 @@ prop "each path can have independent number of events" $ \l -> let - split2' (Event (x, y)) = (Event x, Event y) - split2' NoEvent = (NoEvent, NoEvent) - split2' End = (End, End) + split2' = fmap fst &&& fmap snd gen = arr (fmap $ \x -> [x, x]) >>> fork >>> arr split2' r1 = runKI (run (gen >>> arr fst)) (l::[(Int, [Int])]) r2 = runKI (run (gen >>> second (fork >>> echo) >>> arr fst)) @@ -143,9 +140,9 @@ (f >>> g) `equiv` (f >>> arr id >>> g) it "can be parallelized" $ - let - in do + pendingWith "to correct" +{- let myProc2 = repeatedlyT (Kleisli . const) $ do @@ -153,9 +150,7 @@ lift $ modify (++ [x]) yield `mapM` (take x $ repeat x) - toN (Event x) = Just x - toN NoEvent = Nothing - toN End = Nothing + toN = evMaybe Nothing Just en (ex, ey) = Event (toN ex, toN ey) de evxy = (fst <$> evxy, snd <$> evxy) @@ -169,6 +164,7 @@ (result >>= maybe mzero return . snd) `shouldBe` [1,2,3] state `shouldBe` [1,2,3] +-} prop "first and composition." $ \fx gx cond -> let @@ -338,6 +334,18 @@ 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] + describe "accum" $ + do + it "acts like fold." $ + do + let + pa = proc evx -> + do + val <- accum 0 -< (+1) <$ evx + returnA -< val <$ evx + + run pa (replicate 10 ()) `shouldBe` [1..10] + describe "onEnd" $ do it "fires only once at the end of a stream." $ @@ -385,7 +393,7 @@ before = proc evx -> do ch <- P.filter (arr $ (\x -> x `mod` 2 == 0)) -< evx - returnA -< (NoEvent, ch) + returnA -< (noEvent, ch) after t = proc evx -> returnA -< (t*) <$> evx @@ -405,6 +413,8 @@ do it "switches any times" $ do + pendingWith "to correct" +{- let theArrow sw = proc evtp -> do @@ -419,7 +429,44 @@ ret `shouldBe` [7, 2, 4] retD `shouldBe` [7, 3, 4] +-} +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 -> (| feedback1 (\y -> returnA -< (y::Event Int, x)) |) + let 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 let @@ -450,6 +497,21 @@ (ret, _) = stepRun now2 1 yields ret `shouldBe` ([]::[Int]) hasStopped ret `shouldBe` True + + it "supports step execution (2)" $ + pendingWith "Correct stop handling" +{- + prop "supports step execution (2)" $ \p l -> + let + pa = mkProc p + all pc (x:xs) ys = + do + (r, cont) <- runKleisli (stepRun pc) x + all cont (if hasStopped r then [] else xs) (ys ++ yields r) + all pc [] ys = runKleisli (run pc) [] >>= return . (ys++) + in + runState (all pa (l::[Int]) []) [] == stateProc pa l +-} it "supports yield-driven step" $ do