machinecell (empty) → 1.0.0
raw patch · 13 files changed
+1962/−0 lines, 13 filesdep +QuickCheckdep +basedep +freesetup-changed
Dependencies added: QuickCheck, base, free, haddock, hspec, machinecell, mtl, profunctors
Files
- LICENSE +30/−0
- README.md +13/−0
- Setup.hs +2/−0
- machinecell.cabal +42/−0
- src/Control/Arrow/Machine.hs +30/−0
- src/Control/Arrow/Machine/ArrowUtil.hs +34/−0
- src/Control/Arrow/Machine/Event.hs +208/−0
- src/Control/Arrow/Machine/Plan.hs +158/−0
- src/Control/Arrow/Machine/Running.hs +138/−0
- src/Control/Arrow/Machine/Types.hs +179/−0
- src/Control/Arrow/Machine/Utils.hs +464/−0
- test/RandomProc.hs +221/−0
- test/spec.hs +443/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, as_capabl++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of as_capabl nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,13 @@+machinecell+===========++Arrow based stream transducer.++Description+---------------+Coroutine-style stream processing library with support of arrow combinatins.+AFRP-like utilities are also available.++Usage+---------------+See example of test/Main.hs
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ machinecell.cabal view
@@ -0,0 +1,42 @@+-- Initial machinecell.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: machinecell+version: 1.0.0+synopsis: Arrow based stream transducers+description: Stream processing library similar to pipe, 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>+copyright: Copyright (c) 2014 Hidenori Azuma+category: Control+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++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-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 && <= 4.7.1, profunctors >=4.0+ hs-source-dirs: src+ default-language: Haskell2010++Test-suite spec+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: spec.hs+ other-modules: RandomProc+ Build-depends: base >=4.0, mtl >=2.0, profunctors >=4.0, QuickCheck >=2.0, hspec >=1.0, machinecell++source-repository head+ type: git+ location: https://github.com/as-capabl/machinecell.git+ branch: master++source-repository this+ type: git+ location: https://github.com/as-capabl/machinecell.git+ tag: release-1.0.0-1
+ src/Control/Arrow/Machine.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Arrows #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} +module + Control.Arrow.Machine + ( + -- * Modules + module Control.Arrow.Machine.Event, + module Control.Arrow.Machine.Utils, + module Control.Arrow.Machine.Plan, + 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.Running +import Control.Arrow.Machine.ArrowUtil + + +import Control.Arrow.Machine.Types
+ src/Control/Arrow/Machine/ArrowUtil.hs view
@@ -0,0 +1,34 @@++module+ Control.Arrow.Machine.ArrowUtil (+ kleisli,+ kleisli0,+ kleisli2,+ kleisli3,+ kleisli4,+ kleisli5+ )+where++import Control.Arrow+++kleisli :: Monad m => (a->m b) -> Kleisli m a b+kleisli = Kleisli++kleisli0 :: Monad m => m b -> Kleisli m () b+kleisli0 = Kleisli . const++kleisli2 :: Monad m => (a1 -> a2 -> m b) -> Kleisli m (a1, a2) b+kleisli2 fmx = Kleisli $ \(x1, x2) -> fmx x1 x2++kleisli3 :: Monad m => (a1 -> a2 -> a3 -> m b) -> Kleisli m (a1, a2, a3) b+kleisli3 fmx = Kleisli $ \(x1, x2, x3) -> fmx x1 x2 x3++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++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++
+ src/Control/Arrow/Machine/Event.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}+module+ Control.Arrow.Machine.Event + (+ Occasional (..),+ Event (..), + hEv, + hEv', + evMaybe,+ fromEvent,+ evMap,+ split,+ join,+ split2,+ join2+ )+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)+++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+++data Event a = Event a | NoEvent | End deriving (Eq, Show)++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+++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+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/Plan.hs view
@@ -0,0 +1,158 @@+{-# 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 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+++stopped :: + (ArrowApply a, Occasional c) => ProcessA a b c+stopped = arr (const end)++++data PlanF i o a where+ AwaitPF :: (i->a) -> PlanF i o a+ YieldPF :: o -> a -> PlanF i o a+ StopPF :: a -> PlanF i o a++instance (Functor (PlanF i o)) where+ fmap g (AwaitPF f) = AwaitPF (g . f)+ fmap g (YieldPF x r) = YieldPF x (g r)+ fmap g (StopPF r) = StopPF (g r)+++type PlanT i o m a = F.FreeT (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_ :: Monad m => (i->PlanT i o m a) -> PlanT i o m a+await_ f = F.FreeT $ return $ F.Free $ AwaitPF f++await :: Plan i o i+await = await_ return++stop :: Plan i o ()+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 $ proc (ph, evx) ->+ do+ ff <- fit (F.runFreeT pl) -< ()+ go ph ff -<< evx++ where+ go Feed (F.Free (AwaitPF f)) = proc evx ->+ do+ (| hEv'+ (\x -> + do+ ff2 <- fit (F.runFreeT (f x)) -<< ()+ oneYieldPF fit Feed ff2 -<< ())+ (returnA -< (Feed, NoEvent, constructT fit (await_ f)))+ (returnA -< (Feed, End, stopped))+ |) evx++ go ph pfr = proc evx -> + 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 cont)) = 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 -> + 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 kleisli pl+ where+ kleisli (ArrowMonad a) = a+{-+ unKleisli (Kleisli f) = proc x -> + case f x of {ArrowMonad af -> af} -<< ()+-} ++repeatedly :: ArrowApply a =>+ Plan i o t -> + ProcessA a (Event i) (Event o)+repeatedly pl = construct $ forever pl
+ src/Control/Arrow/Machine/Running.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}++module+ Control.Arrow.Machine.Running+ (+ -- * Run at once.+ run,+ -- * Run step-by-step.+ ExecInfo(..),+ stepRun,+ stepYield+ )+where++import Control.Arrow+import Control.Applicative (Alternative (..))+import Data.Monoid (Monoid (..))++import Control.Arrow.Machine.Types+import Control.Arrow.Machine.Event+++adv Feed = Sweep+adv Suspend = Feed+++handle f1 f2 f3 = proc (e, (ph, ev)) ->+ handleImpl ph ev -<< e+ where+ handleImpl Feed (Event x) = proc e -> f1 -< (e, x)+ handleImpl Suspend _ = f3+ handleImpl _ End = f3+ handleImpl _ _ = f2+++run :: ArrowApply a => ProcessA a (Event b) (Event c) -> a [b] [c]+run pa = proc xs -> + do+ ys <- go Sweep pa xs id -<< ()+ returnA -< ys []+ where+ go Sweep pa [] ys = proc _ ->+ do+ (ph', y, pa') <- step pa -< (Sweep, End)+ react y ph' pa' [] ys -<< ()++ go Feed pa [] ys = arr $ const ys++ 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 =+ do+ go (adv ph) pa [] ys++ 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+++-- | 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)++stepRun :: + ArrowApply a =>+ ProcessA a (Event b) (Event c) ->+ a b (ExecInfo [c], ProcessA a (Event b) (Event c))++++stepRun pa = proc 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'')++ where+ 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)++ +stepYield :: + ArrowApply a =>+ ProcessA a (Event b) (Event c) ->+ a b (ExecInfo (Maybe c), ProcessA a (Event b) (Event c))++stepYield pa = proc x ->+ do+ (my, pa', hsS) <- go pa -<< (Sweep, NoEvent)+ (| handle2 + (returnA -< (ExecInfo { yields = my, hasConsumed = False, hasStopped = hsS}, pa'))+ (do+ (my2, pa'', hsS) <- go pa' -<< (Feed, (Event x))+ returnA -< (ExecInfo { yields = my2, hasConsumed = True, hasStopped = hsS}, pa''))+ |)+ my++ where+ go pa = step pa >>> proc (ph', evy, pa') ->+ do+ (| handle+ (\y -> returnA -<< (Just y, pa', False))+ (go pa' -<< (adv ph', NoEvent))+ (returnA -< (Nothing, pa', case evy of {End->True; _->False}))+ |)+ (ph', evy)+++ handle2 f1 f2 = proc (e, mx) ->+ maybe f2 (const f1) mx -<< e+
+ src/Control/Arrow/Machine/Types.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+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+++-- | 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.+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 #-}++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, _) <- f -< (Suspend, x)+ (ph2, r2, pb') <- g -<< (Sweep, r1)+ cont ph2 x -<< (ph2, r2, ProcessA f >>> pb')+ where+ cont Feed x = returnA+ cont Sweep x = returnA+ cont Suspend x = proc _ ->+ do+ (ph1, r1, pa') <- f -< (Sweep, x)+ (ph2, r2, pb') <- g -< (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')++
+ src/Control/Arrow/Machine/Utils.hs view
@@ -0,0 +1,464 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}+module+ Control.Arrow.Machine.Utils+ (+ -- * AFRP-like utilities+ delay,+ hold,+ accum,+ edge,+ passRecent,+ withRecent,++ -- * 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,++ -- * Other utility arrows+ tee,+ gather,+ -- sampleR,+ -- sampleL,+ source,+ fork,+ filter,+ echo,+ anytime,+ par,+ parB,+ )+where++import Prelude hiding (filter)++import Data.Monoid (mappend, mconcat)+import Data.Tuple (swap)+import qualified Data.Foldable as Fd+import qualified Data.Traversable as Tv+import qualified Control.Category as Cat+import Control.Monad (liftM, forever)+import Control.Monad.Trans+import Control.Arrow+import Control.Applicative+import Debug.Trace++import Control.Arrow.Machine.Types+import Control.Arrow.Machine.Event++import qualified Control.Arrow.Machine.Plan as Pl++++++delay :: + (ArrowApply a, Occasional b) => ProcessA a b b+delay = join >>> delayImpl >>> split+ where+ delayImpl = Pl.repeatedly $+ do+ x <- Pl.await+ Pl.yield noEvent+ Pl.yield x++hold :: + ArrowApply a => b -> ProcessA a (Event b) b+{-+hold old = ProcessA $ proc (ph, evx) ->+ do+ let new = fromEvent old evx+ returnA -< (ph `mappend` Suspend, new, hold new)+-}+hold old = proc evx -> + do+ rSwitch (arr $ const old) -< ((), arr . const <$> evx)++accum ::+ ArrowApply a => b -> ProcessA a (Event (b->b)) b+accum old = proc evf ->+ do+ rSwitch (arr $ const old) -< ((), arr . const <$> (evf <*> pure old))++edge :: + (ArrowApply a, Eq b) =>+ ProcessA a b (Event b)++edge = ProcessA $ impl Nothing + where+ impl mvx = proc (ph, 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)+++infixr 9 `passRecent`++passRecent :: + (ArrowApply a, Occasional o) =>+ ProcessA a e (Event b) ->+ ProcessA a (e, b) o ->+ ProcessA a e o++passRecent af ag = proc e ->+ do+ evx <- af -< e+ mvx <- hold Nothing -< Just <$> evx+ case mvx of+ Just x -> ag -< (e, x)+ _ -> returnA -< noEvent++withRecent :: + (ArrowApply a, Occasional o) =>+ ProcessA a (e, b) o ->+ ProcessA a (e, Event b) o+withRecent af = proc (e, evb) ->+ (returnA -< evb) `passRecent` (\b -> af -< (e, b))+++--+-- Switches+--+hEvPh :: ArrowApply a => a (e,b) c -> a e c -> a (e, (Phase, Event b)) c+hEvPh f1 f2 = proc (e, (ph, ev)) ->+ helper ph ev -<< e+ where+ helper Feed (Event x) = proc e -> f1 -< (e, x)+ helper _ _ = f2+++hEvPh' :: ArrowApply a => a (e,b) c -> a e c -> a e c -> a (e, (Phase, Event b)) c+hEvPh' f1 f2 f3 = proc (e, (ph, ev)) ->+ helper ph ev -<< e+ where+ helper Feed (Event x) = proc e -> f1 -< (e, x)+ helper Feed End = f3+ helper _ _ = f2++switch :: + ArrowApply a => + ProcessA a b (c, Event t) -> + (t -> ProcessA a b c) ->+ ProcessA a b c++switch cur cont = ProcessA $ proc (ph, x) ->+ do+ (ph', (y, evt), new) <- step cur -< (ph, x)+ (| hEvPh+ (\t -> step (cont t) -<< (ph, x))+ (returnA -< (ph', y, switch new cont))+ |) + (ph', evt)+++dSwitch :: + ArrowApply a => + ProcessA a b (c, Event t) -> + (t -> ProcessA a b c) ->+ ProcessA a b c++dSwitch cur cont = ProcessA $ proc (ph, x) ->+ do+ (ph', (y, evt), new) <- step cur -< (ph, x)+ + returnA -< (ph', y, next new evt)+ where+ next _ (Event t) = cont t+ next new _ = dSwitch new cont+++rSwitch :: + ArrowApply a => ProcessA a b c -> + ProcessA a (b, Event (ProcessA a b c)) c++rSwitch cur = ProcessA $ proc (ph, (x, eva)) -> + do+ (ph', y, new) <- + (| hEvPh+ (\af -> step af -<< (ph, x))+ (step cur -< (ph, x))+ |)+ (ph, eva)+ 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))+ (| hEvPh+ (\t -> step $ k sf' t -<< (phT, x))+ (returnA -< (phT, y, kSwitch sf' test' k))+ |) + (phT, evt)+++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))++ (| hEvPh+ (\t -> step $ k sfs' t -<< (ph, x))+ (returnA -< (ph' `mappend` phT, zs, pSwitch r sfs' test' k))+ |) + (phT, evt)+++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+ (ph', zs, sfs') <- parCore r sfs -<< (ph, x)++ (| hEvPh+ (\cont -> + do+ (ph'', ws, sfs'') <- parCore r (cont sfs') -<< (ph, x)+ returnA -< (ph'' `mappend` Suspend, ws, rpSwitch r sfs'')+ )+ (returnA -< (ph' `mappend` Suspend, zs, rpSwitch r sfs'))+ |) + (ph', evCont)+++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+++--+-- other utility arrow+--+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++{-+-- Problem with the last output.+sampleR ::+ ArrowApply a =>+ ProcessA a (Event b1, Event b2) (Event (b1, [b2]))+sampleR = join >>> Pl.construct (go id)+ where+ go l = + do+ (evx, evy) <- Pl.await+ let l2 = evMaybe l (\y -> l . (y:)) evy+ evMaybe (go l2) (\x -> Pl.yield (x, l2 []) >> go id) evx++sampleL ::+ ArrowApply a =>+ ProcessA a (Event b1, Event b2) (Event ([b1], b2))+sampleL = arr swap >>> sampleR >>> evMap swap+-}++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))++-- |It's also possible that source is defined without any await.+-- +-- But awaits are useful to synchronize other inputs.+source ::+ ArrowApply a =>+ [c] -> ProcessA a (Event b) (Event c)+source l = Pl.construct $ mapM_ yd l+ where+ yd x = Pl.await >> Pl.yield x++fork :: + (ArrowApply a, Fd.Foldable f) =>+ ProcessA a (Event (f b)) (Event b)++fork = Pl.repeatedly $ + Pl.await >>= Fd.mapM_ Pl.yield+++anytime :: + ArrowApply a =>+ a b c ->+ ProcessA a (Event b) (Event c)++anytime action = Pl.repeatedlyT arrow $+ do+ x <- Pl.await+ ret <- lift $ (ArrowMonad $ arr (const x) >>> action)+ 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 $+ do+ x <- Pl.await+ b <- lift $ (ArrowMonad $ arr (const x) >>> cond)+ if b then Pl.yield x else return ()+ where+ arrow (ArrowMonad af) = af+++echo :: + ArrowApply a =>+ ProcessA a (Event b) (Event b)++echo = filter (arr (const True))++
+ test/RandomProc.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Arrows #-}++module+ RandomProc+where++import Prelude+import Control.Arrow.Machine as P+import Control.Arrow+import qualified Control.Category as Cat+import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Control.Monad.State+import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized)+import Data.Maybe (fromJust)+++data ProcJoin = PjFst ProcGen | PjSnd ProcGen | PjSum ProcGen+ deriving Show++data ProcGen = PgNop | + PgStop |+ PgPush ProcGen |+ PgPop (ProcGen, ProcGen) ProcJoin |+ PgOdd ProcGen |+ PgDouble ProcGen |+ PgIncl ProcGen |+ PgHarf ProcGen+ deriving Show++instance+ Arbitrary ProcJoin+ where+ arbitrary = oneof [liftM PjFst arbitrary,+ liftM PjSnd arbitrary,+ liftM PjSum arbitrary]++instance + Arbitrary ProcGen+ where+ arbitrary = sized $ \i ->+ frequency [(40, rest), (40 + i, content)]+ where+ rest = return PgNop+ content = oneof [+ return PgNop, + return PgStop, + liftM PgPush arbitrary,+ liftM2 PgPop arbitrary arbitrary,+ liftM PgOdd arbitrary,+ liftM PgDouble arbitrary,+ liftM PgIncl arbitrary,+ liftM PgHarf arbitrary+ ]+type MyProcT = ProcessA (Kleisli (State [Int]))++mkProc :: ProcGen + -> MyProcT (Event Int) (Event Int)+++mkProc PgNop = Cat.id++mkProc (PgPush next) = mc >>> mkProc next+ where+ mc = repeatedlyT kleisli0 $+ do+ x <- await+ lift $ modify (\xs -> x:xs)+ yield x++mkProc (PgPop (fx, fy) fz) =+ mc >>> P.split >>> (mkProc fx *** mkProc fy) >>> mkProcJ fz+ where+ mc = repeatedlyT kleisli0 $+ do+ x <- await+ ys <- lift $ get+ case ys + of+ [] -> + yield (Event x, NoEvent)+ (y:yss) -> + do + lift $ put yss+ yield (Event x, Event y)++mkProc (PgOdd next) = P.filter (arr cond) >>> mkProc next+ where+ cond x = x `mod` 2 == 1++mkProc (PgDouble next) = arr (fmap $ \x -> [x, x]) >>> fork >>> mkProc next++mkProc (PgIncl next) = arr (fmap (+1)) >>> mkProc next++mkProc (PgHarf next) = arr (fmap (`div`2)) >>> mkProc next++mkProc (PgStop) = stopped++mkProcJ :: ProcJoin -> MyProcT (Event Int, Event Int) (Event Int)++mkProcJ (PjFst pg) = arr fst+mkProcJ (PjSnd pg) = arr snd+mkProcJ (PjSum pg) = arr go+ where+ go (evx, evy) = (+) <$> evx <*> evy+++stateProc :: MyProcT (Event a) (Event b) -> [a] -> ([b], [Int])+stateProc a i = + runState mx []+{-+ unsafePerformIO $ + do+ x <- timeout 10000 $+ do+ let x = runState mx []+ deepseq x $ return x+ return (fromJust x)+-}+ where+ mx = runKleisli (run a) i++class + TestIn a+ where+ input :: MyProcT (Event Int) a++class+ TestOut a+ where+ output :: MyProcT a (Event Int)++instance+ TestIn (Event Int)+ where+ input = Cat.id++instance+ TestOut (Event Int)+ where+ output = Cat.id++instance+ (TestIn a, TestIn b) => TestIn (a, b)+ where+ input = mc >>> P.split >>> input *** input+ where+ mc = repeatedly $+ do+ x <- await+ y <- await+ yield (Event x, Event y)++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++instance+ (TestIn a, TestIn b) => + TestIn (Either a b)+ where+ input = proc evx ->+ do+ -- 一個前の値で分岐してみる+ b <- hold True <<< delay -< + (\x -> x `mod` 2 == 0) <$> evx++ if b+ then+ arr Left <<< input -< evx+ else+ arr Right <<< input -< evx+++instance+ (TestOut a, TestOut b) => TestOut (Either a b)+ where+ output = output ||| output++type MyTestT a b = MyProcT a b -> MyProcT a b -> Bool++mkEquivTest :: (TestIn a, TestOut b) =>+ (Maybe (ProcGen, ProcJoin), ProcGen, ProcGen, [Int]) ->+ MyTestT a b+mkEquivTest (Nothing, pre, post, l) pa pb =+ let+ preA = mkProc pre+ postA = mkProc post+ mkCompared p = preA >>> input >>> p >>> output >>> postA+ x = stateProc (mkCompared pa) l+ y = stateProc (mkCompared pb) l+ in+ x == y++mkEquivTest (Just (par, j), pre, post, l) pa pb =+ let+ preA = mkProc pre+ postA = mkProc post+ parA = mkProc par+ joinA = mkProcJ j+ mkCompared p = preA >>> input >>> p >>> output >>> postA+ x = stateProc (mkCompared pa) l+ y = stateProc (mkCompared pb) l+ in+ x == y++mkEquivTest2 ::(Maybe (ProcGen, ProcJoin), ProcGen, ProcGen, [Int]) ->+ MyProcT (Event Int, Event Int) (Event Int, Event Int) -> + MyProcT (Event Int, Event Int) (Event Int, Event Int) ->+ Bool+mkEquivTest2 = mkEquivTest
+ test/spec.hs view
@@ -0,0 +1,443 @@+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Arrows #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +module + Main +where + +import Data.Maybe (fromMaybe) +import Control.Arrow.Machine as P +import Control.Applicative ((<$>), (<*>), (<$)) +import qualified Control.Category as Cat +import Control.Arrow +import Control.Monad.State +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Identity (Identity, runIdentity) +import Debug.Trace +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Arbitrary, arbitrary, oneof, frequency, sized) +import RandomProc + +runKI a x = runIdentity (runKleisli a x) + + + + +main = hspec $ do {basics; rules; loops; choice; plans; utility; switches; execution} + + +basics = + do + describe "ProcessA" $ + do + it "is stream transducer." $ + do + let + process = repeatedly $ + do + x <- await + yield x + yield (x + 1) + + resultA = run process [1,2,4] + + resultA `shouldBe` [1, 2, 2, 3, 4, 5] + + let + -- 入力1度につき同じ値を2回出力する + doubler = repeatedly $ + do {x <- await; yield x; yield x} + -- 入力値をStateのリストの先頭にPushする副作用を行い、同じ値を出力する + pusher = repeatedlyT (Kleisli . const) $ + do {x <- await; lift $ modify (x:); yield x} + + it "has stop state" $ + let + -- 一度だけ入力をそのまま出力し、すぐに停止する + onlyOnce = construct $ await >>= yield + + x = stateProc (doubler >>> pusher >>> onlyOnce) [3, 3] + in + -- 最後尾のMachineが停止した時点で処理を停止するが、 + -- 既にa2が出力した値の副作用は処理する + x `shouldBe` ([3], [3, 3]) + + it "has side-effect" $ + let + incl = arr $ fmap (+1) + + -- doublerで信号が2つに分岐する。 + -- このとき、副作用は1つ目の信号について末尾まで + -- -> 二つ目の信号について分岐点から末尾まで ... + -- の順で処理される。 + a = pusher >>> doubler >>> incl >>> pusher >>> incl >>> pusher + + x = stateProc a [1000] + in + x `shouldBe` ([1002, 1002], reverse [1000,1001,1002,1001,1002]) + + it "never spoils any FEED" $ + let + counter = construct $ counterDo 1 + counterDo n = + do + x <- await + yield $ n * 100 + x + counterDo (n+1) + x = stateProc (doubler >>> doubler >>> counter) [1,2] + in + fst x `shouldBe` [101, 201, 301, 401, 502, 602, 702, 802] + + prop "each path can have independent number of events" $ \l -> + let + split2' (Event (x, y)) = (Event x, Event y) + split2' NoEvent = (NoEvent, NoEvent) + split2' End = (End, End) + gen = arr (fmap $ \x -> [x, x]) >>> fork >>> arr split2' + r1 = runKI (run (gen >>> arr fst)) (l::[(Int, [Int])]) + r2 = runKI (run (gen >>> second (fork >>> echo) >>> arr fst)) + (l::[(Int, [Int])]) + in + r1 == r2 + + +rules = + do + describe "ProcessA as Category" $ + do + prop "has asocciative composition" $ \fx gx hx cond -> + let + f = mkProc fx + g = mkProc gx + h = mkProc hx + equiv = mkEquivTest cond + in + ((f >>> g) >>> h) `equiv` (f >>> (g >>> h)) + + prop "has identity" $ \fx gx cond -> + let + f = mkProc fx + g = mkProc gx + equiv = mkEquivTest cond + in + (f >>> g) `equiv` (f >>> Cat.id >>> g) + + describe "ProcessA as Arrow" $ + do + it "can be made from pure function(arr)" $ + do + (run . arr . fmap $ (+ 2)) [1, 2, 3] + `shouldBe` [3, 4, 5] + + prop "arr id is identity" $ \fx gx cond -> + let + f = mkProc fx + g = mkProc gx + equiv = mkEquivTest cond + in + (f >>> g) `equiv` (f >>> arr id >>> g) + + it "can be parallelized" $ + let + in + do + let + myProc2 = repeatedlyT (Kleisli . const) $ + do + x <- await + lift $ modify (++ [x]) + yield `mapM` (take x $ repeat x) + + toN (Event x) = Just x + toN NoEvent = Nothing + toN End = Nothing + en (ex, ey) = Event (toN ex, toN ey) + de evxy = (fst <$> evxy, snd <$> evxy) + + l = map (\x->(x,x)) [1,2,3] + + (result, state) = + stateProc (arr de >>> first myProc2 >>> arr en) l + + (result >>= maybe mzero return . fst) + `shouldBe` [1,2,2,3,3,3] + (result >>= maybe mzero return . snd) + `shouldBe` [1,2,3] + state `shouldBe` [1,2,3] + + prop "first and composition." $ \fx gx cond -> + let + f = mkProc fx + g = mkProc gx + equiv = mkEquivTest2 cond + in + (first (f >>> g)) `equiv` (first f >>> first g) + + prop "first-second commutes" $ \fx cond -> + let + f = first $ mkProc fx + g = second (arr $ fmap (+2)) + + equiv = mkEquivTest2 cond + in + (f >>> g) `equiv` (g >>> f) + + prop "first-fst commutes" $ \fx cond -> + let + f = mkProc fx + equiv = mkEquivTest cond + ::(MyTestT (Event Int, Event Int) (Event Int)) + in + (first f >>> arr fst) `equiv` (arr fst >>> f) + + prop "assoc relation" $ \fx cond -> + let + f = mkProc fx + assoc ((a,b),c) = (a,(b,c)) + + equiv = mkEquivTest cond + ::(MyTestT ((Event Int, Event Int), Event Int) + (Event Int, (Event Int, Event Int))) + in + (first (first f) >>> arr assoc) `equiv` (arr assoc >>> first f) + +loops = + do + describe "ProcessA as ArrowLoop" $ + do + it "can be used with rec statement(pure)" $ + let + a = proc x -> + do + rec l <- returnA -< evMaybe [] (:l) x + returnA -< l <$ x + 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 + a = proc x -> + do + rec l <- mc -< (:l') <$> x + l' <- returnA -< fromEvent [] l + returnA -< l + result = fst $ stateProc a [2, 5] + in + take 3 (result!!1) `shouldBe` [5, 5, 5] + + it "the last value is valid." $ + do + let + mc = repeatedly $ + do + x <- await + yield x + yield (x*2) + pa = proc x -> + do + rec y <- mc -< (+z) <$> x + z <- hold 0 <<< delay -< y + returnA -< y + run pa [1, 10] `shouldBe` [1, 2, 12, 24] + + describe "Rules for ArrowLoop" $ + do + let + fixcore f y = if y `mod` 5 == 0 then y else y + f (y-1) + pure (evx, f) = (f <$> evx, fixcore f) + apure = arr pure + + prop "left tightening" $ \fx cond -> + let + f = mkProc fx + + equiv = mkEquivTest cond + in + (loop (first f >>> apure)) `equiv` (f >>> loop apure) + + it "right tigntening" + pending +{- + prop "right tightening" $ \fx cond -> + let + f = mkProc fx + + equiv = mkEquivTest cond + in + (loop (apure >>> first f)) `equiv` (loop apure >>> f) +-} + +choice = + do + describe "ProcessA as ArrowChoice" $ + do + it "temp1" $ + do + let + af = mkProc $ PgStop + ag = mkProc $ PgOdd PgNop + aj1 = arr Right + aj2 = arr $ either id id + l = [1] + r1 = stateProc + (aj1 >>> left af >>> aj2) + l + in + r1 `shouldBe` ([1],[]) + + prop "left (f >>> g) = left f >>> left g" $ \fx gx cond -> + let + f = mkProc fx + g = mkProc gx + + equiv = mkEquivTest cond + ::(MyTestT (Either (Event Int) (Event Int)) + (Either (Event Int) (Event Int))) + in + (left (f >>> g)) `equiv` (left f >>> left g) + + +plans = describe "Plan" $ + do + let pl = + do + x <- await + yield x + yield (x+1) + x <- await + yield x + yield (x+1) + l = [2, 5, 10, 20, 100] + + it "can be constructed into ProcessA" $ + do + let + result = run (construct pl) l + result `shouldBe` [2, 3, 5, 6] + + it "can be repeatedly constructed into ProcessA" $ + do + let + result = run (repeatedly pl) l + result `shouldBe` [2, 3, 5, 6, 10, 11, 20, 21, 100, 101] + + +utility = + do + describe "delay" $ + do + it "delays input" $ + 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] + + +switches = + do + describe "switch" $ + do + it "switches once" $ + do + let + before = proc evx -> + do + ch <- P.filter (arr $ (\x -> x `mod` 2 == 0)) -< evx + returnA -< (NoEvent, ch) + + after t = proc evx -> returnA -< (t*) <$> evx + + l = [1,3,4,1,3,2] + + -- 最初に偶数が与えられるまでは、入力を無視(NoEvent)し、 + -- それ以降は最初に与えられた偶数 * 入力値を返す + ret = run (switch before after) l + + -- dが付くと次回からの切り替えとなる + retD = run (dSwitch before after) l + + ret `shouldBe` [16, 4, 12, 8] + retD `shouldBe` [4, 12, 8] + + describe "rSwitch" $ + do + it "switches any times" $ + do + let + theArrow sw = proc evtp -> + do + (evx, evarr) <- P.split -< evtp + sw (arr $ fmap (+2)) -< (evx, evarr) + + l = [(Event 5, NoEvent), + (Event 1, Event (arr $ fmap (*2))), + (Event 2, NoEvent)] + ret = run (theArrow rSwitch) l + retD = run (theArrow drSwitch) l + + ret `shouldBe` [7, 2, 4] + retD `shouldBe` [7, 3, 4] + +execution = describe "Execution of ProcessA" $ + do + let + pl = + do + x <- await + yield x + yield (x+1) + x <- await + yield x + yield (x+1) + yield (x+5) + init = construct pl + + it "supports step execution" $ + do + let + (ret, now) = stepRun init 1 + yields ret `shouldBe` [1, 2] + hasStopped ret `shouldBe` False + + let + (ret, now2) = stepRun now 1 + yields ret `shouldBe` [1, 2, 6] + hasStopped ret `shouldBe` True + + let + (ret, _) = stepRun now2 1 + yields ret `shouldBe` ([]::[Int]) + hasStopped ret `shouldBe` True + + it "supports yield-driven step" $ + do + let + init = construct $ + do + yield (-1) + x <- await + mapM yield (iterate (+1) x) -- infinite + + (ret, now) = stepYield init 5 + yields ret `shouldBe` Just (-1) + hasConsumed ret `shouldBe` False + hasStopped ret `shouldBe` False + + let + (ret, now2) = stepYield now 10 + yields ret `shouldBe` Just 10 + hasConsumed ret `shouldBe` True + hasStopped ret `shouldBe` False + + let + (ret, now3) = stepYield now2 10 + yields ret `shouldBe` Just 11 + hasConsumed ret `shouldBe` False + hasStopped ret `shouldBe` False +