machinecell 2.1.0 → 3.0.0
raw patch · 9 files changed
+604/−539 lines, 9 files
Files
- machinecell.cabal +2/−2
- src/Control/Arrow/Machine.hs +1/−0
- src/Control/Arrow/Machine/ArrowUtil.hs +89/−8
- src/Control/Arrow/Machine/Misc/Discrete.hs +1/−0
- src/Control/Arrow/Machine/Misc/Exception.hs +1/−1
- src/Control/Arrow/Machine/Misc/Pump.hs +2/−1
- src/Control/Arrow/Machine/Types.hs +471/−400
- src/Control/Arrow/Machine/Utils.hs +27/−106
- test/LoopUtil.hs +10/−21
machinecell.cabal view
@@ -1,5 +1,5 @@ name: machinecell-version: 2.1.0+version: 3.0.0 synopsis: Arrow based stream transducers license: BSD3 license-file: LICENSE@@ -53,4 +53,4 @@ source-repository this type: git location: https://github.com/as-capabl/machinecell.git- tag: release-2.1.0+ tag: release-3.0.0
src/Control/Arrow/Machine.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE Safe #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Arrows #-} {-# LANGUAGE RankNTypes #-}
src/Control/Arrow/Machine/ArrowUtil.hs view
@@ -2,6 +2,11 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Arrows #-} +#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif -- | Arrow utilities not related to machinecell library. module@@ -27,7 +32,22 @@ reading, statefully, - -- * To absorve arrow stack signature difference bettween ghc 7.8 and older.+ -- * Arrow construction helper (Lens)+ -- |Lens Isomorphisms between arrows and monads.+ -- All definitions are defined arrow->monad directions.+ -- Use with lens operator (^.) and (#).+ kl,+ am,+ rd,+ uc0,+ uc1,+ uc2,+ uc3,+ uc4,+ uc5,++ -- * Custom arrow syntax helper+ -- |To absorve arrow stack signature difference bettween ghc 7.8 and older. AS, toAS, fromAS,@@ -36,13 +56,17 @@ ) where +import Prelude hiding ((.), id)+import Control.Category import Control.Arrow-import Control.Arrow.Operations (readState, store, fetch)-import Control.Arrow.Transformer.Reader+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.Reader (ReaderT(..), runReaderT) import Control.Monad.State (StateT, runStateT)+import Data.Profunctor + #if __GLASGOW_HASKELL__ >= 708 type AS e = (e, ())@@ -137,10 +161,7 @@ (forall p q. (p->m q)->a p q) -> (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)+reading f mr = ReaderArrow . f $ uncurry (runReaderT . mr) statefully :: (Monad m, Arrow a) =>@@ -155,9 +176,69 @@ returnA -< y +type MyIso s t a b =+ forall p f. (Profunctor p, Functor f) =>+ p a (f b) -> p s (f t)++type MyIso' s a = MyIso s s a a++myIso ::+ (s -> a) -> (b -> t) -> MyIso s t a b+myIso sa bt = dimap sa (fmap bt)++-- |Isomorphsm between m and (Kleisli m)+kl ::+ MyIso' (a -> m b) (Kleisli m a b)+kl = myIso Kleisli runKleisli++-- |Isomorphism between (ArrowMonad a) and a+am ::+ ArrowApply a =>+ MyIso' (b -> ArrowMonad a c) (a b c)+am = myIso unArrowMonad arrowMonad++rd ::+ (Arrow a) =>+ (forall p q. MyIso' (p -> m q) (a p q)) ->+ MyIso' (b -> ReaderT r m c) (ReaderArrow r a b c)+rd f = e . f . g+ where+ e = myIso+ (\frmy -> uncurry (runReaderT . frmy))+ (\fmy -> ReaderT . (curry fmy))+ g = myIso ReaderArrow runReader++uc0 :: MyIso' (m b) (() -> m b)+uc0 = myIso const ($())++uc1 :: MyIso' (a1 -> m b) (a1 -> m b)+uc1 = id++uc2 :: MyIso' (a1 -> a2 -> m b) ((a1, a2) -> m b)+uc2 = myIso+ (\f (a1, a2) -> f a1 a2)+ (\f a1 a2 -> f (a1, a2))++uc3 :: MyIso' (a1 -> a2 -> a3 -> m b) ((a1, a2, a3) -> m b)+uc3 = myIso+ (\f (a1, a2, a3) -> f a1 a2 a3)+ (\f a1 a2 a3 -> f (a1, a2, a3))++uc4 :: MyIso' (a1 -> a2 -> a3 -> a4 -> m b) ((a1, a2, a3, a4) -> m b)+uc4 = myIso+ (\f (a1, a2, a3, a4) -> f a1 a2 a3 a4)+ (\f a1 a2 a3 a4 -> f (a1, a2, a3, a4))++uc5 :: MyIso' (a1 -> a2 -> a3 -> a4 -> a5 -> m b) ((a1, a2, a3, a4, a5) -> m b)+uc5 = myIso+ (\f (a1, a2, a3, a4, a5) -> f a1 a2 a3 a4 a5)+ (\f a1 a2 a3 a4 a5 -> f (a1, a2, a3, a4, a5))+ -- |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)++
src/Control/Arrow/Machine/Misc/Discrete.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE Safe #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Arrows #-} {-# LANGUAGE RankNTypes #-}
src/Control/Arrow/Machine/Misc/Exception.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE Safe #-} module Control.Arrow.Machine.Misc.Exception
src/Control/Arrow/Machine/Misc/Pump.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE Safe #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Arrows #-} {-# LANGUAGE RankNTypes #-}@@ -24,7 +25,7 @@ where import Prelude hiding (id, (.))-import Data.Functor+import Data.Functor ((<$), (<$>)) import Control.Category import Control.Arrow import qualified Control.Arrow.Machine as P
src/Control/Arrow/Machine/Types.hs view
@@ -1,29 +1,41 @@+{-# LANGUAGE Trustworthy #-} -- Safe if eliminate GeneralizedNewtypeInstance {-# LANGUAGE Arrows #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Control.Arrow.Machine.Types (- -- * Basic types+ -- * Stream transducer type ProcessA(), + -- * Event type and utility Occasional' (..), Occasional (..), Event (), condEvent, filterEvent,+ filterJust,+ filterLeft,+ filterRight, evMap, - -- * Plan monads- PlanT,+ -- * Coroutine monad+ -- | Procedural coroutine monad that can await or yield values.+ --+ -- Coroutines can be encoded to machines by `constructT` or so on and+ -- then put into `ProcessA` compositions.+ PlanT(..), Plan, await,@@ -67,33 +79,30 @@ rpSwitchB, par, parB,- -- * Primitive machines - other safe primitives fit,- loop',+ fitW, -- * Primitive machines - unsafe- fitEx,- unsafeSteady, unsafeExhaust, ) where import qualified Control.Category as Cat import Data.Profunctor (Profunctor, dimap, rmap)-import Control.Arrow.Operations (ArrowReader(..))-import Control.Arrow.Transformer.Reader (ArrowAddReader(..)) import Control.Arrow-import Control.Monad hiding (join)+import Control.Monad import Control.Monad.Trans-import Control.Monad.State hiding (join)-import Control.Monad.Writer hiding ((<>), join)-import Control.Applicative hiding (pure)-import qualified Control.Applicative as Ap+import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.Writer hiding ((<>))+import Control.Monad.Identity+import Control.Applicative import Data.Foldable as Fd import Data.Traversable as Tv import Data.Semigroup (Semigroup, (<>))+import Data.Maybe (fromMaybe, isNothing, isJust) import qualified Control.Monad.Trans.Free as F import qualified Control.Monad.Trans.Free.Church as F import Control.Arrow.Machine.ArrowUtil@@ -117,60 +126,107 @@ mappend Sweep Sweep = Sweep -type StepType a b c = a (Phase, b) (Phase, c, ProcessA a b c) +type ProcType a b c = ProcessA a b c -- | The stream transducer arrow. -- -- To construct `ProcessA` instances, use `Control.Arrow.Machine.Plan.Plan`, -- `arr`, functions declared in `Control.Arrow.Machine.Utils`, -- or arrow combinations of them.-newtype ProcessA a b c = ProcessA { - step :: StepType a b c- }+--+-- 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)+ } -fitEx :: (Arrow a, Arrow a') =>- (forall p q. a (p, b) (q, c) -> a' (p, b') (q, c')) ->- ProcessA a b c ->- ProcessA a' b' c'-fitEx f k = ProcessA $ proc (ph, x) ->- do- ((ph', k'), y) <- f (step k >>> arr (\(ph', y, k') -> ((ph', k'), y))) -< (ph, x)- returnA -< (ph', y, fitEx f k')-+-- 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)+ 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+ -<< () -fit :: (Arrow a, Arrow a') => - (forall p q. a p q -> a' p q) -> - ProcessA a b c -> ProcessA a' b c-fit f = fitEx f+instance+ ProcessHelper Identity+ where+ step pa = feed pa >>> first (arr Identity)+ helperToMaybe = Just . runIdentity+ weakly = Identity +instance+ ProcessHelper Maybe+ where+ step = sweep+ helperToMaybe = id+ weakly _ = Nothing -loop' :: ArrowApply a =>- d ->- ProcessA a (b, d) (c, d) ->+makePA ::+ Arrow a =>+ (forall f. ProcessHelper f =>+ a b (f c, ProcessA a b c)) ->+ (b -> c) -> ProcessA a b c-loop' i pa = ProcessA $ proc (ph, x) ->- do- (ph', (y, n), pa') <- step pa -< (ph, (x, i))- returnA -< (ph', y, loop' n pa')+makePA h sus = ProcessA {+ feed = h >>> first (arr runIdentity),+ sweep = h,+ suspend = sus+ }+ + +-- |Natural transformation+fit ::+ (ArrowApply a, ArrowApply a') => + (forall p q. a p q -> a' p q) -> + ProcessA a b c -> ProcessA a' b c+fit f pa =+ arr Identity >>>+ fitW runIdentity (\ar -> arr runIdentity >>> f ar) pa +-- |Experimental: more general fit.+--+-- Should w be a comonad?+fitW :: (ArrowApply a, ArrowApply a', Functor w) =>+ (forall p. w p -> p) ->+ (forall p q. a p q -> a' (w p) q) -> + ProcessA a b c -> ProcessA a' (w b) c+fitW extr f pa = makePA+ (f (step pa) >>> arr (second $ fitW extr f))+ (extr >>> suspend pa)++ instance- Arrow a => Profunctor (ProcessA a)+ ArrowApply a => Profunctor (ProcessA a) where- dimap f g pa = ProcessA $ dimapStep f g (step pa)+ dimap = dimapProc {-# INLINE dimap #-} -dimapStep :: Arrow a => - (b->c)->(d->e)->- StepType a c d -> StepType a b e-dimapStep f g stp = proc (ph, x) ->- do- (ph', y, pa') <- stp -< (ph, f x)- returnA -< (ph', g y, dimap f g pa')-{-# NOINLINE dimapStep #-}+dimapProc ::+ ArrowApply a => + (b->c)->(d->e)->+ ProcType a c d -> ProcType a b e+dimapProc f g pa = makePA+ (arr f >>> step pa >>> (arr (fmap g) *** arr (dimapProc f g)))+ (dimap f g (suspend pa)) +{-# NOINLINE dimapProc #-}++ instance- Arrow a => Functor (ProcessA a i)+ ArrowApply a => Functor (ProcessA a i) where fmap = rmap @@ -180,202 +236,185 @@ pure = arr . const pf <*> px = (pf &&& px) >>> arr (uncurry ($)) - + instance ArrowApply a => Cat.Category (ProcessA a) where- id = ProcessA idStep+ id = idProc {-# INLINE id #-}- g . f = ProcessA $ compositeStep (step f) (step g)+ g . f = compositeProc f g {-# INLINE (.) #-} instance ArrowApply a => Arrow (ProcessA a) where- arr = ProcessA . arrStep+ arr = arrProc {-# INLINE arr #-} - first pa = ProcessA $ parStep (step pa) idStep+ first pa = parProc pa idProc {-# INLINE first #-} - second pa = ProcessA $ parStep idStep (step pa)+ second pa = parProc idProc pa {-# INLINE second #-} - pa *** pb = ProcessA $ parStep (step pa) (step pb)+ (***) = parProc {-# INLINE (***) #-} -parStep :: ArrowApply a =>- StepType a b c ->- StepType a d e ->- StepType a (b, d) (c, e)-parStep f g = proc (ph, (x1, x2)) ->- do- (ph1, y1, pa') <- f -< (ph, x1)- (ph2, y2, pb') <- g -< (ph, x2)- returnA -< (ph1 `mappend` ph2, (y1, y2), pa' *** pb')-{-# NOINLINE parStep #-}--idStep :: ArrowApply a => StepType a b b-idStep = proc (ph, x) ->- returnA -< (ph `mappend` Suspend, x, ProcessA $ idStep)-{-# NOINLINE idStep #-}+parProc :: ArrowApply a =>+ 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 #-} -arrStep :: ArrowApply a => (b->c) -> StepType a b c-arrStep f = proc (ph, x) ->- returnA -< (ph `mappend` Suspend, f x, ProcessA $ arrStep f)-{-# NOINLINE arrStep #-}+idProc :: ArrowApply a => ProcType a b b+idProc = makePA (arr $ \x -> (weakly x, idProc)) id+{-# NOINLINE idProc #-} +arrProc :: ArrowApply a => (b->c) -> ProcType a b c+arrProc f = makePA (arr $ \x -> (weakly (f x), arrProc f)) f+{-# NOINLINE arrProc #-} -- |Composition is proceeded by the backtracking strategy.-compositeStep :: ArrowApply a => - StepType a b d -> StepType a d c -> StepType a b c-compositeStep f g = proc (ph, x) -> compositeStep' ph f g -<< (ph, x)-{-# NOINLINE compositeStep #-}--compositeStep' :: ArrowApply a => - Phase -> - StepType a b d -> StepType a d c -> StepType a b c- -compositeStep' Sweep f g = proc (_, x) ->- do- (_, r1, pa') <- f -< (Suspend, x)- (ph2, r2, pb') <- g -<< (Sweep, r1)- cont ph2 -<< (r2, pa', pb', x)+compositeProc :: ArrowApply a => + ProcType a b d -> ProcType a d c -> ProcType a b c+compositeProc f0 g0 = ProcessA {+ feed = proc x ->+ do+ (y, f') <- feed f0 -< x+ (z, g') <- feed g0 -< y+ returnA -< (z, compositeProc f' g'),+ sweep = proc x ->+ do+ (mz, g') <- sweep g0 -< suspend f0 x+ (case mz+ of+ Just z -> arr $ const (Just z, compositeProc f0 g')+ Nothing -> btrk f0 g')+ -<< x,+ suspend = suspend f0 >>> suspend g0+ } where- cont Feed = arr $ \(r, pa, pb, _) -> (Feed, r, pa >>> pb)- cont Sweep = arr $ \(r, pa, pb, _) -> (Sweep, r, pa >>> pb)- cont Suspend = proc (r, pa, pb, x) ->+ btrk f g = proc x -> do- (ph1, r1, pa') <- step pa -<< (Sweep, x)- (ph2, r2, pb') <-- (if ph1 == Feed- then- step pb- else- arr $ const (Suspend, r, pb))- -<< (ph1, r1)- returnA -< (ph2, r2, pa' >>> pb')+ (my, f') <- sweep f -< x+ (mz, g') <-+ (case my+ of+ Just y -> proc () ->+ do+ (z, g') <- feed g -< y+ returnA -< (Just z, g')+ Nothing -> proc () ->+ do+ returnA -< (Nothing, g))+ -<< ()+ returnA -< (mz, compositeProc f' g') -compositeStep' ph f g = proc (_, x) ->- do- (ph1, r1, pa') <- f -< (ph, x)- (ph2, r2, pb') <- g -<< (ph1, r1)- returnA -< (ph2, r2, pa' >>> pb')+{-# NOINLINE compositeProc #-} -- rules {-# RULES "ProcessA: id/*"- forall g. compositeStep idStep g = g+ forall g. compositeProc idProc g = g "ProcessA: */id"- forall f. compositeStep f idStep = f+ forall f. compositeProc f idProc = f "ProcessA: concat/concat" - forall f g h. compositeStep (compositeStep f g) h = compositeStep f (compositeStep g h)+ forall f g h. compositeProc (compositeProc f g) h = compositeProc f (compositeProc g h) "ProcessA: dimap/dimap"- forall f g h i j. dimapStep f j (dimapStep g i h) = dimapStep (g . f) (j . i) h+ forall f g h i j. dimapProc f j (dimapProc g i h) = dimapProc (g . f) (j . i) h "ProcessA: dimap/arr"- forall f g h. dimapStep f h (arrStep g) = arrStep (h . g . f)+ forall f g h. dimapProc f h (arrProc g) = arrProc (h . g . f) "ProcessA: arr***/par"- forall f1 f2 g1 g2 h. compositeStep (parStep f1 (arrStep f2)) (compositeStep (parStep g1 g2) h) =- compositeStep (parStep (compositeStep f1 g1) (dimapStep f2 id g2)) h+ forall f1 f2 g1 g2 h. compositeProc (parProc f1 (arrProc f2)) (compositeProc (parProc g1 g2) h) =+ compositeProc (parProc (compositeProc f1 g1) (dimapProc f2 id g2)) h "ProcessA: arr***/par-2"- forall f1 f2 g1 g2. compositeStep (parStep f1 (arrStep f2)) (parStep g1 g2) =- parStep (compositeStep f1 g1) (dimapStep f2 id g2)+ forall f1 f2 g1 g2. compositeProc (parProc f1 (arrProc f2)) (parProc g1 g2) =+ parProc (compositeProc f1 g1) (dimapProc f2 id g2) "ProcessA: par/***arr"- forall f1 f2 g1 g2 h. compositeStep (parStep f1 f2) (compositeStep (parStep (arrStep g1) g2) h) =- compositeStep (parStep (dimapStep id g1 f1) (compositeStep f2 g2)) h+ forall f1 f2 g1 g2 h. compositeProc (parProc f1 f2) (compositeProc (parProc (arrProc g1) g2) h) =+ compositeProc (parProc (dimapProc id g1 f1) (compositeProc f2 g2)) h "ProcessA: par/***arr-2"- forall f1 f2 g1 g2. compositeStep (parStep f1 f2) (parStep (arrStep g1) g2) =- parStep (dimapStep id g1 f1) (compositeStep f2 g2)+ forall f1 f2 g1 g2. compositeProc (parProc f1 f2) (parProc (arrProc g1) g2) =+ parProc (dimapProc id g1 f1) (compositeProc f2 g2) "ProcessA: first/par"- forall f1 g1 g2 h. compositeStep (parStep f1 idStep) (compositeStep (parStep g1 g2) h) =- compositeStep (parStep (compositeStep f1 g1) g2) h+ forall f1 g1 g2 h. compositeProc (parProc f1 idProc) (compositeProc (parProc g1 g2) h) =+ compositeProc (parProc (compositeProc f1 g1) g2) h "ProcessA: first/par-2"- forall f1 g1 g2. compositeStep (parStep f1 idStep) (parStep g1 g2) =- parStep (compositeStep f1 g1) g2+ forall f1 g1 g2. compositeProc (parProc f1 idProc) (parProc g1 g2) =+ parProc (compositeProc f1 g1) g2 "ProcessA: par/second"- forall f1 f2 g2 h. compositeStep (parStep f1 f2) (compositeStep (parStep idStep g2) h) =- compositeStep (parStep f1 (compositeStep f2 g2)) h+ forall f1 f2 g2 h. compositeProc (parProc f1 f2) (compositeProc (parProc idProc g2) h) =+ compositeProc (parProc f1 (compositeProc f2 g2)) h "ProcessA: par/second-2"- forall f1 f2 g2. compositeStep (parStep f1 f2) (parStep idStep g2) =- parStep f1 (compositeStep f2 g2)+ forall f1 f2 g2. compositeProc (parProc f1 f2) (parProc idProc g2) =+ parProc f1 (compositeProc f2 g2) "ProcessA: arr/arr"- forall f g h. compositeStep (arrStep f) (compositeStep (arrStep g) h) =- compositeStep (arrStep (g . f)) h+ forall f g h. compositeProc (arrProc f) (compositeProc (arrProc g) h) =+ compositeProc (arrProc (g . f)) h "ProcessA: arr/arr-2"- forall f g. compositeStep (arrStep f) (arrStep g) = arrStep (g . f)+ forall f g. compositeProc (arrProc f) (arrProc g) = arrProc (g . f) "ProcessA: arr/*" [1]- forall f g. compositeStep (arrStep f) g = dimapStep f id g+ forall f g. compositeProc (arrProc f) g = dimapProc f id g "ProcessA: */arr" [1]- forall f g. compositeStep f (arrStep g) = dimapStep id g f+ forall f g. compositeProc f (arrProc g) = dimapProc id g f "ProcessA: arr***arr" [0]- forall f g. parStep (arrStep f) (arrStep g) = arrStep (f *** g)+ forall f g. parProc (arrProc f) (arrProc g) = arrProc (f *** g) #-} -instance- ArrowApply a => ArrowChoice (ProcessA a)- where- left pa@(ProcessA a) = ProcessA $ proc (ph, eth) -> go ph eth -<< ()- where- go ph (Left x) = proc _ -> - do- (ph', y, pa') <- a -< (ph, x)- returnA -< (ph', Left y, left pa')- go ph (Right d) = proc _ -> - returnA -< (ph `mappend` Suspend, Right d, left pa) instance- (ArrowApply a, ArrowLoop a) => ArrowLoop (ProcessA a)+ ArrowApply a => ArrowChoice (ProcessA a) where- loop pa = ProcessA $ proc (ph, x) ->- do- (_, d) <- loop suspended -< x- (ph', (y, _), pa') <- step pa -< (ph, (x, d))- returnA -< (ph', y, loop pa')+ left pa0 = makePA+ (proc eth -> sweep' pa0 eth -<< ())+ (left $ suspend pa0) where- suspended = proc (x, d) ->+ sweep' pa (Left x) = proc () -> do- (_, (y, d'), _) <- step pa -< (Suspend, (x, d))- returnA -< ((y, d'), d')---instance- (ArrowApply a, ArrowReader r a) => - ArrowReader r (ProcessA a)- where- readState = ProcessA $ proc (ph, dm) ->- do- r <- readState -< dm- returnA -< (ph `mappend` Suspend, r, readState)-- newReader = fitEx nr- where- nr f = proc (p, (x, r)) -> newReader f -< ((p, x), r)+ (my, pa') <- step pa -< x+ returnA -< (Left <$> my, left pa')+ sweep' pa (Right d) = proc () ->+ returnA -< (weakly (Right d), left pa) instance- (ArrowApply a, ArrowApply a', ArrowAddReader r a a') =>- ArrowAddReader r (ProcessA a) (ProcessA a')+ ArrowApply a => ArrowLoop (ProcessA a) where- liftReader pa = ProcessA $ proc (ph, x) ->- do- (ph', y, pa') <- (| liftReader (step pa -< (ph, x)) |)- returnA -< (ph', y, liftReader pa')-- elimReader pra = - ProcessA $ arr pre >>> elimReader (step pra) >>> arr post+ loop pa =+ makePA + (proc x ->+ do+ (hyd, pa') <- step pa -< (x, loopSusD x)+ returnA -< (fst <$> hyd, loop pa'))+ (loop $ suspend pa) where- pre (ph, (x, r)) = ((ph, x), r)- post (ph, x, pra') = (ph, x, elimReader pra')-+ loopSusD = loop (suspend pa >>> \(_, d) -> (d, d)) - -data Event a = Event a | NoEvent | End deriving (Eq, Show)+-- | Discrete events on a time line.+-- Created and consumed by various transducers.+data Event a = Event a | NoEvent | End instance @@ -400,7 +439,7 @@ -- | Signals that can be absent(`NoEvent`) or end.--- For composite structure, `collapse` can be defined as monoidal sum of all member occasionals.+-- For composite structure, `collapse` can be defined as monoid sum of all member occasionals. class Occasional' a where@@ -437,18 +476,27 @@ end = End ---- TODO: テスト condEvent :: Bool -> Event a -> Event a condEvent _ End = End condEvent True ev = ev condEvent False _ = NoEvent --- TODO: テスト filterEvent :: (a -> Bool) -> Event a -> Event a filterEvent cond ev@(Event x) = condEvent (cond x) ev filterEvent _ ev = ev +filterJust :: Event (Maybe a) -> Event a+filterJust (Event (Just x)) = Event x+filterJust (Event Nothing) = NoEvent+filterJust NoEvent = NoEvent+filterJust End = End++filterLeft :: Event (Either a b) -> Event a+filterLeft = filterJust . fmap (either Just (const Nothing))++filterRight :: Event (Either a b) -> Event b+filterRight = filterJust . fmap (either (const Nothing) Just)+ -- | Alias of "arr . fmap" -- -- While "ProcessA a (Event b) (Event c)" means a transducer from b to c,@@ -481,7 +529,7 @@ (ArrowApply a, Occasional' b, Occasional c) => ProcessA a b c muted = proc x -> do- ed <- repeatedly $ await `catchP` yield () -< collapse x+ ed <- construct (forever await `catchP` yield ()) -< collapse x rSwitch (arr $ const noEvent) -< ((), stopped <$ ed) @@ -496,32 +544,60 @@ fmap g (YieldPF x r) = YieldPF x (g r) fmap _ StopPF = StopPF --type PlanT i o m a = F.FT (PlanF i o) m a+newtype PlanT i o m a =+ PlanT { freePlanT :: F.FT (PlanF i o) m a }+ deriving+ (Functor, Applicative, Monad, MonadTrans,+ Alternative)+ -- , MonadError, MonadReader, MonadCatch, MonadThrow, MonadIO, MonadCont type Plan i o a = forall m. Monad m => PlanT i o m a +instance+ MonadReader r m => MonadReader r (PlanT i o m)+ where+ ask = PlanT ask+ local f (PlanT pl) = PlanT $ local f pl +instance+ MonadWriter w m => MonadWriter w (PlanT i o m)+ where+ tell = PlanT . tell+ listen = PlanT . listen . freePlanT+ pass = PlanT . pass . freePlanT++instance+ MonadState s m => MonadState s (PlanT i o m)+ where+ get = PlanT get+ put = PlanT . put++instance+ (Monad m, Alternative m) => MonadPlus (PlanT i o m)+ where+ mzero = stop+ mplus = catchP+ yield :: o -> Plan i o ()-yield x = F.liftF $ YieldPF x ()+yield x = PlanT . F.liftF $ YieldPF x () await :: Plan i o i-await = F.FT $ \pure free -> free id (AwaitPF pure (free pure StopPF))+await = PlanT $ F.FT $ \pr free -> free id (AwaitPF pr (free pr StopPF)) stop :: Plan i o a-stop = F.liftF $ StopPF+stop = PlanT $ F.liftF $ StopPF catchP:: Monad m => PlanT i o m a -> PlanT i o m a -> PlanT i o m a -catchP pl cont0 = - F.FT $ \pure free ->+catchP (PlanT pl) cont0 = + PlanT $ F.FT $ \pr free -> F.runFT pl- (pure' pure)- (free' cont0 pure free)+ (pr' pr)+ (free' cont0 pr free) where- pure' pure = pure+ pr' pr = pr free' :: Monad m =>@@ -531,11 +607,11 @@ (y -> m r) -> (PlanF i o y) -> m r- free' cont pure free _ StopPF =- F.runFT cont pure free- free' cont pure free r (AwaitPF f ff) =+ free' (PlanT cont) pr free _ StopPF =+ F.runFT cont pr free+ free' (PlanT cont) pr free r (AwaitPF f ff) = free- (either (\_ -> F.runFT cont pure free) r)+ (either (\_ -> F.runFT cont pr free) r) (AwaitPF (Right . f) (Left ff)) free' _ _ free r pf = free r pf@@ -543,59 +619,69 @@ -constructT :: (Monad m, ArrowApply a) => - (forall b. m b -> a () b) ->- PlanT i o m r -> - ProcessA a (Event i) (Event o)+constructT ::+ (Monad m, ArrowApply a) => + (forall b. m b -> a () b) ->+ PlanT i o m r -> + ProcessA a (Event i) (Event o)+constructT = constructT' -constructT fit0 pl0 = ProcessA $ stepOf fit0 $ F.runFT pl0 pure (free fit0)++constructT' ::+ forall a m i o r.+ (Monad m, ArrowApply a) => + (forall b. m b -> a () b) ->+ PlanT i o m r -> + ProcessA a (Event i) (Event o)+constructT' fit0 (PlanT pl0) = prependProc $ F.runFT pl0 pr free where- stepOf fit' ma = proc arg ->- do- (evy, stp) <- fit' ma -< ()- prependStep evy stp -<< arg- - prependStep (Event y) stp = arr $ \(ph, _) -> - case ph of- Suspend -> - (Suspend, NoEvent, ProcessA $ prependStep (Event y) stp)- _ -> - (Feed, Event y, ProcessA stp)- prependStep End _ = step stopped- prependStep NoEvent stp = stp+ fit' :: (b -> m c) -> a b c+ fit' fmy = proc x -> fit0 (fmy x) -<< () - stepOfAw fit' fma = proc arg@(ph, _) ->- do- (evy, stp) <- fit' $ go arg -<< ()- let ph' = case evy of {NoEvent -> Suspend; _ -> Feed}- returnA -< (ph `mappend` ph', evy, ProcessA stp)- where- go (Feed, evx) = fma evx- go (Sweep, End) = fma End- go _ = return (NoEvent, stepOfAw fit' fma)+ prependProc ::+ 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+ } - pure _ =- return $ (End, step stopped)+ prependFeed (Event x, pa) = arr $ const (Event x, pa)+ prependFeed (NoEvent, pa) = feed pa+ prependFeed (End, _) = arr $ const (End, stopped)+ + prependSweep (Event x, pa) = arr $ const (Just (Event x), pa)+ prependSweep (NoEvent, pa) = sweep pa+ prependSweep (End, _) = arr $ const (Just End, stopped)+ + pr _ = return (End, stopped) free ::- (ArrowApply a, Monad m) =>- (forall t. m t -> a () t) ->- (x -> m (Event o, StepType a (Event i) (Event o)))- -> PlanF i o x -> m (Event o, StepType a (Event i) (Event o))- free fit' r pl@(AwaitPF f ff) =- do- return $ (NoEvent, stepOfAw fit' fma)+ (x -> m (Event o, ProcessA a (Event i) (Event o)))->+ PlanF i o x ->+ m (Event o, ProcessA a (Event i) (Event o))+ free r (YieldPF y cont) =+ return (Event y, prependProc (r cont))+ free r pl@(AwaitPF f ff) =+ return (NoEvent, awaitProc fma) where fma (Event x) = r (f x)- fma NoEvent = free fit' r pl+ fma NoEvent = free r pl fma End = r ff-- free fit' r (YieldPF y fc) =- return $ (Event y, stepOf fit' (r fc))+ free _ StopPF =+ return (End, stopped) - free _ _ StopPF =- return $ (End, step stopped)+ awaitProc fma = ProcessA {+ feed = fit' fma,+ sweep = fit' fma >>> first eToM,+ suspend = const NoEvent+ } + eToM :: a (Event b) (Maybe (Event b))+ eToM = arr eToMpure+ eToMpure NoEvent = Nothing+ eToMpure e = Just e repeatedlyT :: (Monad m, ArrowApply a) => @@ -621,27 +707,7 @@ -- -- Switches ---evMaybePh :: b -> (a->b) -> (Phase, Event a) -> b-evMaybePh _ f (Feed, Event x) = f x-evMaybePh _ f (Sweep, Event x) = f x-evMaybePh d _ _ = d---{--type KSwitchLike a b c t =- ProcessA a b c ->- ProcessA a (b, ) (Event t) ->- (ProcessA a b c -> t -> ProcessA a b c) ->- ProcessA a b c- switchCore ::- ArrowApply a =>- KSwitchLike a b c t ->- ProcessA a b (c, Event t) -> - (t -> ProcessA a b c) ->- ProcessA a b c--}-switchCore :: (Arrow cat, Arrow a2, Arrow cat1, Occasional t3) => (t4 -> a2 (t5, (t6, c1)) c1@@ -675,7 +741,6 @@ rSwitch :: ArrowApply a => ProcessA a b c -> ProcessA a (b, Event (ProcessA a b c)) c- rSwitch p = rSwitch' (p *** Cat.id) >>> arr fst where rSwitch' pid = kSwitch pid test $ \_ p' -> rSwitch'' (p' *** Cat.id)@@ -691,28 +756,24 @@ where drSwitch' pid = dSwitch pid $ \p' -> drSwitch' (p' *** Cat.id) + 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))-- let- nextA t = k sf' t- nextB = kSwitch sf' test' k-- evMaybePh - (arr $ const (phT, y, nextB)) - (step . nextA)- (phT, evt)- -<< (phT, x)-+kSwitch sf test k = makePA+ (proc x ->+ do+ (hy, sf') <- step sf -< x+ (hevt, test') <- step' test -< (x,) <$> hy+ (case (helperToMaybe hevt)+ of+ Just (Event t) -> step (k sf' t)+ _ -> arr $ const (hy, kSwitch sf' test' k))+ -<< x)+ (suspend sf) dkSwitch :: ArrowApply a => @@ -720,67 +781,84 @@ ProcessA a (b, c) (Event t) -> (ProcessA a b c -> t -> ProcessA a b c) -> ProcessA a b c--dkSwitch sf test k = ProcessA $ proc (ph, x) ->- do- (ph', y, sf') <- step sf -< (ph, x)- (phT, evt, test') <- step test -< (ph', (x, y))- - let- nextA t = k sf' t- nextB = dkSwitch sf' test' k-- returnA -< (phT, y, evMaybePh nextB nextA (ph, evt))--+dkSwitch sf test k = makePA+ (proc x ->+ do+ (hy, sf') <- step sf -< x+ (hevt, test') <- step' test -< (x,) <$> hy+ (case (helperToMaybe hevt)+ of+ Just (Event t) -> arr $ const (hy, k sf' t)+ _ -> arr $ const (hy, dkSwitch sf' test' k))+ -<< x)+ (suspend sf)+ 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')+par r sfs =+ makePA+ (parCore r sfs >>> second (arr (par r)))+ (suspendAll r sfs) parB :: (ArrowApply a, Tv.Traversable col) => col (ProcessA a b c) -> ProcessA a b (col c)- parB = par broadcast -parCore ::+suspendAll :: (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))+ b -> col c+suspendAll r sfs = (sus <$>) . (r `flip` sfs)+ where+ sus (ext, sf) = suspend sf ext+ +traverseResult ::+ forall h col c.+ (Tv.Traversable col, ProcessHelper h) =>+ col (h c, c) -> h (col c)+traverseResult zs =+ let+ pr :: (h c, c) -> StateT Bool h c+ pr (hx, d) =+ do+ let mx = helperToMaybe hx+ if isJust mx then put True else return ()+ return (fromMaybe d mx)+ hxs = runStateT (Tv.sequence (pr <$> zs)) False+ exist = fromMaybe False $ helperToMaybe (snd <$> hxs)+ result = fst <$> hxs+ in+ if exist then result else join (weakly result)+ +parCore ::+ (ArrowApply a, Tv.Traversable col, ProcessHelper h) =>+ (forall sf. (b -> col sf -> col (ext, sf))) ->+ col (ProcessA a ext c) ->+ a b (h (col c), col (ProcessA a ext c)) -parCore r sfs = proc (ph, x) ->+parCore r sfs = proc 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')-+ ret <- unwrapArrow (Tv.sequenceA (fmap (WrapArrow . app') input)) -<< ()+ let zs = traverseResult $ fmap fst ret+ sfs' = fmap snd ret+ returnA -< (zs, sfs') where- appPh (y, sf) = proc ph -> step sf -< (ph, y)-- getPh (ph, _, _) = ph- getZ (_, z, _) = z- getSf (_, _, sf) = sf+ app' (y, sf) = proc () ->+ do+ (hz, sf') <- step sf -< y+ returnA -< ((hz, suspend sf' y), sf') pSwitch ::@@ -790,48 +868,50 @@ ProcessA a (b, col c) (Event mng) -> (col (ProcessA a ext c) -> mng -> ProcessA a b (col c)) -> ProcessA a b (col c)--pSwitch r sfs test k = ProcessA $ proc (ph, x) ->- do- (ph', zs, sfs') <- parCore r sfs -<< (ph, x)- (phT, evt, test') <- step test -< (ph', (x, zs))-- evMaybePh- (arr $ const (phT, zs, pSwitch r sfs' test' k))- (step . (k sfs') )- (phT, evt)- -<< (ph, x)-+pSwitch r sfs test k = makePA+ (proc x ->+ do+ (hzs, sfs') <- parCore r sfs -<< x+ (hevt, test') <- step' test -< (x,) <$> hzs+ (case helperToMaybe hevt+ of+ Just (Event t) -> (step (k sfs' t))+ _ -> arr $ const (hzs, pSwitch r sfs' test' k))+ -<< x)+ (suspendAll r sfs)+ 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)))+ ProcessA a+ (b, Event (col (ProcessA a ext c) -> col (ProcessA a ext c))) (col c)--rpSwitch r sfs = ProcessA $ proc (ph, (x, evCont)) ->- do- let sfsNew = evMaybePh sfs ($sfs) (ph, evCont)- (ph', ws, sfs') <- parCore r sfsNew -<< (ph, x)- returnA -< (ph' `mappend` Suspend, ws, rpSwitch r sfs')-+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)+ 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)))+ ProcessA a+ (b, Event (col (ProcessA a b c) -> col (ProcessA a b c))) (col c)- rpSwitchB = rpSwitch broadcast -- `dpSwitch` and `drpSwitch` are not implemented.@@ -840,25 +920,6 @@ -- -- Unsafe primitives ------ | Repeatedly call `p`.------ How many times `p` is called is indefinite.--- So `p` must satisfy the equation below;------ @p &&& p === p >>> (id &&& id)@-unsafeSteady ::- ArrowApply a =>- a b c ->- ProcessA a b c-unsafeSteady f =- fitEx- (\id' ->- arr (\(p, x)->((p, ()), x)) >>>- (id' *** f) >>>- arr (\((q, ()), y)->(q, y)))- Cat.id- -- | Repeatedly call `p`. -- @@ -877,16 +938,11 @@ unsafeExhaust p = go >>> fork where- go = ProcessA $ proc (ph, x) -> handle ph -<< x- - handle Suspend =- arr $ const (Suspend, NoEvent, go)-- handle ph = proc x ->- do- ys <- p -< x- let ph' = if nullFd ys then Suspend else Feed- returnA -< (ph `mappend` ph', Event ys, go)+ 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+ } fork = repeatedly $ await >>= Fd.mapM_ yield @@ -974,10 +1030,10 @@ else return False -feed :: +feedR :: Monad m => i -> RM a (Event i) o m Bool-feed x = feed_ (Event x) NoEvent+feedR x = feed_ (Event x) NoEvent {-@@ -993,29 +1049,42 @@ freeze = gets freezeRI -sweep :: +sweepR :: Monad m => RM a i o m o-sweep =+sweepR = do pa <- freeze- fit0 <- gets getFitRI ph <- gets getPhaseRI- x <- if ph == Feed- then gets getInputRI- else gets getPaddingRI+ ri <- get+ case ph of+ Feed ->+ do+ fit0 <- gets getFitRI+ x <- gets getInputRI+ (y, pa') <- lift $ fit0 (feed pa) x+ put $ ri {+ freezeRI = pa',+ getPhaseRI = Sweep+ }+ return y+ Sweep -> + do+ fit0 <- gets getFitRI+ x <- gets getPaddingRI+ (my, pa') <- lift $ fit0 (sweep pa) x+ put $ ri {+ freezeRI = pa',+ getPhaseRI = if isJust my then Sweep else Suspend+ }+ return $ fromMaybe (suspend pa x) my+ Suspend ->+ do+ x <- gets getPaddingRI+ return $ suspend pa x - (ph', y, pa') <- lift $ fit0 (step pa) (ph, x) - ri <- get- put $ ri {- freezeRI = - pa',- getPhaseRI = - if ph' == Feed then Sweep else ph'- }-- return y+ sweepAll :: @@ -1026,7 +1095,7 @@ while_ ((not . (== Suspend)) `liftM` lift (gets getPhaseRI)) $ do- evx <- lift sweep+ evx <- lift sweepR case evx of Event x ->@@ -1065,12 +1134,12 @@ where feedSweep x cont = do- _ <- lift $ feed x+ _ <- lift $ feedR x ((), wer) <- listen $ sweepAll outpre if getContWE wer then cont else return ()- + newtype Builder a = Builder { unBuilder :: forall b. (a -> b -> b) -> b -> b }@@ -1103,9 +1172,14 @@ data ExecInfo fa = ExecInfo {- yields :: fa, -- [a] or Maybe a- hasConsumed :: Bool,- hasStopped :: Bool+ yields :: fa, -- ^ Values yielded while the step.+ hasConsumed :: Bool, -- ^ True if the input value is consumed.+ --+ -- False if the machine has stopped unless consuming the input.+ --+ -- Or in the case of `stepYield`, this field become false when+ -- the machine produces a value unless consuming the input.+ hasStopped :: Bool -- ^ True if the machine has stopped at the end of the step. } deriving (Eq, Show) @@ -1117,18 +1191,17 @@ ExecInfo (y1 <|> y2) (c1 || c2) (s1 || s2) --- | Execute until an input consumed and the machine suspended.+-- | Execute until an input consumed and the machine suspends. stepRun :: ArrowApply a => ProcessA a (Event b) (Event c) -> a b (ExecInfo [c], ProcessA a (Event b) (Event c))- stepRun pa0 = unArrowMonad $ \x -> do (pa, wer) <- runRM arrowMonad pa0 $ runWriterT $ do sweepAll singleton- _ <- lift $ feed x+ _ <- lift $ feedR x sweepAll singleton lift $ freeze return $ (retval wer, pa)@@ -1147,7 +1220,6 @@ ArrowApply a => ProcessA a (Event b) (Event c) -> a b (ExecInfo (Maybe c), ProcessA a (Event b) (Event c))- stepYield pa0 = unArrowMonad $ \x -> runRM arrowMonad pa0 $ evalStateT `flip` mempty $ do go x@@ -1158,10 +1230,10 @@ where go x = do- csmd <- lift $ feed x+ csmd <- lift $ feedR x modify $ \ri -> ri { hasConsumed = csmd } - evo <- lift sweep+ evo <- lift sweepR case evo of@@ -1176,5 +1248,4 @@ End -> modify $ \ri -> ri { hasStopped = True }-
src/Control/Arrow/Machine/Utils.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Arrows #-} {-# LANGUAGE RankNTypes #-}@@ -5,6 +6,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif+ module Control.Arrow.Machine.Utils (@@ -14,8 +21,6 @@ accum, dAccum, edge,- passRecent,- withRecent, -- * Switches -- | Switches inspired by Yampa library.@@ -32,10 +37,6 @@ rpSwitch, rpSwitchB, - -- * State arrow- peekState,- encloseState,- -- * Other utility arrows tee, gather,@@ -49,22 +50,22 @@ parB, now, onEnd,- cycleDelay+ + -- * Transformer+ readerProc ) where import Prelude hiding (filter) -import Data.Maybe (fromMaybe) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Foldable as Fd import qualified Control.Category as Cat import Control.Monad.Trans import Control.Monad.State import Control.Arrow-import Control.Arrow.Operations (ArrowState(..))-import Control.Arrow.Transformer.State (ArrowAddState(..), StateArrow()) import Control.Applicative+import Control.Arrow.Transformer.Reader (ArrowAddReader(..)) import Control.Arrow.Machine.ArrowUtil import Control.Arrow.Machine.Types@@ -95,85 +96,21 @@ ArrowApply a => b -> ProcessA a (Event (b->b)) b dAccum x = dSwitch (pure x &&& arr (($x)<$>)) dAccum + edge :: (ArrowApply a, Eq b) => ProcessA a b (Event b)--edge = encloseState (unsafeExhaust impl) Nothing- where- impl ::- (ArrowApply a, Eq b) =>- StateArrow (Maybe b) a b (Maybe b)- impl = proc x ->- do- mprv <- fetch -< ()- store -< Just x- returnA -<- case mprv- of- Just prv -> if prv == x then Nothing else Just x- Nothing -> Just x--{-# DEPRECATED passRecent, withRecent "Use `hold` instead" #-}-infixr 9 `passRecent`--passRecent :: - (ArrowApply a, Occasional o) =>- ProcessA a (AS e) (Event b) ->- ProcessA a (e, AS b) o ->- ProcessA a (AS e) o--passRecent af ag = proc ase ->- do- evx <- af -< ase- mvx <- hold Nothing -< Just <$> evx- case mvx of- Just x -> ag -< (fromAS ase, toAS x)- _ -> returnA -< noEvent--withRecent :: - (ArrowApply a, Occasional o) =>- ProcessA a (e, AS b) o ->- ProcessA a (e, AS (Event b)) o-withRecent af = proc (e, asevx) ->+edge = proc x -> do- mvx <- hold Nothing -< Just <$> fromAS asevx- case mvx of- Just x -> af -< (e, toAS x)- _ -> returnA -< noEvent------------ State arrow----peekState ::- (ArrowApply a, ArrowState s a) =>- ProcessA a e s-peekState = unsafeSteady fetch---- Should be exported?-exposeState ::- (ArrowApply a, ArrowApply a', ArrowAddState s a a') =>- ProcessA a b c ->- ProcessA a' (b, s) (c, s)-exposeState = fitEx es+ rec+ ev <- unsafeExhaust (arr judge) -< (prv, x)+ prv <- dHold Nothing -< Just x <$ ev+ returnA -< ev where- es f = proc (p, (x, s)) ->- do- ((q, y), s') <- elimState f -< ((p, x), s)- returnA -< (q, (y, s'))+ judge (prv, x) = if prv == Just x then Nothing else Just x -encloseState ::- (ArrowApply a, ArrowApply a', ArrowAddState s a a') =>- ProcessA a b c ->- s ->- ProcessA a' b c-encloseState pa s = loop' s (exposeState pa) + -- -- other utility arrow @@ -294,30 +231,14 @@ where go = repeatedly $ await `catchP` (yield () >> stop)- --- |Observe a previous value of a signal.--- Tipically used with rec statement. -{-# DEPRECATED cycleDelay "Simply use `dHold` or `dAccum`" #-}-cycleDelay ::- ArrowApply a => ProcessA a b b-cycleDelay =- encloseState impl (Nothing, Nothing)+-- | Run reader of base arrow.+readerProc ::+ (ArrowApply a, ArrowApply a', ArrowAddReader r a a') =>+ ProcessA a b c ->+ ProcessA a' (b, r) c+readerProc pa = arr swap >>> fitW snd (\ar -> arr swap >>> elimReader ar) pa where- impl :: ArrowApply a => ProcessA (StateArrow (Maybe b, Maybe b) a) b b- impl = proc x ->- do- -- Load stored value when backtracking reaches here.- (_, stored) <- peekState -< ()- unsafeExhaust (app >>> arr (const Nothing)) -< appStore stored-- -- Repeat current value.- (current, _) <- peekState -< ()- let x0 = fromMaybe x current- unsafeSteady store -< (Just x0, Just x)- returnA -< x0-- appStore (Just x) = (proc _ -> store -< (Just x, Nothing), ())- appStore _ = (Cat.id, ())- + swap :: (a, b) -> (b, a)+ swap ~(a, b) = (b, a)
test/LoopUtil.hs view
@@ -14,6 +14,10 @@ import Control.Monad.Trans (liftIO) import qualified Control.Arrow.Machine.Misc.Pump as Pump +import Data.Monoid (Endo(Endo), mappend, appEndo)++newtype Duct a = Duct (Endo [a])+ doubler = arr (fmap $ \x -> [x, x]) >>> P.fork loopUtil =@@ -35,22 +39,6 @@ ret <- liftIO $ runKleisli (P.run pa) [1, 2, 3] ret `shouldBe` [0, 1+1, 1+1+2+2] - describe "cycleDelay" $- do- it "can refer a recent value at downstream." $- do- let - pa :: ProcessA (Kleisli IO) (Event Int) (Event Int)- pa = proc evx ->- do- rec- y <- P.cycleDelay -< r2- anytime (Kleisli putStr) -< "" <$ evx -- side effect- evx2 <- doubler -< evx- r2 <- P.accum 0 -< (+) <$> evx2- returnA -< y <$ evx- ret <- liftIO $ runKleisli (P.run pa) [1, 2, 3]- ret `shouldBe` [0, 1+1, 1+1+2+2] describe "Pump" $ do it "pumps up an event stream." $@@ -60,12 +48,13 @@ pa = proc evx -> do rec- evOut <- Pump.outlet -< (dct, () <$ evx)- anytime (Kleisli putStr) -< "" <$ evx -- side effect- so <- doubler -< evx- dct <- Pump.intake -< (so, () <$ evx)+ evOut <- Pump.outlet -< (dct, () <$ evx)+ anytime (Kleisli putStr) -< "" <$ evx -- side effect+ so <- doubler -< evx+ dct <- Pump.intake -< (so, () <$ evx) returnA -< evOut ret <- liftIO $ runKleisli (P.run pa) [4, 5, 6] ret `shouldBe` [4, 4, 5, 5, 6, 6]- ++