machinecell 1.1.0 → 1.1.1

raw patch · 6 files changed

+123/−100 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• machinecell.cabal +2/−2
• src/Control/Arrow/Machine/Plan.hs +21/−11
• src/Control/Arrow/Machine/Running.hs +44/−9
• src/Control/Arrow/Machine/Utils.hs +30/−66
• test/spec.hs +22/−12

@@ -1,3 +1,7 @@+1.1.1+------------+* Eliminated banana brackets to support newest GHC.+ 1.1.0 ------------ * Hide `Event` constructors and some instances (`Applicative`, `Monad`).

@@ -1,5 +1,5 @@ name:                machinecell-version:             1.1.0+version:             1.1.1 synopsis:            Arrow based stream transducers license:             BSD3 license-file:        LICENSE@@ -44,4 +44,4 @@ source-repository this   type:		git   location:	https://github.com/as-capabl/machinecell.git-  tag:		release-1.1.0+  tag:		release-1.1.1

@@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  {-|@@ -34,6 +35,7 @@ import qualified Control.Monad.Trans.Free as F  import Data.Monoid (mappend)+import Data.Functor ((<$>)) import Control.Monad import Control.Arrow import Control.Monad.Trans@@ -63,6 +65,16 @@ 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 ()@@ -80,6 +92,7 @@   + constructT :: (Monad m, ArrowApply a) =>                (forall b. m b -> a () b) ->               PlanT i o m r -> @@ -91,6 +104,12 @@         where++    feedTo f = proc x ->+      do+        ff2 <- fit (F.runFreeT (f x)) -<< ()+        oneYieldPF fit Feed ff2 -<< ()+     probe Suspend pl = proc _ ->         returnA -< (Suspend, NoEvent, constructT fit pl)         @@ -99,17 +118,8 @@         pfr <- fit (F.runFreeT pl) -< ()         go ph pfr -<< evx --    go Feed (F.Free (AwaitPF f)) = proc evx ->-      do-        (| hEv'-            (\x -> -              do-                ff2 <- fit (F.runFreeT (f x)) -<< ()-                oneYieldPF fit Feed ff2 -<< ())-            (returnA -< (Feed, NoEvent, constructT fit (await_ f)))-            (returnA -< (Feed, End, stopped))-           |) evx+    go 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 ph pfr = proc evx ->         oneYieldPF fit ph pfr -< ()

@@ -97,6 +97,10 @@     returnA -< (ExecInfo { yields = ys2 [], hasConsumed = True, hasStopped = hsS } , pa'')    where+{-+    -- Converted code below with arrowp.+    -- Need refactoring overall this file, rather than rewrite here.+     go pa ys = step pa >>> proc (ph', evy, pa') ->       do         (| handle@@ -105,6 +109,23 @@             (returnA -< (ys, pa', case evy of {End->True; _->False}))          |)             (ph', evy)+-}+    go pa ys+          = step pa >>>+              (arr (\ (ph', evy, pa') -> ((evy, pa', ph'), (ph', evy))) >>>+                 handle+                   (arr+                      (\ ((evy, pa', ph'), y) ->+                         (go pa' (\ cont -> ys (y : cont)), (adv ph', NoEvent)))+                      >>> app)+                   (arr (\ (evy, pa', ph') -> (go pa' ys, (adv ph', NoEvent))) >>>+                      app)+                   (arr+                      (\ (evy, pa', ph') ->+                         (ys, pa',+                          case evy of+                              End -> True+                              _ -> False))))                        stepYield :: @@ -115,15 +136,20 @@ stepYield pa = proc x ->   do     (my, pa', hsS) <- go pa -<< (Sweep, NoEvent)-    (| handle2 -        (returnA -< (ExecInfo { yields = my, hasConsumed = False, hasStopped = hsS}, pa'))-        (do-            (my2, pa'', hsS) <- go pa' -<< (Feed, (Event x))-            returnA -< (ExecInfo { yields = my2, hasConsumed = True, hasStopped = hsS}, pa''))-     |)-        my+    cont my pa' hsS -<< x    where+    cont (Just y) pa' hsS = proc _ ->+        returnA -< (ExecInfo { yields = Just y, hasConsumed = False, hasStopped = hsS}, pa')++    cont Nothing pa' hsS = proc x ->+      do+        (my2, pa'', hsS') <- go pa' -<< (Feed, (Event x))+        returnA -< (ExecInfo { yields = my2, hasConsumed = True, hasStopped = hsS}, pa'')+{-+    -- Converted code below with arrowp.+    -- Need refactoring overall this file, rather than rewrite here.+     go pa = step pa >>> proc (ph', evy, pa') ->       do         (| handle@@ -132,8 +158,17 @@             (returnA -< (Nothing, pa', case evy of {End->True; _->False}))          |)             (ph', evy)+-}+    go pa = step pa >>>+              (arr (\ (ph', evy, pa') -> ((evy, pa', ph'), (ph', evy))) >>>+                 handle (arr (\ ((evy, pa', ph'), y) -> (Just y, pa', False)))+                   (arr (\ (evy, pa', ph') -> (go pa', (adv ph', NoEvent))) >>> app)+                   (arr+                      (\ (evy, pa', ph') ->+                         (Nothing, pa',+                          case evy of+                              End -> True+                              _ -> False))))  -    handle2 f1 f2 = proc (e, mx) ->-        maybe f2 (const f1) mx -<< e 

@@ -132,12 +132,17 @@       Just x -> ag -< (e, 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, evb) ->-    (returnA -< evb) `passRecent` (\b -> af -< (e, b))+withRecent af = proc (e, evx) ->+  do+    mvx <- hold Nothing -< Just <$> evx+    case mvx of+      Just x -> af -< (e, x)+      _ -> returnA -< noEvent   @@ -174,15 +179,6 @@          | otherwise = feedback1 paC -{--proc e ->-  do-    (y, _) <- kSwitch pa test eval -< (e, noEvent)-    returnA -< y-  where-    test = -    eval pa' d = switch (yielder >>> --}  -- |Artificially split into two arrow to use binary operator notation -- rather than banana brackets.@@ -201,21 +197,15 @@ -- -- Switches ---hEvPh :: ArrowApply a => a (e,b) c -> a e c -> a (e, (Phase, Event b)) c-hEvPh f1 f2 = proc (e, (ph, ev)) ->-    helper ph ev -<< e-  where-    helper Feed (Event x) = proc e -> f1 -< (e, x)-    helper _ _ = f2+evMaybePh :: b -> (a->b) -> (Phase, Event a) -> b+evMaybePh _ f (Feed, Event x) = f x+evMaybePh d _ _ = d  -hEvPh' :: ArrowApply a => a (e,b) c -> a e c -> a e c -> a (e, (Phase, Event b)) c-hEvPh' f1 f2 f3 = proc (e, (ph, ev)) ->-    helper ph ev -<< e+switchCore sw cur cont = sw cur (arr test) cont' >>> arr fst   where-    helper Feed (Event x) = proc e -> f1 -< (e, x)-    helper Feed End = f3-    helper _ _ = f2+    test (_, (_, evt)) = evt+    cont' _ t = cont t >>> arr (\y -> (y, noEvent))  switch ::      ArrowApply a => @@ -223,14 +213,7 @@     (t -> ProcessA a b c) ->     ProcessA a b c -switch cur cont = ProcessA $ proc (ph, x) ->-  do-    (ph', (y, evt), new) <- step cur -< (ph, x)-    (| hEvPh-        (\t -> step (cont t) -<< (ph, x))-        (returnA -< (ph', y, switch new cont))-      |) -        (ph', evt)+switch = switchCore kSwitch   dSwitch :: @@ -239,14 +222,7 @@     (t -> ProcessA a b c) ->     ProcessA a b c -dSwitch cur cont = ProcessA $ proc (ph, x) ->-  do-    (ph', (y, evt), new) <- step cur -< (ph, x)-    -    returnA -< (ph', y, next new evt)-  where-    next _ (Event t) = cont t-    next new _ = dSwitch new cont+dSwitch = switchCore dkSwitch   rSwitch :: @@ -255,12 +231,8 @@  rSwitch cur = ProcessA $ proc (ph, (x, eva)) ->    do-    (ph', y, new) <- -        (| hEvPh-            (\af -> step af -<< (ph, x))-            (step cur -< (ph, x))-         |)-            (ph, eva)+    let now = evMaybePh cur id (ph, eva)+    (ph', y, new) <-  step now -<< (ph, x)     returnA -< (ph', y, rSwitch new)  @@ -290,11 +262,12 @@   do     (ph', y, sf') <- step sf -< (ph, x)     (phT, evt, test') <- step test -< (ph', (x, y))-    (| hEvPh-        (\t -> step $ k sf' t -<< (phT, x))-        (returnA -< (phT, y, kSwitch sf' test' k))-     |) ++    evMaybePh +        (arr $ const (phT, y, kSwitch sf' test' k)) +        (step . (k sf'))         (phT, evt)+            -<< (phT, x)   dkSwitch ::@@ -379,12 +352,11 @@     (ph', zs, sfs') <- parCore r sfs -<< (ph, x)     (phT, evt, test') <- step test -< (ph', (x, zs)) -    (| hEvPh-       (\t -> step $ k sfs' t -<< (ph, x))-       (returnA -< (ph' `mappend` phT, zs, pSwitch r sfs' test' k))-     |) -       (phT, evt)-+    evMaybePh+        (arr $ const (ph' `mappend` phT, zs, pSwitch r sfs' test' k))+        (step . (k sfs') )+        (phT, evt)+            -<< (ph, x)  pSwitchB ::     (ArrowApply a, Tv.Traversable col) =>@@ -405,17 +377,9 @@  rpSwitch r sfs = ProcessA $ proc (ph, (x, evCont)) ->   do-    (ph', zs, sfs') <- parCore r sfs -<< (ph, x)--    (| hEvPh-       (\cont -> -         do-           (ph'', ws, sfs'') <- parCore r (cont sfs') -<< (ph, x)-           returnA -< (ph'' `mappend` Suspend, ws, rpSwitch r sfs'')-         )-       (returnA -< (ph' `mappend` Suspend, zs, rpSwitch r sfs'))-     |) -       (ph', evCont)+    let sfsNew = evMaybePh sfs ($sfs) (ph, evCont)+    (ph', ws, sfs') <- parCore r sfsNew -<< (ph, x)+    returnA -< (ph' `mappend` Suspend, ws, rpSwitch r sfs')   rpSwitchB ::

@@ -413,30 +413,33 @@       do
         it "switches any times" $
           do
-            pendingWith "to correct"
-{-
             let
                theArrow sw = proc evtp ->
                  do
-                   (evx, evarr) <- P.split -< evtp
+                   evx <- P.fork -< fst <$> evtp
+                   evarr <- P.fork -< snd <$> evtp
                    sw (arr $ fmap (+2)) -< (evx, evarr)
 
-               l = [(Event 5, NoEvent),
-                    (Event 1, Event (arr $ fmap (*2))),
-                    (Event 2, NoEvent)]
+               l = [(Just 5, Nothing),
+                    (Just 1, Just (arr $ fmap (*2))),
+                    (Just 3, Nothing),
+                    (Just 6, Just (arr $ fmap (*3))),
+                    (Just 7, Nothing)]
                ret = run (theArrow rSwitch) l
                retD = run (theArrow drSwitch) l
 
-            ret `shouldBe` [7, 2, 4]
-            retD `shouldBe` [7, 3, 4]
--}
+            ret `shouldBe` [7, 2, 6, 18, 21]
+            retD `shouldBe` [7, 3, 6, 12, 21]
 
+
 operator = describe "Operators on ProcessA"$
   do
     describe "feedback" $
       do
         it "acts like local variable with hold." $
           do
+            pendingWith "Arrow statement with argument broken."
+{-
             let 
                 pa = proc evx ->
                   do
@@ -445,12 +448,19 @@                       do
                         returnA -< ((+y) <$> evx, (y+1) <$ evx)
             run pa [1, 2, 3] `shouldBe` [11, 13, 15]
-
+-}
         it "correctly handles stream end." $
           do
-            let pa = proc x -> (| feedback1 (\y -> returnA -< (y::Event Int, x)) |)
-            let comp = mkProc (PgPush PgStop) >>> pa
+            pendingWith "Arrow statement with argument broken."
+{-
+            let 
+                pa = proc x -> 
+                    (\x -> returnA -< x)
+                  `feedback` 
+                    (\y -> returnA -< (y::Event Int, x))
+                comp = mkProc (PgPush PgStop) >>> pa
             stateProc comp [0, 0] `shouldBe` ([], [0])
+-}
 
         it "correctly handles stream end.(2)" $
           do