Van Laarhoven pipes

VLPipes.hs

{-# LANGUAGE RecordWildCards #-}
import Control.Monad
import Control.Monad.Trans.Class
import Data.Void

data ProxyOps a' a b' b m = Ops { req :: a' -> m a, resp :: b -> m b' }

newtype Proxy a' a b' b m r = Proxy { runProxy :: ProxyOps a' a b' b m -> m r }

run :: ProxyOps a' a b' b m -> Proxy a' a b' b m r -> m r
run = flip runProxy

instance Monad m => Monad (Proxy a' a b' b m) where
  return = lift . return
  Proxy m >>= f = Proxy $ \ops -> m ops >>= run ops . f
  
instance MonadTrans (Proxy a' a b' b) where
  lift mr = Proxy $ \_ -> mr
  
runEffect :: Monad m => Proxy Void () () Void m r -> m r
runEffect = run Ops{ req = absurd, resp = absurd }

reflect :: Monad m => Proxy a' a b' b m r -> Proxy b b' a a' m r
reflect (Proxy f) = Proxy $ \Ops{..} -> f Ops{ resp = req, req = resp }

request :: Monad m => a' -> Proxy a' a y' y m a
request a' = Proxy $ \Ops{..} -> req a'

respond :: Monad m => a -> Proxy x' x a' a m a'
respond a = Proxy $ \Ops{..} -> resp a

pull :: Monad m => a' -> Proxy a' a a' a m r
pull a' = Proxy $ \Ops{..} -> let go = req >=> resp >=> go in go a'

push :: Monad m => a -> Proxy a' a a' a m r
push a = Proxy $ \Ops{..} -> let go = resp >=> req >=> go in go a

(//>) :: Monad m
      =>       Proxy x' x b' b m a'
      -> (b -> Proxy x' x c' c m b')
      ->       Proxy x' x c' c m a'
Proxy p //> fb = Proxy $ \ops -> p ops{ resp = run ops . fb }

(>\\) :: Monad m
      => (b' -> Proxy a' a y' y m b)
      ->        Proxy b' b y' y m c
      ->        Proxy a' a y' y m c
fb' >\\ Proxy p = Proxy $ \ops -> p ops{ req = run ops . fb' }