machinecell 1.1.1 → 1.2.0
raw patch · 12 files changed
+388/−86 lines, 12 filesdep +arrowsPVP ok
version bump matches the API change (PVP)
Dependencies added: arrows
API changes (from Hackage documentation)
- Control.Arrow.Machine.Plan: instance [overlap ok] Functor (PlanF i o)
- Control.Arrow.Machine.Plan: instance [overlap ok] Monad m => MonadPlus (FreeT (PlanF i o) m)
+ Control.Arrow.Machine.ArrowUtil: elimR :: ArrowAddReader r a a' => a (AS e) b -> a' (e, AS r) b
+ Control.Arrow.Machine.ArrowUtil: fromAS :: AS e -> e
+ Control.Arrow.Machine.ArrowUtil: reading :: (Monad m, Arrow a) => (forall p q. (p -> m q) -> a p q) -> (b -> ReaderT r m c) -> ReaderArrow r a b c
+ Control.Arrow.Machine.ArrowUtil: toAS :: e -> AS e
+ Control.Arrow.Machine.ArrowUtil: type AS e = e
+ Control.Arrow.Machine.Core: data ProcessA a b c
+ Control.Arrow.Machine.Core: fit :: (Arrow a, Arrow a') => (forall p q. a p q -> a' p q) -> ProcessA a b c -> ProcessA a' b c
+ Control.Arrow.Machine.Exception: bracket :: Monad m => PlanT i o m a -> (a -> PlanT i o m b) -> (a -> PlanT i o m c) -> PlanT i o m c
+ Control.Arrow.Machine.Exception: bracketOnError :: Monad m => PlanT i o m a -> (a -> PlanT i o m b) -> (a -> PlanT i o m c) -> PlanT i o m c
+ Control.Arrow.Machine.Exception: bracket_ :: Monad m => PlanT i o m a -> PlanT i o m b -> PlanT i o m c -> PlanT i o m c
+ Control.Arrow.Machine.Exception: catch :: Monad m => PlanT i o m a -> PlanT i o m a -> PlanT i o m a
+ Control.Arrow.Machine.Exception: finally :: Monad m => PlanT i o m a -> PlanT i o m b -> PlanT i o m a
+ Control.Arrow.Machine.Exception: handle :: Monad m => PlanT i o m a -> PlanT i o m a -> PlanT i o m a
+ Control.Arrow.Machine.Exception: onException :: Monad m => PlanT i o m a -> PlanT i o m b -> PlanT i o m a
+ Control.Arrow.Machine.Types: instance (ArrowApply a, ArrowApply a', ArrowAddReader r a a') => ArrowAddReader r (ProcessA a) (ProcessA a')
+ Control.Arrow.Machine.Types: instance (ArrowApply a, ArrowReader r a) => ArrowReader r (ProcessA a)
- Control.Arrow.Machine.Plan: stop :: Plan i o ()
+ Control.Arrow.Machine.Plan: stop :: Plan i o a
- Control.Arrow.Machine.Types: parStep :: (Arrow t, Arrow a, Monoid t4) => t (t2, t1) (t4, t5, a b c) -> t (t2, t3) (t4, t6, a b' c') -> t (t2, (t1, t3)) (t4, (t5, t6), a (b, b') (c, c'))
+ Control.Arrow.Machine.Types: parStep :: (Monoid t4, Arrow t, Arrow a) => t (t2, t1) (t4, t5, a b c) -> t (t2, t3) (t4, t6, a b' c') -> t (t2, (t1, t3)) (t4, (t5, t6), a (b, b') (c, c'))
- Control.Arrow.Machine.Utils: feedback :: (ArrowApply a, Occasional d) => ProcessA a (e, d) b -> ProcessA a (e, b) (c, d) -> ProcessA a e c
+ Control.Arrow.Machine.Utils: feedback :: (ArrowApply a, Occasional d) => ProcessA a (e, AS d) b -> ProcessA a (e, AS b) (c, d) -> ProcessA a (AS e) c
- Control.Arrow.Machine.Utils: feedback1 :: (ArrowApply a, Occasional d) => ProcessA a (e, d) (c, d) -> ProcessA a e c
+ Control.Arrow.Machine.Utils: feedback1 :: (ArrowApply a, Occasional d) => ProcessA a (e, AS d) (c, d) -> ProcessA a (AS e) c
- Control.Arrow.Machine.Utils: passRecent :: (ArrowApply a, Occasional o) => ProcessA a e (Event b) -> ProcessA a (e, b) o -> ProcessA a e o
+ Control.Arrow.Machine.Utils: passRecent :: (ArrowApply a, Occasional o) => ProcessA a (AS e) (Event b) -> ProcessA a (e, AS b) o -> ProcessA a (AS e) o
- Control.Arrow.Machine.Utils: withRecent :: (ArrowApply a, Occasional o) => ProcessA a (e, b) o -> ProcessA a (e, Event b) o
+ Control.Arrow.Machine.Utils: withRecent :: (ArrowApply a, Occasional o) => ProcessA a (e, AS b) o -> ProcessA a (e, AS (Event b)) o
Files
- CHANGELOG.md +7/−0
- machinecell.cabal +5/−5
- src/Control/Arrow/Machine.hs +2/−0
- src/Control/Arrow/Machine/ArrowUtil.hs +56/−1
- src/Control/Arrow/Machine/Core.hs +40/−0
- src/Control/Arrow/Machine/Event.hs +3/−0
- src/Control/Arrow/Machine/Exception.hs +98/−0
- src/Control/Arrow/Machine/Plan.hs +65/−40
- src/Control/Arrow/Machine/Plan/Internal.hs +23/−0
- src/Control/Arrow/Machine/Types.hs +40/−0
- src/Control/Arrow/Machine/Utils.hs +34/−32
- test/spec.hs +15/−8
CHANGELOG.md view
@@ -1,3 +1,10 @@+1.2.0+------------+* Support of `ArrowReader`.+* Added await fail handling.+* Improved performance by church-encoded free monads.+* Arrow stack of newest GHC support for some utilities.+ 1.1.1 ------------ * Eliminated banana brackets to support newest GHC.
machinecell.cabal view
@@ -1,5 +1,5 @@ name: machinecell-version: 1.1.1+version: 1.2.0 synopsis: Arrow based stream transducers license: BSD3 license-file: LICENSE@@ -21,10 +21,10 @@ AFRP-like utilities are also available. library- exposed-modules: Control.Arrow.Machine, Control.Arrow.Machine.Event, Control.Arrow.Machine.Plan, Control.Arrow.Machine.Types, Control.Arrow.Machine.Utils, Control.Arrow.Machine.Running, Control.Arrow.Machine.ArrowUtil- other-modules: Control.Arrow.Machine.Event.Internal+ exposed-modules: Control.Arrow.Machine, Control.Arrow.Machine.Event, Control.Arrow.Machine.Plan, Control.Arrow.Machine.Types, Control.Arrow.Machine.Utils, Control.Arrow.Machine.Running, Control.Arrow.Machine.ArrowUtil, Control.Arrow.Machine.Exception, Control.Arrow.Machine.Core+ other-modules: Control.Arrow.Machine.Event.Internal, Control.Arrow.Machine.Plan.Internal other-extensions: FlexibleInstances, Arrows, RankNTypes, TypeSynonymInstances, MultiParamTypeClasses, GADTs, FlexibleContexts, NoMonomorphismRestriction, RecursiveDo- build-depends: base >=4.0 && < 5.0, mtl >=2.0, free >=3.0 && < 5.0, profunctors >=3.0+ build-depends: base >=4.0 && < 5.0, mtl >=2.0, free >=3.0 && < 5.0, profunctors >=3.0, arrows >= 0.4 hs-source-dirs: src default-language: Haskell2010 @@ -44,4 +44,4 @@ source-repository this type: git location: https://github.com/as-capabl/machinecell.git- tag: release-1.1.1+ tag: release-1.2.0
src/Control/Arrow/Machine.hs view
@@ -11,6 +11,7 @@ module Control.Arrow.Machine.Event, module Control.Arrow.Machine.Utils, module Control.Arrow.Machine.Plan, + module Control.Arrow.Machine.Exception, module Control.Arrow.Machine.Running, module Control.Arrow.Machine.ArrowUtil, @@ -23,6 +24,7 @@ import Control.Arrow.Machine.Event import Control.Arrow.Machine.Utils import Control.Arrow.Machine.Plan +import Control.Arrow.Machine.Exception import Control.Arrow.Machine.Running import Control.Arrow.Machine.ArrowUtil
src/Control/Arrow/Machine/ArrowUtil.hs view
@@ -1,18 +1,58 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Arrows #-} ++-- | Arrow utilities not related to machinecell library. module Control.Arrow.Machine.ArrowUtil (+ -- * Arrow construction helper kleisli, kleisli0, kleisli2, kleisli3, kleisli4,- kleisli5+ kleisli5,++ reading,++ -- * To absorve arrow stack signature difference bettween ghc 7.8 and older.+ AS,+ toAS,+ fromAS,++ elimR ) where import Control.Arrow+import Control.Arrow.Operations (readState)+import Control.Arrow.Transformer.Reader+import Control.Monad.Reader (ReaderT, runReaderT) +#if __GLASGOW_HASKELL__ >= 708 +type AS e = (e, ())++toAS :: e -> AS e+toAS e = (e, ())++fromAS :: AS e -> e+fromAS = fst++#else++type AS e = e++toAS :: e -> AS e+toAS = id++fromAS :: AS e -> e+fromAS = id++#endif++ kleisli :: Monad m => (a->m b) -> Kleisli m a b kleisli = Kleisli @@ -32,3 +72,18 @@ kleisli5 fmx = Kleisli $ \(x1, x2, x3, x4, x5) -> fmx x1 x2 x3 x4 x5 +reading :: + (Monad m, Arrow a) => + (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)++-- |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/Core.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}+++{-|+Extracted stuff to be used unqualified from ../Machine.hs.+-}+module+ Control.Arrow.Machine.Core+ (+ -- * Modules+ module Control.Arrow.Machine.Event, +-- module Control.Arrow.Machine.Utils,+ module Control.Arrow.Machine.Plan,+-- module Control.Arrow.Machine.Exception,+ 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.Exception+import Control.Arrow.Machine.Running+import qualified Control.Arrow.Machine.Running as Running+-- import Control.Arrow.Machine.ArrowUtil++import Control.Arrow.Machine.Types+import Control.Arrow++
src/Control/Arrow/Machine/Event.hs view
@@ -14,6 +14,9 @@ evMaybe, fromEvent, evMap,++ -- * Deprecated+ -- | To be renamed. split, join, split2,
+ src/Control/Arrow/Machine/Exception.hs view
@@ -0,0 +1,98 @@+++module+ Control.Arrow.Machine.Exception+ (+ catch,+ handle,+ bracket,+ bracket_,+ bracketOnError,+ finally,+ onException+ )+where++import qualified Control.Monad.Trans.Free as F+import qualified Control.Monad.Trans.Free.Church as F++import Data.Functor ((<$>))++import Control.Arrow.Machine.Types+import Control.Arrow.Machine.Event+import Control.Arrow.Machine.Event.Internal (Event(..))++import Control.Arrow.Machine.Plan.Internal+import Control.Arrow.Machine.Plan++import Debug.Trace+++catch :: Monad m =>+ PlanT i o m a -> PlanT i o m a -> PlanT i o m a++catch pl cont = + F.toFT $ catch' (F.fromFT pl) (F.fromFT cont)++catch' (F.FreeT mf) cont@(F.FreeT mcont) = + F.FreeT $ mf >>= go+ where+ go (F.Pure a) = return $ F.Pure a+ go (F.Free StopPF) = mcont+ go (F.Free (AwaitPF f ff)) = + return $ F.Free $ + AwaitPF (\i -> f i `catch'` cont) (ff `catch'` cont)+ go (F.Free fft) = + return $ F.Free $ (`catch'` cont) <$> fft++handle :: Monad m =>+ PlanT i o m a -> PlanT i o m a -> PlanT i o m a++handle = flip catch+++bracket :: Monad m =>+ PlanT i o m a -> (a -> PlanT i o m b)-> (a -> PlanT i o m c) -> PlanT i o m c+bracket before after thing =+ do+ a <- before+ r <- thing a `catch` (after a >> stop)+ _ <- after a+ return r+++bracket_ :: Monad m =>+ PlanT i o m a -> PlanT i o m b-> PlanT i o m c -> PlanT i o m c+bracket_ before after thing =+ do+ before+ r <- thing `catch` (after >> stop)+ _ <- after+ return r+++bracketOnError :: Monad m =>+ PlanT i o m a -> (a -> PlanT i o m b)-> (a -> PlanT i o m c) -> PlanT i o m c+bracketOnError before after thing =+ do+ a <- before+ r <- thing a `catch` (after a >> stop)+ return r+++finally :: Monad m =>+ PlanT i o m a -> PlanT i o m b-> PlanT i o m a+finally thing after =+ do+ r <- thing `catch` (after >> stop)+ _ <- after+ return r+++onException :: Monad m =>+ PlanT i o m a -> PlanT i o m b-> PlanT i o m a+onException thing after =+ do+ thing `catch` (after >> stop)+ +
src/Control/Arrow/Machine/Plan.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-|@@ -33,6 +32,7 @@ import qualified Control.Category as Cat import qualified Control.Monad.Trans.Free as F+import qualified Control.Monad.Trans.Free.Church as F import Data.Monoid (mappend) import Data.Functor ((<$>))@@ -45,48 +45,24 @@ import Control.Arrow.Machine.Event import Control.Arrow.Machine.Event.Internal (Event(..)) +import Control.Arrow.Machine.Plan.Internal+ 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--instance - Monad m => MonadPlus (F.FreeT (PlanF i o) m)- where- mzero = stop >> return undefined- (F.FreeT mf) `mplus` cont@(F.FreeT mcont) = - F.FreeT $ mf >>= go- where- go (F.Pure a) = mcont >>= return- go (F.Free (StopPF ft)) = mcont >>= return- go (F.Free fft) = return $ F.Free $ (`mplus` cont) <$> fft- 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+await = F.FT $ \pure free -> free (AwaitPF pure (free StopPF)) -stop :: Plan i o ()-stop = F.liftF $ StopPF ()+stop :: Plan i o a+stop = F.liftF $ StopPF @@ -98,16 +74,60 @@ PlanT i o m r -> ProcessA a (Event i) (Event o) -constructT fit pl = ProcessA $ proc (ph, evx) ->+constructT fit pl = ProcessA $ fit' $ F.runFT pl pure free+ where+ fit' ma = proc arg -> do { (evx, pa) <- fit ma -< (); modFit evx pa -<< arg }+ + modFit :: ArrowApply a => Event c -> StepType a b (Event c) -> StepType a b (Event c)+ modFit (Event x) stp = retArrow Feed (Event x) (ProcessA stp)+ modFit _ stp = stp++ retArrow ph' evx cont = arr $ \(ph, _) -> + case ph of+ Suspend -> + (ph `mappend` Suspend, NoEvent, ProcessA $ retArrow ph' evx cont)+ _ -> + (ph `mappend` ph', evx, cont)++ pure _ = return $ (End, retArrow Suspend End stopped)++ free (AwaitPF f ff) =+ do+ return $ (NoEvent, arr (uncurry (awaitIt f ff)) >>> proc pc -> pc -<< ())++ free (YieldPF y fc) = return $ (Event y, fit' fc)++ free StopPF = return $ (End, retArrow Suspend End stopped)+++ awaitIt f _ Feed (Event x) = proc _ ->+ do+ (evy, stp) <- fit (f x) -< ()+ returnA -< (Feed, evy, ProcessA stp)++ awaitIt _ ff Feed End = proc _ ->+ do+ (evy, stp) <- fit ff -< ()+ returnA -< (Feed, evy, ProcessA stp)++ awaitIt _ ff Sweep End = proc _ ->+ do+ (evy, stp) <- fit ff -< ()+ returnA -< (if isOccasion evy then Feed else Suspend, evy, ProcessA stp)++ awaitIt f ff ph evx = proc _ ->+ returnA -< (ph `mappend` Suspend, NoEvent, + ProcessA $ arr (uncurry (awaitIt f ff)) >>> proc pc -> pc -<< ())++{-+ProcessA $ proc (ph, evx) -> do probe ph pl -<< evx - where-- feedTo f = proc x ->+ runAndYield fx = proc _ -> do- ff2 <- fit (F.runFreeT (f x)) -<< ()+ ff2 <- fit (F.runFreeT fx) -<< () oneYieldPF fit Feed ff2 -<< () probe Suspend pl = proc _ ->@@ -118,11 +138,16 @@ pfr <- fit (F.runFreeT pl) -< () go ph pfr -<< evx - go Feed (F.Free (AwaitPF f)) = arr (\evx -> ((), evx)) >>>- hEv' (arr snd >>> feedTo f) (arr $ const (Feed, NoEvent, constructT fit (await_ f))) (arr $ const (Feed, End, stopped))+ go Feed (F.Free (AwaitPF f ff)) = arr (\evx -> ((), evx)) >>>+ hEv' (proc (_, x) -> runAndYield (f x) -<< ()) + (arr $ const (Feed, NoEvent, constructT fit (await_ f))) + (proc _ -> runAndYield ff -<< ()) go ph pfr = proc evx ->- oneYieldPF fit ph pfr -< ()+ do+ let action = case (evx, pfr) of {(End, F.Free (AwaitPF _ ff)) -> ff; _ -> F.FreeT $ return pfr}+ pfr' <- fit (F.runFreeT action) -<< ()+ oneYieldPF fit ph pfr' -<< () oneYieldPF :: (Monad m, ArrowApply a) => @@ -139,7 +164,7 @@ oneYieldPF f ph (F.Free (YieldPF x cont)) = proc _ -> returnA -< (Feed, Event x, constructT f cont) -oneYieldPF f ph (F.Free (StopPF cont)) = proc _ ->+oneYieldPF f ph (F.Free StopPF) = proc _ -> returnA -< (ph `mappend` Suspend, End, stopped) oneYieldPF f ph (F.Free pf) = proc _ ->@@ -149,7 +174,7 @@ oneYieldPF f ph (F.Pure x) = proc _ -> returnA -< (ph `mappend` Suspend, End, stopped)-+-} repeatedlyT :: (Monad m, ArrowApply a) => (forall b. m b -> a () b) ->
+ src/Control/Arrow/Machine/Plan/Internal.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}++module+ Control.Arrow.Machine.Plan.Internal+where++import qualified Control.Monad.Trans.Free as F+import qualified Control.Monad.Trans.Free.Church as F++data PlanF i o a where+ AwaitPF :: (i->a) -> a -> PlanF i o a+ YieldPF :: o -> a -> PlanF i o a+ StopPF :: PlanF i o a++instance (Functor (PlanF i o)) where+ fmap g (AwaitPF f ff) = AwaitPF (g . f) (g ff)+ fmap g (YieldPF x r) = YieldPF x (g r)+ fmap g StopPF = StopPF+++type PlanT i o m a = F.FT (PlanF i o) m a+type Plan i o a = forall m. Monad m => PlanT i o m a
src/Control/Arrow/Machine/Types.hs view
@@ -1,6 +1,10 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+ module Control.Arrow.Machine.Types -- This file includes internals. Export definitions is at ../Machine.hs@@ -9,6 +13,8 @@ import qualified Control.Category as Cat import Data.Monoid (Monoid(..)) import Data.Profunctor (Profunctor, dimap)+import Control.Arrow.Operations (ArrowReader(..))+import Control.Arrow.Transformer.Reader (ReaderArrow, runReader, ArrowAddReader(..)) import Control.Arrow @@ -183,3 +189,37 @@ returnA -< ((ph', y, loop pa'), 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 pa = ProcessA $ proc (ph, (e, r)) ->+ do+ (ph', y, pa') <- newReader (step pa) -< ((ph, e), r)+ returnA -< (ph', y, newReader pa')++instance+ (ArrowApply a, ArrowApply a', ArrowAddReader r a a') =>+ ArrowAddReader r (ProcessA a) (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+ where+ pre (ph, (x, r)) = ((ph, x), r)+ post (ph, x, pra') = (ph, x, elimReader pra')+{-+ elimReader pra = ProcessA $ proc (ph, (x, r)) ->+ do+ (ph', y, pra') <- (| elimReader (step pra -< (ph, x)) |) r+ returnA -< (ph', y, elimReader pra')+-}
src/Control/Arrow/Machine/Utils.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GADTs #-}+ module Control.Arrow.Machine.Utils (@@ -57,28 +57,32 @@ import Control.Monad (liftM, forever) import Control.Monad.Trans import Control.Arrow+import Control.Arrow.Transformer.Reader (ReaderArrow, runReader) import Control.Applicative import Debug.Trace import Control.Arrow.Machine.Types import Control.Arrow.Machine.Event import Control.Arrow.Machine.Event.Internal (Event(..))+import Control.Arrow.Machine.ArrowUtil import qualified Control.Arrow.Machine.Plan as Pl-+import Control.Arrow.Machine.Exception delay :: (ArrowApply a, Occasional b) => ProcessA a b b+ delay = join >>> delayImpl >>> split where delayImpl = Pl.repeatedly $ do- x <- Pl.await+ mx <- liftM Just Pl.await `catch` return Nothing Pl.yield noEvent- Pl.yield x+ maybe Pl.stop Pl.yield mx + hold :: ArrowApply a => b -> ProcessA a (Event b) b {-@@ -120,28 +124,27 @@ passRecent :: (ArrowApply a, Occasional o) =>- ProcessA a e (Event b) ->- ProcessA a (e, b) o ->- ProcessA a e o+ ProcessA a (AS e) (Event b) ->+ ProcessA a (e, AS b) o ->+ ProcessA a (AS e) o -passRecent af ag = proc e ->+passRecent af ag = proc ase -> do- evx <- af -< e+ evx <- af -< ase mvx <- hold Nothing -< Just <$> evx case mvx of- Just x -> ag -< (e, x)+ Just x -> ag -< (fromAS ase, toAS x) _ -> returnA -< noEvent --- No use for banana brackets since ghc 7.8.1 withRecent :: (ArrowApply a, Occasional o) =>- ProcessA a (e, b) o ->- ProcessA a (e, Event b) o-withRecent af = proc (e, evx) ->+ ProcessA a (e, AS b) o ->+ ProcessA a (e, AS (Event b)) o+withRecent af = proc (e, asevx) -> do- mvx <- hold Nothing -< Just <$> evx+ mvx <- hold Nothing -< Just <$> fromAS asevx case mvx of- Just x -> af -< (e, x)+ Just x -> af -< (e, toAS x) _ -> returnA -< noEvent @@ -151,15 +154,15 @@ -- So be careful to make an infinite loop. feedback1 :: (ArrowApply a, Occasional d) =>- ProcessA a (e, d) (c, d) ->- ProcessA a e c-feedback1 pa = ProcessA $ proc (ph, e) ->+ ProcessA a (e, AS d) (c, d) ->+ ProcessA a (AS e) c+feedback1 pa = ProcessA $ proc (ph, ase) -> do- (ph', (y, d), pa') <- step pa -< (ph, (e, noEvent))+ (ph', (y, d), pa') <- step pa -< (ph, (fromAS ase, toAS noEvent)) returnA -< (ph', y, cont ph' d pa') where cont phPrev d paC - | isOccasion d = ProcessA $ proc (ph, e) ->+ | isOccasion d = ProcessA $ proc (ph, ase) -> do let (dIn, dOut, phPv2, phCur) = @@ -169,13 +172,13 @@ else (d, id, id, ph `mappend` Feed) - (ph', (y, d'), pa') <- step paC -< (phCur, (e, dIn))+ (ph', (y, d'), pa') <- step paC -< (phCur, (fromAS ase, toAS dIn)) returnA -< (ph', y, cont (phPv2 ph') (dOut d') pa') - | isEnd d && phPrev == Feed = ProcessA $ proc (ph, e) ->+ | isEnd d && phPrev == Feed = ProcessA $ proc (ph, ase) -> do- (ph', (y, _), pa') <- step pa -< (ph, (e, end))- returnA -< (ph', y, proc x -> arr fst <<< pa' -< (x, end))+ (ph', (y, _), pa') <- step paC -< (ph, (fromAS ase, toAS end))+ returnA -< (ph', y, proc asx -> arr fst <<< pa' -< (fromAS asx, toAS end)) | otherwise = feedback1 paC @@ -184,14 +187,14 @@ -- rather than banana brackets. feedback :: (ArrowApply a, Occasional d) =>- ProcessA a (e, d) b ->- ProcessA a (e, b) (c, d) ->- ProcessA a e c+ ProcessA a (e, AS d) b ->+ ProcessA a (e, AS b) (c, d) ->+ ProcessA a (AS e) c feedback pa pb = - feedback1 $ proc (e, x) -> + feedback1 $ proc (ase, x) -> do - y <- pa -< (e, x)- pb -< (e, y)+ y <- pa -< (ase, x)+ pb -< (ase, toAS y) --@@ -389,7 +392,6 @@ (col c) rpSwitchB = rpSwitch broadcast- -- -- other utility arrow
test/spec.hs view
@@ -324,7 +324,19 @@ result = run (repeatedly pl) l result `shouldBe` [2, 3, 5, 6, 10, 11, 20, 21, 100, 101] + it "can handle the end with catch." $ + do + let pl2 = + do + x <- await `catch` (yield 1 >> stop) + yield x + y <- await + yield y + run (construct pl2) [] `shouldBe` [1] + run (construct pl2) [3] `shouldBe` [3] + run (construct pl2) [3, 2] `shouldBe` [3, 2] + utility = do describe "delay" $ @@ -438,8 +450,6 @@ do it "acts like local variable with hold." $ do - pendingWith "Arrow statement with argument broken." -{- let pa = proc evx -> do @@ -448,19 +458,16 @@ do returnA -< ((+y) <$> evx, (y+1) <$ evx) run pa [1, 2, 3] `shouldBe` [11, 13, 15] --} + it "correctly handles stream end." $ do - pendingWith "Arrow statement with argument broken." -{- let pa = proc x -> - (\x -> returnA -< x) + (\asx -> returnA -< asx) `feedback` - (\y -> returnA -< (y::Event Int, x)) + (\asy -> returnA -< (asy::Event Int, x)) comp = mkProc (PgPush PgStop) >>> pa stateProc comp [0, 0] `shouldBe` ([], [0]) --} it "correctly handles stream end.(2)" $ do