Prototype of the Church-encoded Proxy for pipes

PipesChurch.hs

{-# LANGUAGE RankNTypes #-}

module Pipes.Church where

import Control.Monad (replicateM, liftM, join)
import Control.Monad.Trans.Class

--------------------------------------------------------------------------------
--
-- The "classical" implementation
--

data Pipe i o m r
  = Done r
  | Await (i -> Pipe i o m r)
  | Yield o (Pipe i o m r)
  | M (m (Pipe i o m r))

instance (Functor m) => Functor (Pipe i o m) where
  fmap f p = case p of
    Await fi -> Await (fmap f .fi)
    Yield o fo -> Yield o (fmap f fo)
    Done r -> Done (f r)
    M sc -> M (fmap (fmap f) sc)

instance (Monad m) => Monad (Pipe i o m) where
  return = Done

  (Await fi) >>= f = Await (\i -> fi i >>= f)
  (Yield o fo) >>= f = Yield o (fo >>= f)
  (Done r) >>= f = f r
  (M sc) >>= f = M (liftM (>>= f) sc)

instance MonadTrans (Pipe i o) where
  lift op = M (liftM Done op)

runEffect :: (Monad m) => Pipe i o m r -> m r
runEffect p = case p of
  Await _ -> error "runEffect: Await"
  Yield _ _ -> error "runEffect: Yield"
  Done r -> return r
  M sc -> sc >>= runEffect

(>->) :: Monad m => Pipe i e m r -> Pipe e o m r -> Pipe i o m r
up >-> down = go down
  where
    go (Yield o fo) = Yield o (go fo)
    go (Await fe) = up >~> fe
    go (Done r) = Done r
    go (M sc) = M (liftM go sc)

(>~>) :: Monad m => Pipe i e m r -> (e -> Pipe e o m r) -> Pipe i o m r
up >~> down = go up
  where
    go (Await fi) = Await (\i -> go (fi i))
    go (Yield e fe) = fe >-> down e
    go (Done r) = Done r
    go (M sc) = M (liftM go sc)


yield :: o -> Pipe i o m ()
yield o = Yield o (Done ())

await :: Pipe i o m i
await = Await Done

pull :: Pipe e e m r
pull = Await (\e -> Yield e pull)

numbers :: Monad m => Pipe i Int m r
numbers = go 0
  where
    go k = Yield k (go (k+1))

--------------------------------------------------------------------------------
--
-- The Church-encoded implementation
--

newtype PipeC i o m a = PipeC {
  runPipeC :: forall r.
              (a -> r)
              -> (o -> r -> r)
              -> ((i -> r) -> r)
              -> (m r -> r)
              -> r }

instance Functor (PipeC i o m) where
  fmap f (PipeC p) = PipeC (\ret -> p (ret . f))

instance Monad (PipeC i o m) where
  return a = PipeC (\ret _ _ _ -> ret a)
  (PipeC p) >>= f = PipeC (\ret yi aw mm -> p (\a -> runPipeC (f a) ret yi aw mm) yi aw mm)

instance MonadTrans (PipeC i o) where
  lift op = PipeC (\ret _ _ mm -> mm (liftM ret op))

runEffectC :: Monad m => PipeC i o m a -> m a
runEffectC (PipeC p) = p return (error "runEffectC: yield") (error "runEffectC: await") join

yieldC :: o -> PipeC i o m ()
yieldC o = PipeC (\ret yi _ _ -> yi o (ret ()))

awaitC :: PipeC i o m i
awaitC = PipeC (\ret _ aw _ -> aw ret)

pullC :: PipeC e e m a
pullC = PipeC (\_ yi aw _ -> let res = aw (\e -> yi e res) in res)

toPipe :: PipeC i o m a -> Pipe i o m a
toPipe (PipeC p) = p Done Yield Await M

fromPipe :: Monad m => Pipe i o m a -> PipeC i o m a
fromPipe p = PipeC res
  where
    res ret yi aw mm = go p
      where
        go (Done a) = ret a
        go (Yield o fo) = yi o (go fo)
        go (Await fi) = aw (go . fi)
        go (M sc) = mm (liftM go sc)


(>!->) :: Monad m => PipeC i e m a -> PipeC e o m a -> PipeC i o m a
up >!-> down = fromPipe $ toPipe up >-> toPipe down

numbersC :: PipeC i Int m r
numbersC = PipeC (\_ yi _ _ -> let go k = yi k (go (k+1)) in go 0)

takeC :: Int -> PipeC e e m ()
takeC n = PipeC res
  where
    res ret yi aw _ = go n
      where
        go 0 = ret ()
        go k = aw (\e -> yi e (go (k-1)))

--------------------------------------------------------------------------------

main :: IO ()
main = do
  l <- runEffectC $ numbersC >!-> do { lift (print "Hello"); replicateM 100000 awaitC }
  print $ last l