objective 0.6.1 → 0.6.2

raw patch · 9 files changed

+300/−71 lines, 9 filesdep +freedep +hashabledep +kan-extensionsdep ~elevator

Dependencies added: free, hashable, kan-extensions, unordered-containers, witherable

Dependency ranges changed: elevator

Files

.travis.yml +10/−1
CHANGELOG.md +28/−1
objective.cabal +3/−3
src/Control/Monad/Objective/Class.hs +20/−9
src/Control/Monad/Objective/IO.hs +1/−1
src/Control/Monad/Objective/ST.hs +1/−1
src/Control/Object.hs +197/−53
src/Data/Functor/PushPull.hs +31/−1
src/Data/Functor/Request.hs +9/−1

.travis.yml view

@@ -1,1 +1,10 @@-language: haskell+language: haskell
+
+env:
+  - GHCVER=7.8.3
+
+before_install:
+  - sudo add-apt-repository -y ppa:hvr/ghc
+  - sudo apt-get update
+  - sudo apt-get install -y -qq cabal-install-1.20 ghc-$GHCVER
+  - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.20/bin:$PATH

CHANGELOG.md view

@@ -1,7 +1,34 @@+0.6.2
+----
+* Added `announce`, `announceMaybe` and `announceMaybeT` which invoke a method for every objects in a container.
+* Added `(@**@)` and `(@||@)`.
+* Renamed `(.>>.)` to `(@>>@)`, `.|>.` to `(@|>@)` for consistency.
+* Added `filterPush`.
+* Added `iterObject`, `iterTObject`, `iterative`, `iterativeT` for free monads.
+* Renamed `runSequential` to `(@!)`.
+* Added combinators for `ReifiedProgramT`: `(@!!)` and `sequentialT`.
+* Changed the semantics of `variable` to accept `StateT`.
+* Added `flyweight'` that relies on HashMap
+* Added `MonadObjective` constraint
+
+0.6.1
+-----
+* Fixed the wrong constraints of `request`
+
+0.6
+-----
+* `PushPull` has more `Floors`
+* Added `Applicative` instance for `Request`
+* Reformed around Control.Monad.Objective
+  * Instance f g m ==> Inst m f g
+  * `invoke` takes two transformations for lifting
+  * Added lifted versions of `new`: `newIO` and `newST`
+
 0.5.2
 -----
 * Added Process
 * Added `runSequential`, `sequential` for operational monad
+* Added `flyweight`
 
 0.5.1
 -----
@@ -18,4 +45,4 @@ -----
 * Added Request functor along with Lift
 * Supported "extensible" objects using open unions
-* AccessT is now obsolete+* AccessT is now obsolete

objective.cabal view

@@ -1,5 +1,5 @@ name:                objective
-version:             0.6.1
+version:             0.6.2
 synopsis:            Extensible objects
 description:         Stateful effect transducer
 homepage:            https://github.com/fumieval/objective
@@ -23,9 +23,9 @@                      , Control.Monad.Objective.ST
                      , Data.Functor.Request
                      , Data.Functor.PushPull
-  -- other-modules:       
+  -- other-modules:
   other-extensions:    MultiParamTypeClasses, KindSignatures, TypeFamilies
-  build-depends:       base >=4.5 && <5, transformers >= 0.3 && <0.5, clean-unions < 0.2, elevator, containers, minioperational >= 0.4 && <0.5, profunctors >= 4.0 && <5
+  build-depends:       base >=4.5 && <5, transformers >= 0.3 && <0.5, clean-unions < 0.2, elevator >= 0.1.2, containers, minioperational >= 0.4 && <0.5, profunctors >= 4.0 && <5, witherable <= 0.2, free >= 4.4 && <5, kan-extensions >= 4.1, unordered-containers, hashable >= 1.2 && <1.4
   ghc-options: -Wall
   hs-source-dirs:      src
   default-language:    Haskell2010

src/Control/Monad/Objective/Class.hs view

@@ -22,33 +22,34 @@ -----------------------------------------------------------------------------
 module Control.Monad.Objective.Class where
 import Control.Object
-
 import Control.Elevator
 import Control.Monad.Trans.State.Strict
+import Control.Monad.Operational.Mini
+import Control.Monad
 
 type Inst' f g = Inst g f g
-type Instance' f g = Inst g f g
-type Instance f g m = Inst m f g
 
-class ObjectiveBase b where
+class Monad b => ObjectiveBase b where
   data Inst b (f :: * -> *) (g :: * -> *)
   new :: Object f g -> b (Inst b f g)
-  invoke :: Monad r => (forall x. b x -> r x) -> (forall x. g x -> r x) -> Inst b f g -> f a -> r a
+  invoke :: Monad m => (forall x. b x -> m x) -> (forall x. g x -> m x) -> Inst b f g -> f a -> m a
 
-(.-) :: (ObjectiveBase b, Elevate b m, Elevate g m, Monad m) => Inst b f g -> f a -> m a
+type MonadObjective b m = (ObjectiveBase b, Elevate b m, Monad m)
+
+(.-) :: (MonadObjective b m, Elevate g m) => Inst b f g -> f a -> m a
 (.-) = invoke elevate elevate
 {-# INLINE (.-) #-}
 
 infix 3 .-
 
 -- | Invoke a method.
-(.^) :: (ObjectiveBase b, Elevate b m, Elevate g m, Monad m, Elevate e f) => Inst b f g -> e a -> m a
+(.^) :: (MonadObjective b m, Elevate g m, Elevate e f) => Inst b f g -> e a -> m a
 i .^ e = i .- elevate e
 {-# INLINE (.^) #-}
 infix 3 .^
 
--- | Specialized (.^) for StateT
-(.&) :: (ObjectiveBase b, Elevate b m, Elevate g m, Monad m, Elevate (State s) f) => Inst b f g -> StateT s m a -> m a
+-- | (.^) for StateT
+(.&) :: (MonadObjective b m, Elevate g m, Elevate (State s) f) => Inst b f g -> StateT s m a -> m a
 i .& m = do
   s <- i .^ get
   (a, s') <- runStateT m s
@@ -56,3 +57,13 @@   return a
 
 infix 3 .&
+
+(.!) :: (MonadObjective b m, Elevate g m) => Inst b f g -> Program f a -> m a
+(.!) i = interpret (i.-)
+
+infix 3 .!
+
+-- | We can convert method invocation into an object trivially.
+-- @invocation i = liftO (i.-)@
+invocation :: (MonadObjective b m, Elevate g m) => Inst b f g -> Object f m
+invocation i = Object $ liftM (\a -> (a, invocation i)). (i.-)

src/Control/Monad/Objective/IO.hs view

@@ -31,4 +31,4 @@   new v = InstIO `fmap` newMVar v
 
 newIO :: MonadIO m => Object f g -> m (Inst IO f g)
-newIO = liftIO . new+newIO = liftIO . new

src/Control/Monad/Objective/ST.hs view

@@ -33,4 +33,4 @@   new o = InstST `fmap` newSTRef o
 
 newST :: Elevate (ST s) m => Object f g -> m (Inst (ST s) f g)
-newST = elevate . new+newST = elevate . new

src/Control/Object.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE Rank2Types, FlexibleInstances, FlexibleContexts, TypeOperators, CPP #-}
+{-# LANGUAGE Rank2Types, FlexibleInstances, FlexibleContexts, TypeOperators, CPP, ConstraintKinds #-}
 #if __GLASGOW_HASKELL__ >= 707
 {-# LANGUAGE DeriveDataTypeable #-}
 #endif
@@ -23,48 +23,82 @@   oneshot,
   stateful,
   variable,
+  unfoldO,
+  unfoldOM,
+  foldP,
+  foldP',
+  sharing,
   -- * Composition
-  (.>>.),
+  (@>>@),
+  (@>>^),
+  (^>>@),
+  (@**@),
+  (@||@),
+  loner,
+  (@|>@),
   transObject,
   adaptObject,
+  -- * Monads
+  (@!),
+  (@!!),
   sequential,
-  runSequential,
-  -- * Multifunctional objects
-  loner,
-  (.|>.),
-  sharing,
+  sequentialT,
+  iterObject,
+  iterTObject,
+  iterative,
+  iterativeT,
   -- * Patterns
   flyweight,
+  flyweight',
+  announce,
+  announceMaybe,
+  announceMaybeT,
   Process(..),
-  _Process
+  _Process,
+  -- * Deprecated
+  runSequential
   )
 where
 
-import Control.Monad.Trans.State.Strict
-import Control.Monad
-import Data.Typeable
 import Control.Applicative
-import Data.OpenUnion1.Clean
-import qualified Data.Map as Map
-import Data.Functor.Request
-import Control.Monad.Operational.Mini
 import Control.Arrow
-import qualified Control.Category as C
-import Data.Profunctor
+import Control.Monad
+import Control.Monad.Operational.Mini
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.State.Strict
+import Control.Monad.Trans.Writer.Strict
+import Control.Monad.Trans.Class
+import Control.Elevator
+import Data.Functor.Request
+import Data.Functor.PushPull
 import Data.Monoid
+import Data.OpenUnion1.Clean
+import Data.Profunctor
+import Data.Typeable
+import Data.Witherable
+import qualified Control.Category as C
+import qualified Control.Monad.Trans.Operational.Mini as T
+import qualified Control.Monad.Trans.Free as T
+import qualified Data.Map.Strict as Map
+import qualified Data.Traversable as T
+import Control.Monad.Free
+import qualified Data.HashMap.Strict as HM
+import Data.Functor.Day
+import Data.Functor.Sum as F
+import Data.Hashable
 
--- | The type 'Object e m' represents objects which can handle messages @e@, perform actions in the environment @m@.
+-- | The type 'Object f g' represents objects which can handle messages @f@, perform actions in the environment @g@.
 -- It can be thought of as an automaton that converts effects.
--- 'Object's can be composed just like functions using '.>>.'; the identity element is 'echo'.
-newtype Object e m = Object { runObject :: forall x. e x -> m (x, Object e m) }
+-- 'Object's can be composed just like functions using '@>>@'; the identity element is 'echo'.
+newtype Object f g = Object { runObject :: forall x. f x -> g (x, Object f g) }
 #if __GLASGOW_HASKELL__ >= 707
   deriving (Typeable)
 #else
-instance (Typeable1 f, Typeable1 m) => Typeable (Object f m) where
+instance (Typeable1 f, Typeable1 g) => Typeable (Object f g) where
   typeOf t = mkTyConApp objectTyCon [typeOf1 (f t), typeOf1 (g t)] where
-    f :: Object f m -> f a
+    f :: Object f g -> f a
     f = undefined
-    g :: Object f m -> m a
+    g :: Object f g -> g a
     g = undefined
 
 objectTyCon :: TyCon
@@ -76,46 +110,79 @@ {-# NOINLINE objectTyCon #-}
 #endif
 
+-- | The identity object
+echo :: Functor f => Object f f
+echo = Object (fmap (\x -> (x, echo)))
+
+-- | Object-object composition
+(@>>@) :: Functor h => Object f g -> Object g h -> Object f h
+Object m @>>@ Object n = Object $ \e -> fmap (\((x, m'), n') -> (x, m' @>>@ n')) $ n (m e)
+infixr 1 @>>@
+
+-- | Object-function composition
+(@>>^) :: Functor h => Object f g -> (forall x. g x -> h x) -> Object f h
+m0 @>>^ g = go m0 where go (Object m) = Object $ fmap (fmap go) . g . m
+infixr 1 @>>^
+
+-- | Function-object composition
+(^>>@) :: Functor h => (forall x. f x -> g x) -> Object g h -> Object f h
+f ^>>@ m0 = go m0 where go (Object m) = Object $ fmap (fmap go) . m . f
+infixr 1 ^>>@
+
+(@**@) :: Applicative m => Object f m -> Object g m -> Object (Day f g) m
+a @**@ b = Object $ \(Day f g r) -> (\(x, a') (y, b') -> (r x y, a' @**@ b')) <$> runObject a f <*> runObject b g
+infixr 3 @**@
+
+(@||@) :: Functor m => Object f m -> Object g m -> Object (F.Sum f g) m
+a @||@ b = Object $ \r -> case r of
+  InL f -> fmap (fmap (@||@b)) (runObject a f)
+  InR g -> fmap (fmap (a@||@)) (runObject b g)
+infixr 2 @||@
+
 -- | Lift a natural transformation into an object.
-liftO :: Functor f => (forall x. e x -> f x) -> Object e f
-liftO f = Object $ fmap (\x -> (x, liftO f)) . f
+liftO :: Functor g => (forall x. f x -> g x) -> Object f g
+liftO f = go where go = Object $ fmap (\x -> (x, go)) . f
+{-# INLINE liftO #-}
 
 -- | Change the workspace of the object.
 transObject :: Functor g => (forall x. f x -> g x) -> Object e f -> Object e g
-transObject f (Object m) = Object $ fmap (fmap (transObject f)) . f . m
+transObject f = (@>>^f)
 
 -- | Apply a function to the messages coming into the object.
-adaptObject :: Functor m => (forall x. e x -> f x) -> Object f m -> Object e m
-adaptObject f (Object m) = Object $ fmap (fmap (adaptObject f)) . m . f
-
--- | Parrots messages given.
-echo :: Functor e => Object e e
-echo = Object (fmap (\x -> (x, echo)))
-
--- | Compose two objects (aka Dependency Injection).
-(.>>.) :: Functor n => Object e m -> Object m n -> Object e n
-Object m .>>. Object n = Object $ \e -> fmap (\((x, m'), n') -> (x, m' .>>. n')) $ n (m e)
-
-infixr 4 .>>.
+adaptObject :: Functor m => (forall x. g x -> f x) -> Object f m -> Object g m
+adaptObject f = (f^>>@)
 
 -- | Build an object using continuation passing style.
-oneshot :: (Functor e, Monad m) => (forall a. e (m a) -> m a) -> Object e m
+oneshot :: (Functor f, Monad m) => (forall a. f (m a) -> m a) -> Object f m
 oneshot m = go where
   go = Object $ \e -> m (fmap return e) >>= \a -> return (a, go)
 {-# INLINE oneshot #-}
 
 -- | Build a stateful object.
-stateful :: Monad m => (forall a. e a -> StateT s m a) -> s -> Object e m
+-- @stateful t s = t ^>>@ variable s@
+stateful :: Monad m => (forall a. f a -> StateT s m a) -> s -> Object f m
 stateful h = go where
   go s = Object $ liftM (\(a, s') -> (a, go s')) . flip runStateT s . h
 {-# INLINE stateful #-}
 
+-- | The unwrapped analog of 'stateful'
+--     @unfoldO runObject = id@
+--     @unfoldO runSequential = sequential@
+--     @unfoldO iterObject = iterable@
+unfoldO :: Functor g => (forall a. r -> f a -> g (a, r)) -> r -> Object f g
+unfoldO h = go where go r = Object $ fmap (fmap go) . h r
+{-# INLINE unfoldO #-}
+
+unfoldOM :: Monad m => (forall a. r -> f a -> m (a, r)) -> r -> Object f m
+unfoldOM h = go where go r = Object $ liftM (fmap go) . h r
+{-# INLINE unfoldOM #-}
+
 -- | A mutable variable.
-variable :: Applicative f => s -> Object (State s) f
-variable s = Object $ \m -> let (a, s') = runState m s in pure (a, variable s')
+variable :: Monad m => s -> Object (StateT s m) m
+variable s = Object $ \m -> liftM (fmap variable) $ runStateT m s
 
 -- | Build a stateful object, sharing out the state.
-sharing :: Monad m => (forall a. e a -> StateT s m a) -> s -> Object (State s |> e |> Nil) m
+sharing :: Monad m => (forall a. f a -> StateT s m a) -> s -> Object (State s |> f |> Nil) m
 sharing m = go where
   go s = Object $ \k -> liftM (fmap go) $ ($k)
     $ (\n -> return $ runState n s)
@@ -124,30 +191,101 @@ {-# INLINE sharing #-}
 
 -- | An object that won't accept any messages.
-loner :: Functor m => Object Nil m
+loner :: Functor f => Object Nil f
 loner = liftO exhaust
 
 -- | Extend an object by adding another independent object.
-(.|>.) :: Functor m => Object f m -> Object (Union s) m -> Object (f |> Union s) m
-p .|>. q = Object $ fmap (fmap (.|>.q)) . runObject p ||> fmap (fmap (p .|>.)) . runObject q
-
-infixr 3 .|>.
+(@|>@) :: Functor g => Object f g -> Object (Union s) g -> Object (f |> Union s) g
+p @|>@ q = Object $ fmap (fmap (@|>@q)) . runObject p ||> fmap (fmap (p @|>@)) . runObject q
+infixr 3 @|>@
 
 -- | The flyweight pattern.
-flyweight :: Monad m => Ord k => (k -> m a) -> Object (Request k a) m
+flyweight :: (Monad m, Ord k) => (k -> m a) -> Object (Request k a) m
 flyweight f = go Map.empty where
   go m = Object $ \(Request k cont) -> case Map.lookup k m of
     Just a -> return (cont a, go m)
     Nothing -> f k >>= \a -> return (cont a, go $ Map.insert k a m)
 
+-- | Like 'flyweight', but it uses 'Data.HashMap.Strict' internally.
+flyweight' :: (Monad m, Eq k, Hashable k) => (k -> m a) -> Object (Request k a) m
+flyweight' f = go HM.empty where
+  go m = Object $ \(Request k cont) -> case HM.lookup k m of
+    Just a -> return (cont a, go m)
+    Nothing -> f k >>= \a -> return (cont a, go $ HM.insert k a m)
+
+(@!) :: Monad m => Object e m -> ReifiedProgram e a -> m (a, Object e m)
+obj @! Return a = return (a, obj)
+obj @! (e :>>= cont) = runObject obj e >>= \(a, obj') -> obj' @! cont a
+
+(@!!) :: Monad m => Object e m -> T.ReifiedProgramT e m a -> m (a, Object e m)
+obj @!! T.Return a = return (a, obj)
+obj @!! T.Lift m cont = m >>= (obj @!!) . cont
+obj @!! (e T.:>>= cont) = runObject obj e >>= \(a, obj') -> obj' @!! cont a
+
 runSequential :: Monad m => Object e m -> ReifiedProgram e a -> m (a, Object e m)
-runSequential obj (Return a) = return (a, obj)
-runSequential obj (e :>>= cont) = runObject obj e >>= \(a, obj') -> runSequential obj' (cont a)
+runSequential = (@!)
+{-# DEPRECATED runSequential "use (@!!) instead" #-}
 
+iterObject :: Monad m => Object f m -> Free f a -> m (a, Object f m)
+iterObject obj (Pure a) = return (a, obj)
+iterObject obj (Free f) = runObject obj f >>= \(cont, obj') -> iterObject obj' cont
+
+iterTObject :: Monad m => Object f m -> T.FreeT f m a -> m (a, Object f m)
+iterTObject obj m = T.runFreeT m >>= \r -> case r of
+  T.Pure a -> return (a, obj)
+  T.Free f -> runObject obj f >>= \(cont, obj') -> iterTObject obj' cont
+
 -- | Let object handle sequential methods.
 sequential :: Monad m => Object e m -> Object (ReifiedProgram e) m
-sequential obj = Object $ liftM (fmap sequential) . runSequential obj
+sequential = unfoldOM (@!)
 
+-- | Let object handle sequential methods.
+sequentialT :: Monad m => Object e m -> Object (T.ReifiedProgramT e m) m
+sequentialT = unfoldOM (@!!)
+
+iterative :: Monad m => Object f m -> Object (Free f) m
+iterative = unfoldOM iterObject
+
+iterativeT :: Monad m => Object f m -> Object (T.FreeT f m) m
+iterativeT = unfoldOM iterTObject
+
+foldP :: Applicative f => (a -> r -> f r) -> r -> Object (PushPull a r) f
+foldP f = go where
+  go r = Object $ \pp -> case pp of
+    Push a c -> fmap (\z -> (c, z `seq` go z)) (f a r)
+    Pull cont -> pure (cont r, go r)
+{-# INLINE foldP #-}
+
+foldP' :: Applicative f => (a -> r -> r) -> r -> Object (PushPull a r) f
+foldP' f = go where
+  go r = Object $ \pp -> case pp of
+    Push a c -> let z = f a r in pure (c, z `seq` go z)
+    Pull cont -> pure (cont r, go r)
+{-# INLINE foldP' #-}
+
+announce :: (T.Traversable t, Monad m, Elevate (State (t (Object f g))) m, Elevate g m) => f a -> m [a]
+announce f = do
+  t <- elevate get
+  (t', Endo e) <- runWriterT $ T.mapM (\obj -> (lift . elevate) (runObject obj f)
+      >>= \(x, obj') -> writer (obj', Endo (x:))) t
+  elevate (put t')
+  return (e [])
+
+announceMaybe :: (Witherable t, Monad m, Elevate (State (t (Object f Maybe))) m) => f a -> m [a]
+announceMaybe f = elevate $ state
+  $ \t -> let (t', Endo e) = runWriter
+                $ witherM (\obj -> case runObject obj f of
+                  Just (x, obj') -> lift $ writer (obj', Endo (x:))
+                  Nothing -> mzero) t in (e [], t')
+
+announceMaybeT :: (Witherable t, Monad m, State (t (Object f (MaybeT g))) ∈ Floors1 m, g ∈ Floors1 m, Tower m) => f a -> m [a]
+announceMaybeT f = do
+  t <- elevate get
+  (t', Endo e) <- runWriterT $ witherM (\obj -> mapMaybeT (lift . elevate) (runObject obj f)
+      >>= \(x, obj') -> lift (writer (obj', Endo (x:)))) t
+  elevate (put t')
+  return (e [])
+
 -- | An object which is specialized to be a Mealy machine
 newtype Process m a b = Process { unProcess :: Object (Request a b) m }
 
@@ -182,12 +320,18 @@     go = Object $ \(Request a cont) -> return (cont (f a), go)
   first (Process f0) = Process $ go f0 where
     go f = Object $ \(Request (a, c) cont) -> liftM (\(b, f') -> (cont (b, c), go f')) $ runObject f (Request a id)
+  second (Process f0) = Process $ go f0 where
+    go f = Object $ \(Request (a, c) cont) -> liftM (\(d, f') -> (cont (a, d), go f')) $ runObject f (Request c id)
 
 instance Monad m => ArrowChoice (Process m) where
   left (Process f0) = Process $ go f0 where
     go f = Object $ \(Request e cont) -> case e of
       Left a -> liftM (\(b, f') -> (cont (Left b), go f')) $ runObject f (Request a id)
       Right c -> return (cont (Right c), go f)
+  right (Process f0) = Process $ go f0 where
+    go f = Object $ \(Request e cont) -> case e of
+      Right a -> liftM (\(b, f') -> (cont (Right b), go f')) $ runObject f (Request a id)
+      Left c -> return (cont (Left c), go f)
 
 instance Monad m => Profunctor (Process m) where
   dimap f g (Process f0) = Process (go f0) where
@@ -203,7 +347,7 @@ instance Monad m => Choice (Process m) where
   left' = left
   {-# INLINE left' #-}
-  right' = right 
+  right' = right
   {-# INLINE right' #-}
 
 instance (Applicative m, Num o) => Num (Process m i o) where

src/Data/Functor/PushPull.hs view

@@ -14,16 +14,46 @@ import Data.Typeable
 import Control.Elevator
 import Data.OpenUnion1.Clean
+import Control.Applicative
+import Data.Profunctor
+import Data.Functor.Day
 
 -- | The type for asynchronous input/output.
 data PushPull a b r = Push a r | Pull (b -> r) deriving (Functor, Typeable)
 
+type PushPull' a = PushPull a a
+
+instance Profunctor (PushPull a) where
+  dimap _ g (Push a r) = Push a (g r)
+  dimap f g (Pull br) = Pull (dimap f g br)
+
 instance Tower (PushPull a b) where
   type Floors (PushPull a b) = (,) a :> (->) b :> Empty
   toLoft = uncurry Push ||> Pull ||> exhaust
 
+mapPush :: (a -> a') -> PushPull a b r -> PushPull a' b r
+mapPush f (Push a r) = Push (f a) r
+mapPush _ (Pull br) = Pull br
+
 push :: (Elevate (PushPull a b) f) => a -> f ()
 push a = elevate (Push a ())
 
 pull :: (Elevate (PushPull a b) f) => f b
-pull = elevate (Pull id)+pull = elevate (Pull id)
+
+bipush :: (i -> (a, c)) -> (b -> d -> o) -> PushPull i o r -> Day (PushPull a b) (PushPull c d) r
+bipush f g = go where
+  go (Pull r) = Day (Pull id) (Pull id) (fmap r . g)
+  go (Push i r) = let (a, b) = f i in Day (Push a ()) (Push b ()) (\_ _ -> r)
+{-# INLINE bipush #-}
+
+bipull :: (a -> b -> c) -> PushPull i c r -> Day (PushPull i a) (PushPull i b) r
+bipull = bipush (\x -> (x, x))
+{-# INLINE bipull #-}
+
+-- | @filterPush :: (a -> Bool) -> PushPull a b r -> Program (PushPull a b) r@
+filterPush :: (Applicative f, Elevate (PushPull a b) f) => (a -> Bool) -> PushPull a b r -> f r
+filterPush p e@(Push a r)
+  | p a = elevate e
+  | otherwise = pure r
+filterPush _ e = elevate e

src/Data/Functor/Request.hs view

@@ -17,10 +17,18 @@ import Data.Monoid
 import Control.Applicative
 import Data.OpenUnion1.Clean
-import Data.Functor.Identity
+import Data.Profunctor
 
 -- | 'Request a b' is the type of a request that sends @a@ to receive @b@.
 data Request a b r = Request a (b -> r) deriving (Functor, Typeable)
+
+mapRequest :: (a -> a') -> Request a b r -> Request a' b r
+mapRequest f (Request a br) = Request (f a) br
+{-# INLINE mapRequest #-}
+
+instance Profunctor (Request a) where
+  dimap f g (Request a br) = Request a (dimap f g br)
+  {-# INLINE dimap #-}
 
 instance Monoid a => Applicative (Request a b) where
   pure a = Request mempty (const a)