machinecell 3.1.0 → 3.2.0
raw patch · 6 files changed
+358/−155 lines, 6 files
Files
- CHANGELOG.md +5/−0
- machinecell.cabal +12/−3
- src/Control/Arrow/Machine/ArrowUtil.hs +18/−6
- src/Control/Arrow/Machine/Misc/Discrete.hs +21/−8
- src/Control/Arrow/Machine/Types.hs +295/−135
- src/Control/Arrow/Machine/Utils.hs +7/−3
CHANGELOG.md view
@@ -1,4 +1,9 @@ +3.2.0+----------+* Add arrow-tr flag+* add `gSwitch`, `dgSwitch`+ 3.1.0 ----------- * Add `Discrete` utilities
machinecell.cabal view
@@ -1,5 +1,5 @@ name: machinecell-version: 3.1.0+version: 3.2.0 synopsis: Arrow based stream transducers license: BSD3 license-file: LICENSE@@ -22,6 +22,12 @@ . A quick introduction is available in the Control.Arrow.Machine documentation. +flag arrow-tr+ description:+ Arrow transformer support.+ default: True+ manual: True+ library exposed-modules: Control.Arrow.Machine,@@ -33,10 +39,13 @@ Control.Arrow.Machine.Misc.Discrete other-extensions: FlexibleInstances, Arrows, RankNTypes, TypeSynonymInstances, MultiParamTypeClasses, GADTs, FlexibleContexts, NoMonomorphismRestriction, RecursiveDo ghc-options: -Wall- build-depends: base >=4.0 && <5.0, mtl >=2.0.1.1, free >=4.12 && < 5.0, profunctors >=4.0, arrows >=0.4.1.2, semigroups >=0.8.3.1+ build-depends: base >=4.0 && <5.0, mtl >=2.0.1.1, free >=4.12 && < 5.0, semigroups >=0.8.3.1, profunctors >=4.0 hs-source-dirs: src default-language: Haskell2010 + if flag(arrow-tr)+ build-depends: arrows >= 0.4.1.2+ Test-suite spec type: exitcode-stdio-1.0 default-language: Haskell2010@@ -53,4 +62,4 @@ source-repository this type: git location: https://github.com/as-capabl/machinecell.git- tag: release-3.1.0+ tag: release-3.2.0
src/Control/Arrow/Machine/ArrowUtil.hs view
@@ -18,7 +18,7 @@ ary3, ary4, ary5,- + kleisli, kleisli0, kleisli2,@@ -28,9 +28,11 @@ unArrowMonad, arrowMonad,- ++#if defined(MIN_VERSION_arrows) reading, statefully,+#endif -- * Arrow construction helper (Lens) -- |Lens Isomorphisms between arrows and monads.@@ -38,7 +40,9 @@ -- Use with lens operator (^.) and (#). kl, am,+#if defined(MIN_VERSION_arrows) rd,+#endif uc0, uc1, uc2,@@ -52,18 +56,22 @@ toAS, fromAS, +#if defined(MIN_VERSION_arrows) elimR+#endif ) where import Prelude hiding ((.), id) import Control.Category import Control.Arrow+#if defined(MIN_VERSION_arrows) import Control.Arrow.Operations (store, fetch) import Control.Arrow.Transformer.Reader import Control.Arrow.Transformer.State import Control.Monad.Reader (ReaderT(..), runReaderT) import Control.Monad.State (StateT, runStateT)+#endif import Data.Profunctor @@ -125,7 +133,7 @@ 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 = ary1 Kleisli @@ -155,7 +163,8 @@ a p q -> p -> ArrowMonad a q arrowMonad af x = ArrowMonad $ arr (const x) >>> af - ++#if defined(MIN_VERSION_arrows) reading :: (Monad m, Arrow a) => (forall p q. (p->m q)->a p q) -> @@ -174,7 +183,7 @@ (y, s') <- liftState (f $ \(x, s) -> runStateT (ms x) s) -< (x, s) store -< s' returnA -< y- +#endif type MyIso s t a b = forall p f. (Profunctor p, Functor f) =>@@ -197,6 +206,7 @@ MyIso' (b -> ArrowMonad a c) (a b c) am = myIso unArrowMonad arrowMonad +#if defined(MIN_VERSION_arrows) rd :: (Arrow a) => (forall p q. MyIso' (p -> m q) (a p q)) ->@@ -207,6 +217,7 @@ (\frmy -> uncurry (runReaderT . frmy)) (\fmy -> ReaderT . (curry fmy)) g = myIso ReaderArrow runReader+#endif uc0 :: MyIso' (m b) (() -> m b) uc0 = myIso const ($())@@ -234,11 +245,12 @@ (\f (a1, a2, a3, a4, a5) -> f a1 a2 a3 a4 a5) (\f a1 a2 a3 a4 a5 -> f (a1, a2, a3, a4, a5)) +#if defined(MIN_VERSION_arrows) -- |Alternate for `elimReader` that can be used with both ghc 7.8 and older. elimR :: ArrowAddReader r a a' => a (AS e) b -> a' (e, AS r) b elimR f = second (arr $ fromAS) >>> elimReader (arr toAS >>> f)-+#endif
src/Control/Arrow/Machine/Misc/Discrete.hs view
@@ -23,6 +23,7 @@ arr5, constant,+ unsafeConstant, hold, accum, fromEq,@@ -77,15 +78,18 @@ P.ProcessA a (P.Event (), b) (T b) makeT = Arr.arr $ uncurry T --- TODO this should be implemented by switch-rising ::++stimulate :: ArrowApply a => P.ProcessA a b (T c) -> P.ProcessA a b (T c)-rising sf = proc x ->- do- (dy, n) <- sf &&& P.now -< x- makeT -< (updates dy `mappend` n, value dy)+stimulate sf = P.dgSwitch (id &&& id) sf body $ \sf' _ -> sf'+ where+ body = proc (dy, _) ->+ do+ n <- P.now -< ()+ disc <- makeT -< (updates dy `mappend` n, value dy)+ returnA -< (disc, updates disc) arr :: ArrowApply a =>@@ -134,6 +138,15 @@ constant x = (P.now &&& Arr.arr (const x)) >>> makeT +-- |Constant without initial notifications.+-- Users must manage initialization manually.+unsafeConstant::+ ArrowApply a =>+ c ->+ P.ProcessA a b (T c)+unsafeConstant x =+ (pure P.noEvent &&& Arr.arr (const x)) >>> makeT+ onUpdate :: ArrowApply a => P.ProcessA a (P.Event b) (P.Event ())@@ -182,7 +195,7 @@ P.ProcessA a (b, T c) (P.Event t) -> (P.ProcessA a b (T c) -> t -> P.ProcessA a b (T c)) -> P.ProcessA a b (T c)-kSwitch sf test k = P.kSwitch sf test (\sf' x -> rising (k sf' x))+kSwitch sf test k = P.kSwitch sf test (\sf' x -> stimulate (k sf' x)) dkSwitch :: ArrowApply a =>@@ -190,7 +203,7 @@ P.ProcessA a (b, T c) (P.Event t) -> (P.ProcessA a b (T c) -> t -> P.ProcessA a b (T c)) -> P.ProcessA a b (T c)-dkSwitch sf test k = P.dkSwitch sf test (\sf' x -> rising (k sf' x))+dkSwitch sf test k = P.dkSwitch sf test (\sf' x -> stimulate (k sf' x)) {-$alg
src/Control/Arrow/Machine/Types.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -13,6 +14,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-} module Control.Arrow.Machine.Types@@ -74,17 +76,23 @@ drSwitch, kSwitch, dkSwitch,+ gSwitch,+ dgSwitch, pSwitch, pSwitchB,+ dpSwitch,+ dpSwitchB, rpSwitch, rpSwitchB,+ drpSwitch,+ drpSwitchB, par, parB,- + -- * Primitive machines - other safe primitives fit, fitW,- + -- * Primitive machines - unsafe unsafeExhaust, )@@ -129,6 +137,12 @@ type ProcType a b c = ProcessA a b c +class Stepper a b c s | s -> a, s -> b, s -> c+ where+ feed :: s -> a b (c, s)+ sweep :: s -> a b (Maybe c, s)+ suspend :: s -> b -> c+ -- | The stream transducer arrow. -- -- To construct `ProcessA` instances, use `Control.Arrow.Machine.Plan.Plan`,@@ -137,56 +151,55 @@ -- -- See an introduction at "Control.Arrow.Machine" documentation. data ProcessA a b c = ProcessA {- feed :: a b (c, ProcessA a b c),- sweep :: a b (Maybe c, ProcessA a b c),- suspend :: !(b -> c)+ paFeed :: a b (c, ProcessA a b c),+ paSweep :: a b (Maybe c, ProcessA a b c),+ paSuspend :: !(b -> c) } +instance+ Stepper a b c (ProcessA a b c)+ where+ feed = paFeed+ sweep = paSweep+ suspend = paSuspend +toProcessA ::+ (ArrowApply a, Stepper a b c s) =>+ s -> ProcessA a b c+toProcessA s = ProcessA {+ paFeed = feed s >>> arr (second toProcessA),+ paSweep = sweep s >>> arr (second toProcessA),+ paSuspend = suspend s+ }+{-# INLINE[2] toProcessA #-}+ -- For internal use class (Applicative f, Monad f) => ProcessHelper f where- step :: ArrowApply a => ProcessA a b c -> a b (f c, ProcessA a b c)+ step ::+ (ArrowApply a, Stepper a b c s) =>+ s -> a b (f c, s) helperToMaybe :: f a -> Maybe a weakly :: a -> f a - step' :: ArrowApply a => ProcessA a b c -> a (f b) (f c, ProcessA a b c)- step' pa = proc hx ->- do- let mx = helperToMaybe hx- maybe- (arr $ const (suspend pa <$> hx, pa))- (\x -> proc _ -> step pa -< x)- mx- -<< ()+ compositeStep ::+ (ArrowApply a, Stepper a b p s1, Stepper a p c s2) =>+ s1 -> s2 ->+ a b (f c, s1, s2) - testStep' ::- ArrowApply a =>- (x -> a b (f c, x)) ->- (x -> b -> c) ->- x ->- ProcessA a (b, c) t ->- a b (f c, f t, x, ProcessA a (b, c) t) -testStep ::- (ArrowApply a, ProcessHelper f) =>- ProcessA a b c ->- ProcessA a (b, c) t ->- a b (f c, f t, ProcessA a b c, ProcessA a (b, c) t)-testStep = testStep' step suspend- instance ProcessHelper Identity where step pa = feed pa >>> first (arr Identity) helperToMaybe = Just . runIdentity weakly = Identity- testStep' stp' _ sf test = proc x ->+ compositeStep sf test = proc x -> do- (Identity y, sf') <- stp' sf -< x- (t, test') <- feed test -< (x, y)- returnA -< (return y, return t, sf', test')+ (y, sf') <- feed sf -< x+ (z, test') <- feed test -< y+ returnA -< (return z, sf', test') instance ProcessHelper Maybe@@ -194,26 +207,26 @@ step = sweep helperToMaybe = id weakly _ = Nothing- testStep' stp' sus' sf0 test0 = proc x ->+ compositeStep sf0 test0 = proc x -> do- let y = sus' sf0 x- (mt, test') <- sweep test0 -< (x, y)+ let y = suspend sf0 x+ (mt, test') <- sweep test0 -< y (case mt of- Just t -> arr $ const (Just y, Just t, sf0, test')+ Just t -> arr $ const (Just t, sf0, test') Nothing -> cont sf0 test') -<< x where cont sf test = proc x -> do- (my, sf') <- stp' sf -< x+ (my, sf') <- sweep sf -< x (case my of Just y -> cont2 y sf' test- Nothing -> arr $ const (Nothing, Nothing, sf', test))+ Nothing -> arr $ const (Nothing, sf', test)) -<< x- cont2 y sf test = proc x ->+ cont2 y sf test = proc _ -> do- (t, test') <- feed test -< (x, y)- returnA -< (Just y, Just t, sf, test')+ (t, test') <- feed test -< y+ returnA -< (Just t, sf, test') makePA :: Arrow a =>@@ -222,12 +235,79 @@ (b -> c) -> ProcessA a b c makePA h !sus = ProcessA {- feed = h >>> first (arr runIdentity),- sweep = h,- suspend = sus+ paFeed = h >>> first (arr runIdentity),+ paSweep = h,+ paSuspend = sus } +data CompositeStep a b c s1 s2+ where+ CompositeStep ::+ (Stepper a b p s1, Stepper a p c s2) =>+ s1 -> s2 ->+ CompositeStep a b c s1 s2++instance+ ArrowApply a => Stepper a b c (CompositeStep a b c s1 s2)+ where+ feed (CompositeStep s1 s2) =+ compositeStep s1 s2 >>>+ arr (\(fz, s1', s2') -> (runIdentity $ fz, CompositeStep s1' s2'))+ sweep (CompositeStep s1 s2) =+ compositeStep s1 s2 >>>+ arr (\(fz, s1', s2') -> (fz, CompositeStep s1' s2'))+ suspend (CompositeStep s1 s2) =+ suspend s2 . suspend s1+++data IDStep a b c+ where+ IDStep :: IDStep (a :: * -> * -> *) b b++instance+ ArrowApply a => Stepper a b c (IDStep a b c)+ where+ feed IDStep = Cat.id &&& arr (const IDStep)+ sweep IDStep = arr (const (Nothing, IDStep))+ suspend IDStep = id++newtype ArrStep (a :: * -> * -> *) b c = ArrStep (b -> c)++instance+ ArrowApply a => Stepper a b c (ArrStep a b c)+ where+ feed (ArrStep f) = arr $ \x -> (f x, ArrStep f)+ sweep (ArrStep f) = arr $ const (Nothing, ArrStep f)+ suspend (ArrStep f) = f+++data ParStep a b c s1 s2+ where+ ParStep ::+ (Stepper a b1 c1 s1, Stepper a b2 c2 s2) =>+ s1 -> s2 ->+ ParStep a (b1, b2) (c1, c2) s1 s2++instance+ ArrowApply a => Stepper a b c (ParStep a b c s1 s2)+ where+ feed (ParStep f g) = proc (x1, x2) ->+ do+ (y1, f') <- feed f -< x1+ (y2, g') <- feed g -< x2+ returnA -< ((y1, y2), ParStep f' g')+ sweep (ParStep f g) = proc (x1, x2) ->+ do+ (my1, f') <- sweep f -< x1+ (my2, g') <- sweep g -< x2+ let y1 = fromMaybe (suspend f' x1) my1 -- suspend f ?+ y2 = fromMaybe (suspend g' x2) my2+ r = if (isNothing my1 && isNothing my2) then Nothing else Just (y1, y2)+ returnA -< (r, ParStep f' g')+ suspend (ParStep f g) = suspend f *** suspend g++ -- |Natural transformation fit :: (ArrowApply a, ArrowApply a') =>@@ -283,6 +363,7 @@ where id = idProc {-# INLINE id #-}+ g . f = compositeProc f g {-# INLINE (.) #-} @@ -307,23 +388,8 @@ ProcType a b c -> ProcType a d e -> ProcType a (b, d) (c, e)-parProc f g = ProcessA {- feed = proc (x1, x2) ->- do- (y1, f') <- feed f -< x1- (y2, g') <- feed g -< x2- returnA -< ((y1, y2), parProc f' g'),- sweep = proc (x1, x2) ->- do- (my1, f') <- sweep f -< x1- (my2, g') <- sweep g -< x2- let y1 = fromMaybe (suspend f' x1) my1 -- suspend f ?- y2 = fromMaybe (suspend g' x2) my2- r = if (isNothing my1 && isNothing my2) then Nothing else Just (y1, y2)- returnA -< (r, parProc f' g'),- suspend = suspend f *** suspend g- }-{-# NOINLINE parProc #-}+parProc f g = toProcessA $ ParStep f g+{-# INLINE [0] parProc #-} idProc :: ArrowApply a => ProcType a b b idProc = makePA (arr $ \x -> (weakly x, idProc)) id@@ -337,12 +403,12 @@ compositeProc :: ArrowApply a => ProcType a b d -> ProcType a d c -> ProcType a b c compositeProc f0 g0 = ProcessA {- feed = proc x ->+ paFeed = proc x -> do (y, f') <- feed f0 -< x (z, g') <- feed g0 -< y returnA -< (z, compositeProc f' g'),- sweep = proc x ->+ paSweep = proc x -> do (mz, g') <- sweep g0 -< suspend f0 x (case mz@@ -350,7 +416,7 @@ Just z -> arr $ const (Just z, compositeProc f0 g') Nothing -> btrk f0 g') -<< x,- suspend = suspend f0 >>> suspend g0+ paSuspend = suspend f0 >>> suspend g0 } where btrk f g = proc x ->@@ -683,9 +749,9 @@ m (Event o, ProcessA a (Event i) (Event o)) -> ProcessA a (Event i) (Event o) prependProc mr = ProcessA {- feed = proc ex -> do { r <- fit0 mr -< (); prependFeed r -<< ex} ,- sweep = proc ex -> do { r <- fit0 mr -< (); prependSweep r -<< ex},- suspend = const NoEvent+ paFeed = proc ex -> do { r <- fit0 mr -< (); prependFeed r -<< ex} ,+ paSweep = proc ex -> do { r <- fit0 mr -< (); prependSweep r -<< ex},+ paSuspend = const NoEvent } prependFeed (Event x, pa) = arr $ const (Event x, pa)@@ -714,9 +780,9 @@ return (End, stopped) awaitProc fma = ProcessA {- feed = fit' fma,- sweep = fit' fma >>> first eToM,- suspend = const NoEvent+ paFeed = fit' fma,+ paSweep = fit' fma >>> first eToM,+ paSuspend = const NoEvent } eToM :: a (Event b) (Maybe (Event b))@@ -753,17 +819,7 @@ ProcessA a b (c, Event t) -> (t -> ProcessA a b c) -> ProcessA a b c-switch sf k = makePA- (proc x ->- do- (hy, sf') <- step sf -< x- let hevt = fmap snd hy- (case (helperToMaybe hevt)- of- Just (Event t) -> step (k t)- _ -> arr $ const (fst <$> hy, switch sf' k))- -<< x)- (fst . suspend sf)+switch sf k = ggSwitch (const ()) sf (\() -> k) dSwitch ::@@ -771,18 +827,7 @@ ProcessA a b (c, Event t) -> (t -> ProcessA a b c) -> ProcessA a b c-dSwitch sf k = makePA- (proc x ->- do- (hyevt, sf') <- step sf -< x- let hevt = fmap snd hyevt- hy = fmap fst hyevt- (case (helperToMaybe hevt)- of- Just (Event t) -> arr $ const (hy, k t)- _ -> arr $ const (hy, dSwitch sf' k))- -<< x)- (fst . suspend sf)+dSwitch sf k = dggSwitch (const ()) sf (\() -> k) rSwitch ::@@ -810,34 +855,89 @@ ProcessA a (b, c) (Event t) -> (ProcessA a b c -> t -> ProcessA a b c) -> ProcessA a b c-kSwitch sf test k = makePA- (proc x ->- do- (hy, hevt, sf', test') <- testStep sf test -< x- (case (helperToMaybe hevt)- of- Just (Event t) -> step (k sf' t)- _ -> arr $ const (hy, kSwitch sf' test' k))- -<< x)- (suspend sf)+kSwitch sf test =+ ggSwitch+ (\(CompositeStep _ (CompositeStep (ParStep IDStep sf') _)) -> sf')+ (CompositeStep (ArrStep (id &&& id))+ (CompositeStep (ParStep IDStep sf) (arr snd &&& test))) + dkSwitch :: ArrowApply a => ProcessA a b c -> ProcessA a (b, c) (Event t) -> (ProcessA a b c -> t -> ProcessA a b c) -> ProcessA a b c-dkSwitch sf test k = makePA+dkSwitch sf test =+ dggSwitch+ (\(CompositeStep _ (CompositeStep (ParStep IDStep sf') _)) -> sf')+ (CompositeStep (ArrStep (id &&& id))+ (CompositeStep (ParStep IDStep sf) (arr snd &&& test)))++ggSwitch ::+ (ArrowApply a, Stepper a b (c, Event t) sWhole) =>+ (sWhole -> s) ->+ sWhole ->+ (s -> t -> ProcessA a b c) ->+ ProcessA a b c+ggSwitch picker whole k = makePA (proc x -> do- (hy, hevt, sf', test') <- testStep sf test -< x+ let+ (hyevt, whole') <- step whole -<< x+ let hy = fst <$> hyevt+ hevt = snd <$> hyevt (case (helperToMaybe hevt) of- Just (Event t) -> arr $ const (hy, k sf' t)- _ -> arr $ const (hy, dkSwitch sf' test' k))+ Just (Event t) -> step (k (picker whole') t)+ _ -> arr $ const (hy, ggSwitch picker whole' k)) -<< x)- (suspend sf)+ (arr fst . suspend whole) +dggSwitch ::+ (ArrowApply a, Stepper a b (c, Event t) sWhole) =>+ (sWhole -> s) ->+ sWhole ->+ (s -> t -> ProcessA a b c) ->+ ProcessA a b c+dggSwitch picker whole k = makePA+ (proc x ->+ do+ let+ (hyevt, whole') <- step whole -<< x+ let hy = fst <$> hyevt+ hevt = snd <$> hyevt+ (case (helperToMaybe hevt)+ of+ Just (Event t) -> arr $ const (hy, k (picker whole') t)+ _ -> arr $ const (hy, dggSwitch picker whole' k))+ -<< x)+ (arr fst . suspend whole)++gSwitch ::+ ArrowApply a =>+ ProcessA a b (p, r) ->+ ProcessA a p q ->+ ProcessA a (q, r) (c, Event t) ->+ (ProcessA a p q -> t -> ProcessA a b c) ->+ ProcessA a b c+gSwitch pre sf post =+ ggSwitch+ (\(CompositeStep _ (CompositeStep (ParStep sf' IDStep) _)) -> sf')+ (CompositeStep pre (CompositeStep (ParStep sf IDStep) post))++dgSwitch ::+ ArrowApply a =>+ ProcessA a b (p, r) ->+ ProcessA a p q ->+ ProcessA a (q, r) (c, Event t) ->+ (ProcessA a p q -> t -> ProcessA a b c) ->+ ProcessA a b c+dgSwitch pre sf post =+ dggSwitch+ (\(CompositeStep _ (CompositeStep (ParStep sf' IDStep) _)) -> sf')+ (CompositeStep pre (CompositeStep (ParStep sf IDStep) post))+ broadcast :: Functor col => b -> col sf -> col (b, sf)@@ -848,10 +948,7 @@ (forall sf. (b -> col sf -> col (ext, sf))) -> col (ProcessA a ext c) -> ProcessA a b (col c)-par r sfs =- makePA- (parCore r sfs >>> second (arr (par r)))- (suspendAll r sfs)+par r sfs = toProcessA (PluralStep r sfs) parB :: (ArrowApply a, Tv.Traversable col) =>@@ -859,6 +956,23 @@ ProcessA a b (col c) parB = par broadcast ++data PluralStep ext col a b c+ where+ PluralStep ::+ (forall sf. (b -> col sf -> col (ext, sf))) ->+ (col (ProcessA a ext c)) ->+ PluralStep ext col a b c+++instance+ (ArrowApply a, Tv.Traversable col) =>+ Stepper a b (col c) (PluralStep ext col a b c)+ where+ feed (PluralStep r sfs) = parCore r sfs >>> arr (runIdentity *** PluralStep r)+ sweep (PluralStep r sfs) = parCore r sfs >>> arr (id *** PluralStep r)+ suspend (PluralStep r sfs) = suspendAll r sfs+ suspendAll :: (ArrowApply a, Tv.Traversable col) => (forall sf. (b -> col sf -> col (ext, sf))) ->@@ -913,17 +1027,12 @@ 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 = makePA- (proc x ->- do- (hzs, hevt, sfs', test') <-- testStep' (parCore r) (suspendAll r) sfs test -< x- (case helperToMaybe hevt- of- Just (Event t) -> (step (k sfs' t))- _ -> arr $ const (hzs, pSwitch r sfs' test' k))- -<< x)- (suspendAll r sfs)+pSwitch r sfs test =+ ggSwitch+ (\(CompositeStep _+ (CompositeStep (ParStep IDStep (PluralStep _ sfs')) _)) -> sfs')+ (CompositeStep (ArrStep (id &&& id))+ (CompositeStep (ParStep IDStep (PluralStep r sfs)) (arr snd &&& test))) pSwitchB :: (ArrowApply a, Tv.Traversable col) =>@@ -933,7 +1042,27 @@ ProcessA a b (col c) pSwitchB = pSwitch broadcast +dpSwitch ::+ (ArrowApply a, Tv.Traversable col) =>+ (forall sf. (b -> col sf -> col (ext, sf))) ->+ col (ProcessA a ext c) ->+ ProcessA a (b, col c) (Event mng) ->+ (col (ProcessA a ext c) -> mng -> ProcessA a b (col c)) ->+ ProcessA a b (col c)+dpSwitch r sfs test =+ dggSwitch+ (\(CompositeStep _+ (CompositeStep (ParStep IDStep (PluralStep _ sfs')) _)) -> sfs')+ (CompositeStep (ArrStep (id &&& id))+ (CompositeStep (ParStep IDStep (PluralStep r sfs)) (arr snd &&& test))) +dpSwitchB ::+ (ArrowApply a, Tv.Traversable col) =>+ col (ProcessA a b c) ->+ ProcessA a (b, col c) (Event mng) ->+ (col (ProcessA a b c) -> mng -> ProcessA a b (col c)) ->+ ProcessA a b (col c)+dpSwitchB = dpSwitch broadcast rpSwitch :: (ArrowApply a, Tv.Traversable col) =>@@ -942,13 +1071,24 @@ ProcessA a (b, Event (col (ProcessA a ext c) -> col (ProcessA a ext c))) (col c)-rpSwitch r sfs = makePA- (proc (x, evCont) ->- do- let sfsNew = case evCont of {Event f -> f sfs; _ -> sfs}- (hzs, sfs') <- parCore r sfsNew -<< x- returnA -< (hzs, rpSwitch r sfs'))- (fst >>> suspendAll r sfs)+rpSwitch r sfs =+ ggSwitch+ (\(ParStep (PluralStep _ sfs') IDStep) -> sfs')+ (ParStep (PluralStep r sfs) IDStep)+ (\sfs' tr -> next r (tr sfs'))+ where+ next ::+ (ArrowApply a, Tv.Traversable col) =>+ (forall sf. (b -> col sf -> col (ext, sf))) ->+ col (ProcessA a ext c) ->+ ProcessA a+ (b, Event (col (ProcessA a ext c) -> col (ProcessA a ext c)))+ (col c)+ next r' sfs' =+ dggSwitch+ (\(ParStep (PluralStep _ sfs'') IDStep) -> sfs'')+ (ParStep (PluralStep r' sfs') IDStep)+ (\sfs'' _ -> rpSwitch r' sfs'') rpSwitchB ::@@ -959,9 +1099,29 @@ (col c) rpSwitchB = rpSwitch broadcast --- `dpSwitch` and `drpSwitch` are not implemented. +drpSwitch ::+ (ArrowApply a, Tv.Traversable col) =>+ (forall sf. (b -> col sf -> col (ext, sf))) ->+ col (ProcessA a ext c) ->+ ProcessA a+ (b, Event (col (ProcessA a ext c) -> col (ProcessA a ext c)))+ (col c)+drpSwitch r sfs =+ dggSwitch+ (\(ParStep (PluralStep _ sfs') IDStep) -> sfs')+ (ParStep (PluralStep r sfs) IDStep)+ (\sfs' tr -> drpSwitch r (tr sfs')) +drpSwitchB ::+ (ArrowApply a, Tv.Traversable col) =>+ col (ProcessA a b c) ->+ ProcessA a+ (b, Event (col (ProcessA a b c) -> col (ProcessA a b c)))+ (col c)+drpSwitchB = drpSwitch broadcast++ -- -- Unsafe primitives --@@ -984,9 +1144,9 @@ go >>> fork where go = ProcessA {- feed = p >>> arr (\y -> (Event y, go)),- sweep = p >>> arr (\y -> (if nullFd y then Nothing else Just (Event y), go)),- suspend = const NoEvent+ paFeed = p >>> arr (\y -> (Event y, go)),+ paSweep = p >>> arr (\y -> (if nullFd y then Nothing else Just (Event y), go)),+ paSuspend = const NoEvent } fork = repeatedly $ await >>= Fd.mapM_ yield
src/Control/Arrow/Machine/Utils.hs view
@@ -56,9 +56,10 @@ parB, now, onEnd,-+#if defined(MIN_VERSION_arrows) -- * Transformer readerProc+#endif ) where @@ -71,8 +72,9 @@ import Control.Monad.State import Control.Arrow import Control.Applicative+#if defined(MIN_VERSION_arrows) import Control.Arrow.Transformer.Reader (ArrowAddReader(..))-+#endif import Control.Arrow.Machine.ArrowUtil import Control.Arrow.Machine.Types @@ -325,6 +327,8 @@ go = repeatedly $ await `catchP` (yield () >> stop) ++#if defined(MIN_VERSION_arrows) -- | Run reader of base arrow. readerProc :: (ArrowApply a, ArrowApply a', ArrowAddReader r a a') =>@@ -334,4 +338,4 @@ where swap :: (a, b) -> (b, a) swap ~(a, b) = (b, a)-+#endif