packages feed

pipes-fluid 0.3.1.0 → 0.4.0.0

raw patch · 7 files changed

+321/−321 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

- Pipes.Fluid.React: React :: Producer a m () -> React m a
- Pipes.Fluid.React: [reactively] :: React m a -> Producer a m ()
- Pipes.Fluid.React: instance (GHC.Base.Alternative m, GHC.Base.Monad m) => GHC.Base.Applicative (Pipes.Fluid.React.React m)
- Pipes.Fluid.React: instance (GHC.Base.Alternative m, GHC.Base.Monad m) => Pipes.Fluid.Merge.Merge (Pipes.Fluid.React.React m)
- Pipes.Fluid.React: instance Control.Lens.Wrapped.Wrapped (Pipes.Fluid.React.React m0 a0)
- Pipes.Fluid.React: instance GHC.Base.Monad m => GHC.Base.Functor (Pipes.Fluid.React.React m)
- Pipes.Fluid.React: instance Pipes.Fluid.React.React m0 a0 ~ t0 => Control.Lens.Wrapped.Rewrapped (Pipes.Fluid.React.React m1 a1) t0
- Pipes.Fluid.React: newtype React m a
- Pipes.Fluid.ReactIO: ReactIO :: Producer a m () -> ReactIO m a
- Pipes.Fluid.ReactIO: [reactivelyIO] :: ReactIO m a -> Producer a m ()
- Pipes.Fluid.ReactIO: instance (Control.Monad.Trans.Control.MonadBaseControl GHC.Types.IO m, Data.Constraint.Forall.Forall (Control.Concurrent.Async.Lifted.Safe.Pure m)) => GHC.Base.Applicative (Pipes.Fluid.ReactIO.ReactIO m)
- Pipes.Fluid.ReactIO: instance (Control.Monad.Trans.Control.MonadBaseControl GHC.Types.IO m, Data.Constraint.Forall.Forall (Control.Concurrent.Async.Lifted.Safe.Pure m)) => Pipes.Fluid.Merge.Merge (Pipes.Fluid.ReactIO.ReactIO m)
- Pipes.Fluid.ReactIO: instance Control.Lens.Wrapped.Wrapped (Pipes.Fluid.ReactIO.ReactIO m0 a0)
- Pipes.Fluid.ReactIO: instance GHC.Base.Monad m => GHC.Base.Functor (Pipes.Fluid.ReactIO.ReactIO m)
- Pipes.Fluid.ReactIO: instance Pipes.Fluid.ReactIO.ReactIO m0 a0 ~ t0 => Control.Lens.Wrapped.Rewrapped (Pipes.Fluid.ReactIO.ReactIO m1 a1) t0
- Pipes.Fluid.ReactIO: newtype ReactIO m a
+ Pipes.Fluid.Impulse: Impulse :: Producer a m () -> Impulse m a
+ Pipes.Fluid.Impulse: [impulsively] :: Impulse m a -> Producer a m ()
+ Pipes.Fluid.Impulse: instance (GHC.Base.Alternative m, GHC.Base.Monad m) => GHC.Base.Applicative (Pipes.Fluid.Impulse.Impulse m)
+ Pipes.Fluid.Impulse: instance (GHC.Base.Alternative m, GHC.Base.Monad m) => Pipes.Fluid.Merge.Merge (Pipes.Fluid.Impulse.Impulse m)
+ Pipes.Fluid.Impulse: instance Control.Lens.Wrapped.Wrapped (Pipes.Fluid.Impulse.Impulse m0 a0)
+ Pipes.Fluid.Impulse: instance GHC.Base.Monad m => GHC.Base.Functor (Pipes.Fluid.Impulse.Impulse m)
+ Pipes.Fluid.Impulse: instance Pipes.Fluid.Impulse.Impulse m0 a0 ~ t0 => Control.Lens.Wrapped.Rewrapped (Pipes.Fluid.Impulse.Impulse m1 a1) t0
+ Pipes.Fluid.Impulse: newtype Impulse m a
+ Pipes.Fluid.ImpulseIO: ImpulseIO :: Producer a m () -> ImpulseIO m a
+ Pipes.Fluid.ImpulseIO: [impulsivelyIO] :: ImpulseIO m a -> Producer a m ()
+ Pipes.Fluid.ImpulseIO: instance (Control.Monad.Trans.Control.MonadBaseControl GHC.Types.IO m, Data.Constraint.Forall.Forall (Control.Concurrent.Async.Lifted.Safe.Pure m)) => GHC.Base.Applicative (Pipes.Fluid.ImpulseIO.ImpulseIO m)
+ Pipes.Fluid.ImpulseIO: instance (Control.Monad.Trans.Control.MonadBaseControl GHC.Types.IO m, Data.Constraint.Forall.Forall (Control.Concurrent.Async.Lifted.Safe.Pure m)) => Pipes.Fluid.Merge.Merge (Pipes.Fluid.ImpulseIO.ImpulseIO m)
+ Pipes.Fluid.ImpulseIO: instance Control.Lens.Wrapped.Wrapped (Pipes.Fluid.ImpulseIO.ImpulseIO m0 a0)
+ Pipes.Fluid.ImpulseIO: instance GHC.Base.Monad m => GHC.Base.Functor (Pipes.Fluid.ImpulseIO.ImpulseIO m)
+ Pipes.Fluid.ImpulseIO: instance Pipes.Fluid.ImpulseIO.ImpulseIO m0 a0 ~ t0 => Control.Lens.Wrapped.Rewrapped (Pipes.Fluid.ImpulseIO.ImpulseIO m1 a1) t0
+ Pipes.Fluid.ImpulseIO: newtype ImpulseIO m a

Files

pipes-fluid.cabal view
@@ -1,5 +1,5 @@ name:                pipes-fluid-version:             0.3.1.0+version:             0.4.0.0 synopsis:            Reactively combines Producers so that a value is yielded as soon as possible. description:         Please see README.md homepage:            https://github.com/louispan/pipes-fluid#readme@@ -17,8 +17,8 @@   hs-source-dirs:      src   exposed-modules:     Pipes.Fluid                        Pipes.Fluid.Merge-                       Pipes.Fluid.React-                       Pipes.Fluid.ReactIO+                       Pipes.Fluid.Impulse+                       Pipes.Fluid.ImpulseIO                        Pipes.Fluid.Sync   build-depends:       base >= 4.7 && < 5                      , constraints >= 0.4 && < 1
src/Pipes/Fluid.hs view
@@ -1,11 +1,11 @@ module Pipes.Fluid     ( module Pipes.Fluid.Merge-    , module Pipes.Fluid.React-    , module Pipes.Fluid.ReactIO+    , module Pipes.Fluid.Impulse+    , module Pipes.Fluid.ImpulseIO     , module Pipes.Fluid.Sync     ) where  import Pipes.Fluid.Merge-import Pipes.Fluid.React-import Pipes.Fluid.ReactIO+import Pipes.Fluid.Impulse+import Pipes.Fluid.ImpulseIO import Pipes.Fluid.Sync
+ src/Pipes/Fluid/Impulse.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Pipes.Fluid.Impulse+    ( Impulse(..)+    , module Pipes.Fluid.Merge+    ) where++import Control.Applicative+import Control.Lens+import Control.Monad.Trans.Class+import Data.These+import qualified Pipes as P+import Pipes.Fluid.Merge+import qualified Pipes.Prelude as PP++-- | The applicative instance of this combines multiple Producers reactively+-- ie, yields a value as soon as either or both of the input producers yields a value.+newtype Impulse m a = Impulse+    { impulsively :: P.Producer a m ()+    }++makeWrapped ''Impulse++instance Monad m =>+         Functor (Impulse m) where+    fmap f (Impulse as) = Impulse $ as P.>-> PP.map f+    {-# INLINABLE fmap #-}++-- | Impulseively combines two producers, given initial values to use when the producer is blocked/failed.+-- This only works for Alternative m where failure means there was no effects, eg. 'Control.Concurrent.STM', or @MonadTrans t => t STM@.+-- Be careful of monad transformers like ExceptT that hides the STM Alternative instance.+instance (Alternative m, Monad m) =>+         Applicative (Impulse m) where+    pure = Impulse . P.yield+    {-# INLINABLE pure #-}++    fs <*> as =+        Impulse $+        P.for (impulsively $ merge fs as) $ \r ->+            case r of+                Coupled _ f a -> P.yield $ f a+                -- never got anything from one of the signals, can't do anything yet.+                -- fail/retry/block until we get something from the other signal+                LeftOnly _ _ -> lift empty+                RightOnly _ _-> lift empty+    {-# INLINABLE (<*>) #-}++-- | Impulseively combines two producers, given initial values to use when the produce hasn't produced anything yet+-- Combine two signals, and returns a signal that emits+-- @Either bothfired (Either (leftFired, previousRight) (previousLeft, rightFired))@.+-- This only works for Alternative m where failure means there was no effects, eg. 'Control.Concurrent.STM', or @MonadTrans t => t STM@.+-- Be careful of monad transformers ExceptT that hides the STM Alternative instance.+instance (Alternative m, Monad m) => Merge (Impulse m) where+    merge' px_ py_ (Impulse xs_) (Impulse ys_) = Impulse $ go px_ py_ xs_ ys_+      where+        go px py xs ys = do+            -- use the Alternative of m, not P.Proxy+            r <- lift $ bothOrEither (P.next xs) (P.next ys)+            case r+                -- both fs and as have ended+                  of+                These (Left _) (Left _) -> pure ()+                -- @xs@ ended,                @ys@ failed/retry/blocked+                This (Left _) -> case px of+                    Nothing -> ys P.>-> PP.map (RightOnly OtherDead)+                    Just x -> ys P.>-> PP.map (Coupled (FromRight OtherDead) x)+                -- @xs@ failed/retry/blocked, @ys@ ended+                That (Left _) -> case py of+                    Nothing -> xs P.>-> PP.map (LeftOnly OtherDead)+                    Just y -> xs P.>-> PP.map (\x -> Coupled (FromLeft OtherDead) x y)+                -- @xs@ produced something,   @ys@ failed/retry/blocked+                This (Right (x, xs')) -> do+                    case py of+                        Nothing -> P.yield $ LeftOnly OtherLive x+                        Just y -> P.yield $ Coupled (FromLeft OtherLive) x y+                    go (Just x) py xs' ys+                -- @xs@ failed/retry/blocked, @ys@ produced something+                That (Right (y, ys')) -> do+                    case px of+                        Nothing -> P.yield $ RightOnly OtherLive y+                        Just x -> P.yield $ Coupled (FromRight OtherLive) x y+                    go px (Just y) xs ys'+                -- @xs@ produced something,   @ys@ ended+                These (Right (x, xs')) (Left _) ->+                    case py of+                        Nothing -> do+                            P.yield $ LeftOnly OtherDead x+                            xs' P.>-> PP.map (LeftOnly OtherDead)+                        Just y -> do+                            P.yield $ Coupled (FromLeft OtherDead) x y+                            xs' P.>-> PP.map (\x' -> Coupled (FromLeft OtherDead) x' y)+                -- @fs@ ended,                @as@ produced something+                These (Left _) (Right (y, ys')) ->+                    case px of+                        Nothing -> do+                            P.yield $ RightOnly OtherDead y+                            ys' P.>-> PP.map (RightOnly OtherDead)+                        Just x -> do+                            P.yield $ Coupled (FromRight OtherDead) x y+                            ys' P.>-> PP.map (Coupled (FromRight OtherDead) x)+                -- both @fs@ and @as@ produced something+                These (Right (x, xs')) (Right (y, ys')) -> do+                    P.yield $ Coupled FromBoth x y+                    go (Just x) (Just y) xs' ys'+    {-# INLINABLE merge' #-}++-- | Used internally by Impulse and ImpulseIO identifying which side (or both) returned values+bothOrEither :: Alternative f => f a -> f b -> f (These a b)+bothOrEither left right =+  (These <$> left <*> right)+  <|>+  (This <$> left)+  <|>+  (That <$> right)+{-# INLINABLE bothOrEither #-}
+ src/Pipes/Fluid/ImpulseIO.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Pipes.Fluid.ImpulseIO+    ( ImpulseIO(..)+    , module Pipes.Fluid.Merge+    ) where++import Control.Applicative+import qualified Control.Concurrent.Async.Lifted.Safe as A+import qualified Control.Concurrent.STM as S+import Control.Lens+import Control.Monad.Base+import Control.Monad.Trans.Class+import Control.Monad.Trans.Control+import Data.Constraint.Forall (Forall)+import Data.These+import qualified Pipes as P+import Pipes.Fluid.Merge+import qualified Pipes.Prelude as PP++-- | The applicative instance of this combines multiple Producers reactively+-- ie, yields a value as soon as either or both of the input producers yields a value.+-- This creates two threads each time this combinator is used.+-- Warning: This means that the monadic effects are run in isolation from each other+-- so if the monad is something like (StateT s IO), then the state will alternate+-- between the two input producers, which is most likely not what you want.+newtype ImpulseIO m a = ImpulseIO+    { impulsivelyIO :: P.Producer a m ()+    }++makeWrapped ''ImpulseIO++instance Monad m => Functor (ImpulseIO m) where+  fmap f (ImpulseIO as) = ImpulseIO $ as P.>-> PP.map f+  {-# INLINABLE fmap #-}++instance (MonadBaseControl IO m, Forall (A.Pure m)) => Applicative (ImpulseIO m) where+    pure = ImpulseIO . P.yield+    {-# INLINABLE pure #-}++    -- 'ap' doesn't know about initial values+    fs <*> as = ImpulseIO $ P.for (impulsivelyIO $ merge fs as) $ \r ->+        case r of+            Coupled _ f a -> P.yield $ f a+            -- never got anything from one of the signals, can't do anything yet.+            -- drop the event+            LeftOnly _ _ -> pure ()+            RightOnly _ _-> pure ()+    {-# INLINABLE (<*>) #-}++-- | Reactively combines two producers, given initial values to use when the produce hasn't produced anything yet+-- Combine two signals, and returns a signal that emits+-- @Either bothfired (Either (leftFired, previousRight) (previousLeft, rightFired))@.+-- This creates two threads each time this combinator is used.+-- Warning: This means that the monadic effects are run in isolation from each other+-- so if the monad is something like (StateT s IO), then the state will alternate+-- between the two input producers, which is most likely not what you want.+-- This will be detect as a compile error due to use of Control.Concurrent.Async.Lifted.Safe+instance (MonadBaseControl IO m, Forall (A.Pure m)) => Merge (ImpulseIO m) where+    merge' px_ py_ (ImpulseIO xs_) (ImpulseIO ys_) = ImpulseIO $ do+        ax <- lift $ A.async $ P.next xs_+        ay <- lift $ A.async $ P.next ys_+        doMergeIO px_ py_ ax ay+      where+        doMergeIO :: (MonadBaseControl IO m, Forall (A.Pure m)) =>+             Maybe x+          -> Maybe y+          -> A.Async (Either () (x, P.Producer x m ()))+          -> A.Async (Either () (y, P.Producer y m ()))+          -> P.Producer (Merged x y) m ()+        doMergeIO px py ax ay = do+            r <-+                lift $+                liftBase . S.atomically $ bothOrEither (A.waitSTM ax) (A.waitSTM ay)+            case r of+                -- both @ax@ and @ay@ have ended+                These (Left _) (Left _) -> pure ()+                -- @ax@ ended,                @ay@ still waiting+                This (Left _) -> do+                    ry <- lift $ A.wait ay -- wait for @ay@ to return and then+                                           -- only use @ys@+                    case ry of+                        Left _ -> pure ()+                        Right (y, ys') -> case px of+                            Nothing -> do+                                P.yield $ RightOnly OtherDead y+                                ys' P.>-> PP.map (RightOnly OtherDead)+                            Just x -> do+                                P.yield $ Coupled (FromRight OtherDead) x y+                                ys' P.>-> PP.map (Coupled (FromRight OtherDead) x)+                -- @ax@ still waiting,        @ay@ ended+                That (Left _) -> do+                    rx <- lift $ A.wait ax -- wait for @ax@ to retrun and then+                                           -- only use @xs@+                    case rx of+                        Left _ -> pure ()+                        Right (x, xs') -> case py of+                            Nothing -> do+                                P.yield $ LeftOnly OtherDead x+                                xs' P.>-> PP.map (LeftOnly OtherDead)+                            Just y -> do+                                P.yield $ Coupled (FromLeft OtherDead) x y+                                xs' P.>-> PP.map (\x' -> Coupled (FromLeft OtherDead) x' y)+                -- @ax@ produced something,   @ay@ still waiting+                This (Right (x, xs')) -> do+                    case py of+                        Nothing -> P.yield $ LeftOnly OtherLive x+                        Just y -> P.yield $ Coupled (FromLeft OtherLive) x y+                    ax' <- lift $ A.async $ P.next xs'+                    doMergeIO (Just x) py ax' ay+                -- @ax@ still waiting,        @ay@ produced something+                That (Right (y, ys')) -> do+                    case px of+                        Nothing -> P.yield $ RightOnly OtherLive y+                        Just x -> P.yield $ Coupled (FromRight OtherLive) x y+                    ay' <- lift $ A.async $ P.next ys'+                    doMergeIO px (Just y) ax ay'+                -- @ax@ produced something,   @ay@ ended+                These (Right (x, xs')) (Left _) ->+                    case py of+                        Nothing -> do+                            P.yield $ LeftOnly OtherDead x+                            xs' P.>-> PP.map (LeftOnly OtherDead)+                        Just y -> do+                            P.yield $ Coupled (FromLeft OtherDead) x y+                            xs' P.>-> PP.map (\x' -> Coupled (FromLeft OtherDead) x' y)+                -- @af@ ended,                @aa@ produced something+                These (Left _) (Right (y, ys')) ->+                    case px of+                        Nothing -> do+                            P.yield $ RightOnly OtherDead y+                            ys' P.>-> PP.map (RightOnly OtherDead)+                        Just x -> do+                            P.yield $ Coupled (FromRight OtherDead) x y+                            ys' P.>-> PP.map (Coupled (FromRight OtherDead) x)+                -- both @fs@ and @as@ produced something+                These (Right (x, xs')) (Right (y, ys')) -> do+                    P.yield $ Coupled FromBoth x y+                    ax' <- lift $ A.async $ P.next xs'+                    ay' <- lift $ A.async $ P.next ys'+                    doMergeIO (Just x) (Just y) ax' ay'+    {-# INLINABLE merge' #-}++-- | Used internally by Impulse and ImpulseIO identifying which side (or both) returned values+bothOrEither :: Alternative f => f a -> f b -> f (These a b)+bothOrEither left right =+  (These <$> left <*> right)+  <|>+  (This <$> left)+  <|>+  (That <$> right)+{-# INLINABLE bothOrEither #-}
− src/Pipes/Fluid/React.hs
@@ -1,123 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ImpredicativeTypes #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}--module Pipes.Fluid.React-    ( React(..)-    , module Pipes.Fluid.Merge-    ) where--import Control.Applicative-import Control.Lens-import Control.Monad.Trans.Class-import Data.These-import qualified Pipes as P-import Pipes.Fluid.Merge-import qualified Pipes.Prelude as PP---- | The applicative instance of this combines multiple Producers reactively--- ie, yields a value as soon as either or both of the input producers yields a value.-newtype React m a = React-    { reactively :: P.Producer a m ()-    }--makeWrapped ''React--instance Monad m =>-         Functor (React m) where-    fmap f (React as) = React $ as P.>-> PP.map f-    {-# INLINABLE fmap #-}---- | Reactively combines two producers, given initial values to use when the producer is blocked/failed.--- This only works for Alternative m where failure means there was no effects, eg. 'Control.Concurrent.STM', or @MonadTrans t => t STM@.--- Be careful of monad transformers like ExceptT that hides the STM Alternative instance.-instance (Alternative m, Monad m) =>-         Applicative (React m) where-    pure = React . P.yield-    {-# INLINABLE pure #-}--    fs <*> as =-        React $-        P.for (reactively $ merge fs as) $ \r ->-            case r of-                Coupled _ f a -> P.yield $ f a-                -- never got anything from one of the signals, can't do anything yet.-                -- fail/retry/block until we get something from the other signal-                LeftOnly _ _ -> lift empty-                RightOnly _ _-> lift empty-    {-# INLINABLE (<*>) #-}---- | Reactively combines two producers, given initial values to use when the produce hasn't produced anything yet--- Combine two signals, and returns a signal that emits--- @Either bothfired (Either (leftFired, previousRight) (previousLeft, rightFired))@.--- This only works for Alternative m where failure means there was no effects, eg. 'Control.Concurrent.STM', or @MonadTrans t => t STM@.--- Be careful of monad transformers ExceptT that hides the STM Alternative instance.-instance (Alternative m, Monad m) => Merge (React m) where-    merge' px_ py_ (React xs_) (React ys_) = React $ go px_ py_ xs_ ys_-      where-        go px py xs ys = do-            -- use the Alternative of m, not P.Proxy-            r <- lift $ bothOrEither (P.next xs) (P.next ys)-            case r-                -- both fs and as have ended-                  of-                These (Left _) (Left _) -> pure ()-                -- @xs@ ended,                @ys@ failed/retry/blocked-                This (Left _) -> case px of-                    Nothing -> ys P.>-> PP.map (RightOnly OtherDead)-                    Just x -> ys P.>-> PP.map (Coupled (FromRight OtherDead) x)-                -- @xs@ failed/retry/blocked, @ys@ ended-                That (Left _) -> case py of-                    Nothing -> xs P.>-> PP.map (LeftOnly OtherDead)-                    Just y -> xs P.>-> PP.map (\x -> Coupled (FromLeft OtherDead) x y)-                -- @xs@ produced something,   @ys@ failed/retry/blocked-                This (Right (x, xs')) -> do-                    case py of-                        Nothing -> P.yield $ LeftOnly OtherLive x-                        Just y -> P.yield $ Coupled (FromLeft OtherLive) x y-                    go (Just x) py xs' ys-                -- @xs@ failed/retry/blocked, @ys@ produced something-                That (Right (y, ys')) -> do-                    case px of-                        Nothing -> P.yield $ RightOnly OtherLive y-                        Just x -> P.yield $ Coupled (FromRight OtherLive) x y-                    go px (Just y) xs ys'-                -- @xs@ produced something,   @ys@ ended-                These (Right (x, xs')) (Left _) ->-                    case py of-                        Nothing -> do-                            P.yield $ LeftOnly OtherDead x-                            xs' P.>-> PP.map (LeftOnly OtherDead)-                        Just y -> do-                            P.yield $ Coupled (FromLeft OtherDead) x y-                            xs' P.>-> PP.map (\x' -> Coupled (FromLeft OtherDead) x' y)-                -- @fs@ ended,                @as@ produced something-                These (Left _) (Right (y, ys')) ->-                    case px of-                        Nothing -> do-                            P.yield $ RightOnly OtherDead y-                            ys' P.>-> PP.map (RightOnly OtherDead)-                        Just x -> do-                            P.yield $ Coupled (FromRight OtherDead) x y-                            ys' P.>-> PP.map (Coupled (FromRight OtherDead) x)-                -- both @fs@ and @as@ produced something-                These (Right (x, xs')) (Right (y, ys')) -> do-                    P.yield $ Coupled FromBoth x y-                    go (Just x) (Just y) xs' ys'-    {-# INLINABLE merge' #-}---- | Used internally by React and ReactIO identifying which side (or both) returned values-bothOrEither :: Alternative f => f a -> f b -> f (These a b)-bothOrEither left right =-  (These <$> left <*> right)-  <|>-  (This <$> left)-  <|>-  (That <$> right)-{-# INLINABLE bothOrEither #-}
− src/Pipes/Fluid/ReactIO.hs
@@ -1,161 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ImpredicativeTypes #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--module Pipes.Fluid.ReactIO-    ( ReactIO(..)-    , module Pipes.Fluid.Merge-    ) where--import Control.Applicative-import qualified Control.Concurrent.Async.Lifted.Safe as A-import qualified Control.Concurrent.STM as S-import Control.Lens-import Control.Monad.Base-import Control.Monad.Trans.Class-import Control.Monad.Trans.Control-import Data.Constraint.Forall (Forall)-import Data.These-import qualified Pipes as P-import Pipes.Fluid.Merge-import qualified Pipes.Prelude as PP---- | The applicative instance of this combines multiple Producers reactively--- ie, yields a value as soon as either or both of the input producers yields a value.--- This creates two threads each time this combinator is used.--- Warning: This means that the monadic effects are run in isolation from each other--- so if the monad is something like (StateT s IO), then the state will alternate--- between the two input producers, which is most likely not what you want.-newtype ReactIO m a = ReactIO-    { reactivelyIO :: P.Producer a m ()-    }--makeWrapped ''ReactIO--instance Monad m => Functor (ReactIO m) where-  fmap f (ReactIO as) = ReactIO $ as P.>-> PP.map f-  {-# INLINABLE fmap #-}--instance (MonadBaseControl IO m, Forall (A.Pure m)) => Applicative (ReactIO m) where-    pure = ReactIO . P.yield-    {-# INLINABLE pure #-}--    -- 'ap' doesn't know about initial values-    fs <*> as = ReactIO $ P.for (reactivelyIO $ merge fs as) $ \r ->-        case r of-            Coupled _ f a -> P.yield $ f a-            -- never got anything from one of the signals, can't do anything yet.-            -- drop the event-            LeftOnly _ _ -> pure ()-            RightOnly _ _-> pure ()-    {-# INLINABLE (<*>) #-}---- | Reactively combines two producers, given initial values to use when the produce hasn't produced anything yet--- Combine two signals, and returns a signal that emits--- @Either bothfired (Either (leftFired, previousRight) (previousLeft, rightFired))@.--- This creates two threads each time this combinator is used.--- Warning: This means that the monadic effects are run in isolation from each other--- so if the monad is something like (StateT s IO), then the state will alternate--- between the two input producers, which is most likely not what you want.--- This will be detect as a compile error due to use of Control.Concurrent.Async.Lifted.Safe-instance (MonadBaseControl IO m, Forall (A.Pure m)) => Merge (ReactIO m) where-    merge' px_ py_ (ReactIO xs_) (ReactIO ys_) = ReactIO $ do-        ax <- lift $ A.async $ P.next xs_-        ay <- lift $ A.async $ P.next ys_-        doMergeIO px_ py_ ax ay-      where-        doMergeIO :: (MonadBaseControl IO m, Forall (A.Pure m)) =>-             Maybe x-          -> Maybe y-          -> A.Async (Either () (x, P.Producer x m ()))-          -> A.Async (Either () (y, P.Producer y m ()))-          -> P.Producer (Merged x y) m ()-        doMergeIO px py ax ay = do-            r <--                lift $-                liftBase . S.atomically $ bothOrEither (A.waitSTM ax) (A.waitSTM ay)-            case r of-                -- both @ax@ and @ay@ have ended-                These (Left _) (Left _) -> pure ()-                -- @ax@ ended,                @ay@ still waiting-                This (Left _) -> do-                    ry <- lift $ A.wait ay -- wait for @ay@ to return and then-                                           -- only use @ys@-                    case ry of-                        Left _ -> pure ()-                        Right (y, ys') -> case px of-                            Nothing -> do-                                P.yield $ RightOnly OtherDead y-                                ys' P.>-> PP.map (RightOnly OtherDead)-                            Just x -> do-                                P.yield $ Coupled (FromRight OtherDead) x y-                                ys' P.>-> PP.map (Coupled (FromRight OtherDead) x)-                -- @ax@ still waiting,        @ay@ ended-                That (Left _) -> do-                    rx <- lift $ A.wait ax -- wait for @ax@ to retrun and then-                                           -- only use @xs@-                    case rx of-                        Left _ -> pure ()-                        Right (x, xs') -> case py of-                            Nothing -> do-                                P.yield $ LeftOnly OtherDead x-                                xs' P.>-> PP.map (LeftOnly OtherDead)-                            Just y -> do-                                P.yield $ Coupled (FromLeft OtherDead) x y-                                xs' P.>-> PP.map (\x' -> Coupled (FromLeft OtherDead) x' y)-                -- @ax@ produced something,   @ay@ still waiting-                This (Right (x, xs')) -> do-                    case py of-                        Nothing -> P.yield $ LeftOnly OtherLive x-                        Just y -> P.yield $ Coupled (FromLeft OtherLive) x y-                    ax' <- lift $ A.async $ P.next xs'-                    doMergeIO (Just x) py ax' ay-                -- @ax@ still waiting,        @ay@ produced something-                That (Right (y, ys')) -> do-                    case px of-                        Nothing -> P.yield $ RightOnly OtherLive y-                        Just x -> P.yield $ Coupled (FromRight OtherLive) x y-                    ay' <- lift $ A.async $ P.next ys'-                    doMergeIO px (Just y) ax ay'-                -- @ax@ produced something,   @ay@ ended-                These (Right (x, xs')) (Left _) ->-                    case py of-                        Nothing -> do-                            P.yield $ LeftOnly OtherDead x-                            xs' P.>-> PP.map (LeftOnly OtherDead)-                        Just y -> do-                            P.yield $ Coupled (FromLeft OtherDead) x y-                            xs' P.>-> PP.map (\x' -> Coupled (FromLeft OtherDead) x' y)-                -- @af@ ended,                @aa@ produced something-                These (Left _) (Right (y, ys')) ->-                    case px of-                        Nothing -> do-                            P.yield $ RightOnly OtherDead y-                            ys' P.>-> PP.map (RightOnly OtherDead)-                        Just x -> do-                            P.yield $ Coupled (FromRight OtherDead) x y-                            ys' P.>-> PP.map (Coupled (FromRight OtherDead) x)-                -- both @fs@ and @as@ produced something-                These (Right (x, xs')) (Right (y, ys')) -> do-                    P.yield $ Coupled FromBoth x y-                    ax' <- lift $ A.async $ P.next xs'-                    ay' <- lift $ A.async $ P.next ys'-                    doMergeIO (Just x) (Just y) ax' ay'-    {-# INLINABLE merge' #-}---- | Used internally by React and ReactIO identifying which side (or both) returned values-bothOrEither :: Alternative f => f a -> f b -> f (These a b)-bothOrEither left right =-  (These <$> left <*> right)-  <|>-  (This <$> left)-  <|>-  (That <$> right)-{-# INLINABLE bothOrEither #-}
test/Spec.hs view
@@ -19,8 +19,8 @@ import Data.Maybe import qualified Pipes as P import qualified Pipes.Concurrent as PC-import qualified Pipes.Fluid.React as PF-import qualified Pipes.Fluid.ReactIO as PF+import qualified Pipes.Fluid.Impulse as PF+import qualified Pipes.Fluid.ImpulseIO as PF import qualified Pipes.Fluid.Sync as PF import qualified Pipes.Misc.Concurrent as PM import qualified Pipes.Misc.State.Strict as PM@@ -101,71 +101,71 @@                         PF.synchronously $                         (\a b -> (a, b, a + b)) <$> PF.Sync as <*> PF.Sync bs                 xs `shouldBe` (\(a, b) -> (a, b, a + b)) <$> zip data1 data2-        describe "React" $ do-            it "React STM: yield a value whenever any producer yields a value" $ do+        describe "Impulse" $ do+            it "Impulse STM: yield a value whenever any producer yields a value" $ do                 xs <-                     testSig' False $ \as bs ->                         PP.toListM $                         hoist atomically $-                        PF.reactively $-                        (\a b -> (a, b, a + b)) <$> PF.React as <*> PF.React bs+                        PF.impulsively $+                        (\a b -> (a, b, a + b)) <$> PF.Impulse as <*> PF.Impulse bs                 xs `shouldSatisfy` isBigger-            it "React IdentityT STM: reactively yields under 't STM'" $ do+            it "Impulse IdentityT STM: impulsively yields under 't STM'" $ do                 xs <-                     testSig' False $ \as bs ->                         runIdentityT $                         PP.toListM $                         hoist (hoist atomically) $-                        PF.reactively $-                        (\a b -> (a, b, a + b)) <$> (PF.React $ hoist lift as) <*>-                        (PF.React $ hoist lift bs)+                        PF.impulsively $+                        (\a b -> (a, b, a + b)) <$> (PF.Impulse $ hoist lift as) <*>+                        (PF.Impulse $ hoist lift bs)                 xs `shouldSatisfy` isBigger-            it "React StateT STM: reactively yields under 'StateT STM'" $ do+            it "Impulse StateT STM: impulsively yields under 'StateT STM'" $ do                 xs <-                     testSig' False $ \as bs ->                         (`evalStateT` (Model 0 0)) $                         PP.toListM $                         (hoist (hoist atomically) $-                         PF.reactively $+                         PF.impulsively $                          (\a b -> (a, b, a + b)) <$>-                         (PF.React $ hoist lift as P.>-> PM.store id counter1) <*>-                         (PF.React $ hoist lift bs P.>-> PM.store id counter2)) P.>->+                         (PF.Impulse $ hoist lift as P.>-> PM.store id counter1) <*>+                         (PF.Impulse $ hoist lift bs P.>-> PM.store id counter2)) P.>->                         PM.retrieve id                 xs `shouldSatisfy` isBigger-            it "React Merge: yield a Left/Right value depending on which producer yields a value" $ do+            it "Impulse Merge: yield a Left/Right value depending on which producer yields a value" $ do                 xs <-                     testSig' False $ \as bs ->                         PP.toListM $                         hoist atomically $-                        PF.reactively $-                        PF.React as `PF.merge`PF.React bs+                        PF.impulsively $+                        PF.Impulse as `PF.merge`PF.Impulse bs                 xs `shouldSatisfy` isDifferent-        describe "ReactIO" $ do-            it "React IO: reactively yield under IO using lifted-async" $ do+        describe "ImpulseIO" $ do+            it "Impulse IO: impulsively yield under IO using lifted-async" $ do                 xs <-                     testSig' False $ \as bs ->                         PP.toListM $-                        PF.reactivelyIO $-                        (\a b -> (a, b, a + b)) <$> (PF.ReactIO $ hoist atomically as) <*>-                        (PF.ReactIO $ hoist atomically bs)+                        PF.impulsivelyIO $+                        (\a b -> (a, b, a + b)) <$> (PF.ImpulseIO $ hoist atomically as) <*>+                        (PF.ImpulseIO $ hoist atomically bs)                 xs `shouldSatisfy` isBigger-            it "React IdentityT IO: reactively yield under 't IO' using lifted-async" $ do+            it "Impulse IdentityT IO: impulsively yield under 't IO' using lifted-async" $ do                 xs <-                     testSig' False $ \as bs ->                         runIdentityT $                         PP.toListM $-                        PF.reactivelyIO $-                        (\a b -> (a, b, a + b)) <$> (PF.ReactIO $ hoist (lift . atomically) as) <*>-                        (PF.ReactIO $ hoist (lift . atomically) bs)+                        PF.impulsivelyIO $+                        (\a b -> (a, b, a + b)) <$> (PF.ImpulseIO $ hoist (lift . atomically) as) <*>+                        (PF.ImpulseIO $ hoist (lift . atomically) bs)                 xs `shouldSatisfy` isBigger-            it "\nReact StateT IO is unsafe (lift-async detect this as a compile error)" $ do+            it "\nImpulse StateT IO is unsafe (lift-async detect this as a compile error)" $ do                 pure () `shouldReturn` ()-            it "ReactIO Merge: yield a Left/Right value depending on which producer yields a value" $ do+            it "ImpulseIO Merge: yield a Left/Right value depending on which producer yields a value" $ do                 xs <-                     testSig' False $ \as bs ->                         PP.toListM $-                        PF.reactivelyIO $-                        (PF.ReactIO $ hoist atomically as) `PF.merge` (PF.ReactIO $ hoist atomically bs)+                        PF.impulsivelyIO $+                        (PF.ImpulseIO $ hoist atomically as) `PF.merge` (PF.ImpulseIO $ hoist atomically bs)                 xs `shouldSatisfy` isDifferent  isBigger :: Ord a => [a] -> Bool