machinecell 3.2.0 → 3.3.0

raw patch · 5 files changed

+148/−114 lines, 5 filesdep +transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• machinecell.cabal +3/−3
• src/Control/Arrow/Machine/Types.hs +100/−106
• src/Control/Arrow/Machine/Utils.hs +18/−4
• test/spec.hs +19/−1

@@ -1,4 +1,12 @@ +3.3.0+----------+* Correct a space leak problem+* Add `splitEvent`, `oneshot`+* Generalize some functions+    * construct, repeatedly+    * filterEvent, filterJust, filterLeft, filterRight+ 3.2.0 ---------- * Add arrow-tr flag

@@ -1,5 +1,5 @@ name:                machinecell-version:             3.2.0+version:             3.3.0 synopsis:            Arrow based stream transducers license:             BSD3 license-file:        LICENSE@@ -39,7 +39,7 @@         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, semigroups >=0.8.3.1, profunctors >=4.0+  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, transformers   hs-source-dirs:      src   default-language:    Haskell2010 @@ -62,4 +62,4 @@ source-repository this   type:		git   location:	https://github.com/as-capabl/machinecell.git-  tag:		release-3.2.0+  tag:		release-3.3.0

@@ -31,6 +31,7 @@         filterJust,         filterLeft,         filterRight,+        splitEvent,         evMap,          -- * Coroutine monad@@ -103,10 +104,11 @@ import Control.Arrow import Control.Monad import Control.Monad.Trans-import Control.Monad.State+import Control.Monad.State.Strict import Control.Monad.Reader import Control.Monad.Writer hiding ((<>)) import Control.Monad.Identity+import Control.Monad.Trans.Cont (ContT(..), evalContT, callCC) import Control.Applicative import Data.Foldable as Fd import Data.Traversable as Tv@@ -588,22 +590,40 @@ condEvent True ev = ev condEvent False _ = NoEvent -filterEvent :: (a -> Bool) -> Event a -> Event a-filterEvent cond ev@(Event x) = condEvent (cond x) ev-filterEvent _ ev = ev+filterEvent ::+    Arrow ar =>+    (a -> Bool) ->+    ar (Event a) (Event a)+filterEvent cond = filterJust <<< evMap mcond+  where+    mcond x+        | cond x = Just x+        | otherwise = Nothing -filterJust :: Event (Maybe a) -> Event a-filterJust (Event (Just x)) = Event x-filterJust (Event Nothing) = NoEvent-filterJust NoEvent = NoEvent-filterJust End = End+filterJust ::+    Arrow ar => ar (Event (Maybe a)) (Event a)+filterJust = arr filterJust'+  where+    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))+filterLeft ::+    Arrow ar =>+    ar (Event (Either a b)) (Event a)+filterLeft = filterJust <<< evMap (either Just (const Nothing)) -filterRight :: Event (Either a b) -> Event b-filterRight = filterJust . fmap (either (const Nothing) Just)+filterRight ::+    Arrow ar =>+    ar (Event (Either a b)) (Event b)+filterRight = filterJust <<< evMap (either (const Nothing) Just) +splitEvent ::+    Arrow ar =>+    ar (Event (Either a b)) (Event a, Event b)+splitEvent = filterLeft &&& filterRight+ -- | Alias of "arr . fmap" -- -- While "ProcessA a (Event b) (Event c)" means a transducer from b to c,@@ -796,19 +816,19 @@               PlanT i o m r ->               ProcessA a (Event i) (Event o) -repeatedlyT f pl = constructT f $ forever pl+repeatedlyT f = constructT f . forever   -- for pure construct :: ArrowApply a =>-             Plan i o t ->+             PlanT i o Identity r ->              ProcessA a (Event i) (Event o)-construct pl = constructT (ary0 unArrowMonad) pl+construct = constructT (arr . const . runIdentity)  repeatedly :: ArrowApply a =>-              Plan i o t ->+              PlanT i o Identity r ->               ProcessA a (Event i) (Event o)-repeatedly pl = construct $ forever pl+repeatedly = construct . forever   --@@ -1158,42 +1178,16 @@ -- -- Running -------- Utilities----while_ ::-    Monad m =>-    m Bool -> m a -> m ()-while_ cond body =-  do-    b <- cond-    if b-        then body >> while_ cond body-        else return () --- | Monoid wrapper-data WithEnd r = WithEnd {-    getRWE :: r,-    getContWE :: !Bool-  }--instance-    Monoid r => Monoid (WithEnd r)-  where-    mempty = WithEnd mempty True-    WithEnd x True `mappend` WithEnd y b = WithEnd (x `mappend` y) b-    mx@(WithEnd _ False) `mappend` _ = mx-- -- -- Running Monad (To be exported) -- data RunInfo a i o m = RunInfo {-    freezeRI :: ProcessA a i o,-    getInputRI :: i,-    getPaddingRI :: i,-    getPhaseRI :: Phase,-    getFitRI :: forall p q. a p q -> p -> m q+    freezeRI :: !(ProcessA a i o),+    getInputRI :: !i,+    getPaddingRI :: !i,+    getPhaseRI :: !Phase,+    getFitRI :: !(forall p q. a p q -> p -> m q)   }  type RM a i o m = StateT (RunInfo a i o m) m@@ -1217,8 +1211,8 @@   feed_ ::-    Monad m =>-    i -> i -> RM a i o m Bool+    (Monad m, MonadState (RunInfo a i o m') m) =>+    i -> i -> m Bool feed_ input padding =   do     ph <- gets getPhaseRI@@ -1236,24 +1230,16 @@             return False  feedR ::-    Monad m =>-    i -> RM a (Event i) o m Bool+    (Monad m, MonadState (RunInfo a (Event i) o m') m) =>+    i -> m Bool feedR x = feed_ (Event x) NoEvent  -{--finalizeE ::-    Monad m =>-    RM a (Event i) o m Bool-finalizeE = feed_ End End--}- freeze ::     Monad m =>     RM a i o m (ProcessA a i o) freeze = gets freezeRI - sweepR ::     Monad m =>     RM a i o m o@@ -1289,28 +1275,34 @@             return $ suspend pa x  --- sweepAll ::     (ArrowApply a, Monoid r, Monad m) =>     (o->r) ->-    WriterT (WithEnd r) (RM a i (Event o) m) ()+    ContT Bool (StateT r (RM a i (Event o) m)) () sweepAll outpre =-        while_-            ((not . (== Suspend)) `liftM` lift (gets getPhaseRI)) $-          do-            evx <- lift sweepR-            case evx-              of-                Event x ->-                    tell (WithEnd (outpre x) True)-                NoEvent ->-                    return ()-                End ->-                    tell (WithEnd mempty False)+    callCC $ \sus -> forever $ cond sus >> body+  where+    cond sus =+      do+        ph <- lift $ lift $ gets getPhaseRI+        if ph == Suspend then sus () else return ()+    body =+      do+        evx <- lift $ lift $ sweepR+        case evx+          of+            Event x ->+              do+                lift $ modify' (`mappend` outpre x)+            NoEvent ->+                return ()+            End ->+                breakCont False +breakCont :: Monad m => r -> ContT r m a+breakCont = ContT . const . return + -- | Run a machine with results concatenated in terms of a monoid. runOn ::     (ArrowApply a, Monoid r, Fd.Foldable f) =>@@ -1318,31 +1310,27 @@     ProcessA a (Event b) (Event c) ->     a (f b) r runOn outpre pa0 = unArrowMonad $ \xs ->-  do-    wer <- runRM arrowMonad pa0 $ execWriterT $+    runRM arrowMonad pa0 $ execStateT `flip` mempty $       do-        -- Sweep initial events.-        (_, wer) <- listen $ sweepAll outpre+        _ <- evalContT $+          do+            -- Sweep initial events.+            sweepAll outpre -        -- Feed inputs.-        if getContWE wer-          then-            Fd.foldr feedSweep (return ()) xs-          else-            return ()+            -- Feed values+            mapM_ feedSweep xs +            return True+         -- Terminate.-        _ <- lift (feed_ End End)-        sweepAll outpre-    return $ getRWE wer+        _ <- lift $ feed_ End End+        evalContT $ sweepAll outpre >> return True    where-    feedSweep x cont =+    feedSweep x =       do-        _ <- lift $ feedR x-        ((), wer) <- listen $ sweepAll outpre-        if getContWE wer then cont else return ()-+        _ <- lift $ lift $ feedR x+        sweepAll outpre   newtype Builder a = Builder {@@ -1403,21 +1391,27 @@     a b (ExecInfo [c], ProcessA a (Event b) (Event c)) stepRun pa0 = unArrowMonad $ \x ->   do-    (pa, wer)  <- runRM arrowMonad pa0 $ runWriterT $+    ((csmd, ct, pa), r)  <- runRM arrowMonad pa0 $ runStateT `flip` mempty $       do-        sweepAll singleton-        _ <- lift $ feedR x-        sweepAll singleton-        lift $ freeze-    return $ (retval wer, pa)-+        csmd <- evalContT $+          do+            sweepAll singleton+            return True+        ct <- evalContT $+          do+            _ <- lift $ lift $ feedR x+            sweepAll singleton+            return True+        pa <- lift $ freeze+        return (csmd, ct, pa)+    return $ (retval r csmd ct, pa)   where     singleton x = Endo (x:) -    retval WithEnd {..} = ExecInfo {-        yields = appEndo getRWE [],-        hasConsumed = True,-        hasStopped = not getContWE+    retval r csmd ct = ExecInfo {+        yields = appEndo r [],+        hasConsumed = csmd,+        hasStopped = not ct       }  -- | Execute until an output produced.

@@ -54,6 +54,7 @@         anytime,         par,         parB,+        oneshot,         now,         onEnd, #if defined(MIN_VERSION_arrows)@@ -311,14 +312,27 @@  echo = filter (arr (const True)) -now ::+-- |Emit an event of given value as soon as possible.+oneshot ::     ArrowApply a =>-    ProcessA a b (Event ())-now = arr (const noEvent) >>> go+    c ->+    ProcessA a b (Event c)+oneshot x = arr (const noEvent) >>> go   where     go = construct $-        yield () >> forever await+        yield x >> forever await +-- |Emit an event as soon as possible.+--+-- @+--  now = oneshot ()+-- @+now ::+    ArrowApply a =>+    ProcessA a b (Event ())+now = oneshot ()++-- |Emit an event at the end of the input stream. onEnd ::     (ArrowApply a, Occasional' b) =>     ProcessA a b (Event ())

@@ -116,7 +116,18 @@             in               r1 == r2 +        it "is lazy for individual input values" $+          do+            let l = runOn (\x -> [x]) Cat.id (take 10 $ repeat undefined)+            length l `shouldBe` 10 +{-+        it "is lazy for inpurt stream" $+          do+            let l = take 10 $ run Cat.id (repeat undefined)+            length l `shouldBe` 10+-}+ rules =   do     describe "ProcessA as Category" $@@ -354,6 +365,13 @@  utility =   do+    describe "splitEvent" $+      do+        it "splits an event stream" $+          do+            run (splitEvent >>> arr fst) [Left 1, Right 2, Left 3, Right 4] `shouldBe` [1, 3]+            run (splitEvent >>> arr snd) [Left 1, Right 2, Left 3, Right 4] `shouldBe` [2, 4]+     describe "edge" $       do         it "detects edges of input behaviour" $@@ -411,7 +429,7 @@             let                 before = proc evx ->                   do-                    ch <- P.filter (arr $ (\x -> x `mod` 2 == 0)) -< evx+                    ch <- P.filterEvent (\x -> x `mod` 2 == 0) -< evx                     returnA -< (noEvent, ch)                  after t = proc evx -> returnA -< (t*) <$> evx