Sketches for a baby version of Pipes.

Straws.hs

{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
{-# LANGUAGE Rank2Types #-}

module Tuyau where

import Control.Applicative
import Control.Monad
import Control.Monad.Trans

import System.IO (isEOF)

data X

data Straw i o m r
  = Pure r
  | Step (m (Straw i o m r))
  | Pull (i -> Straw i o m r)
  | Push o (Straw i o m r)

instance Monad m => Functor (Straw i o m) where
  fmap f (Pure r) = Pure (f r)
  fmap f (Step ms) = Step (liftM (fmap f) ms)
  fmap f (Pull k) = Pull (fmap f . k)
  fmap f (Push o t) = Push o (fmap f t)

instance Monad m => Applicative (Straw i o m) where
  pure = Pure
  (Pure f) <*> tx = fmap f tx
  (Step mtf) <*> tx = Step (liftM (<*> tx) mtf)
  (Pull k) <*> tx = Pull ((<*> tx) . k)
  (Push o tf) <*> tx = Push o (tf <*> tx)

instance Monad m => Monad (Straw i o m) where
  return = Pure
  (Pure a) >>= f = f a
  (Step mta) >>= f = Step (liftM (>>= f) mta)
  (Pull k) >>= f = Pull ((>>= f) . k)
  (Push o t) >>= f = Push o (t >>= f)

instance MonadTrans (Straw i o) where
  lift = Step . liftM Pure

type Source  a m r = Straw X a m r
type Source' a m r = forall i. Straw i a m r
type Sink    a m r = Straw a X m r
type Sink'   a m r = forall o. Straw a o m r
type Effect  m r = Straw X X m r

runEffect :: Monad m => Effect m r -> m r
runEffect (Pure r) = return r
runEffect (Step ms) = ms >>= runEffect
runEffect (Pull k) = undefined -- impossible
runEffect (Push x s) = undefined -- impossible

pull :: Sink' a m a
pull = Pull Pure

push :: a -> Source' a m ()
push o = Push o (Pure ())

plug :: Monad m => Straw i x m r -> Straw x o m r -> Straw i o m r
plug s (Pure r)  = Pure r
plug s (Step ms') = Step (ms' >>= \s' -> return (plug s s'))
plug (Pure r) (Pull k') = Pure r
plug (Step ms) (Pull k') = Step (ms >>= \s -> return (plug s (Pull k')))
plug (Pull k) (Pull k') = Pull (\i -> plug (k i) (Pull k'))
plug (Push o s) (Pull k') = plug s (k' o)
plug s (Push o s') = Push o (plug s s')

s >-> s' = plug s s'
infixl 7 >->

cat :: Monad m => Straw a a m r
cat = forever $ pull >>= push

for :: Monad m => Straw i o m r -> (o -> Straw i o' m r') -> Straw i o' m r
for (Pure r) l = Pure r
for (Step ms) l = Step (liftM (flip for l) ms)
for (Pull k) l = Pull (flip for l . k)
for (Push o s) l = l o >> for s l

(f ~> g) x = for (f x) g
infixr 4 ~>

(>~) :: Monad m => Straw i o m r -> Straw r o m r' -> Straw i o m r'
s >~ (Pure r) = Pure r
s >~ (Step ms') = Step (ms' >>= \s' -> return (s >~ s'))
s >~ (Pull k) = s >>= (s >~) . k
s >~ (Push o s') = Push o (s >~ s')
infixr 5 >~

stdinLn :: Source String IO ()
stdinLn = do
  eof <- lift isEOF
  unless eof $ do
    push =<< lift getLine
    stdinLn

stdoutLn :: Sink String IO r
stdoutLn = do
  l <- pull
  lift $ putStrLn l
  stdoutLn

example :: IO r
example = runEffect $ lift getLine >~ stdoutLn

pullStraw :: Monad m => Straw Int o m Int
pullStraw = liftA2 (+) pull pull

pushStraw :: Num n => Source n IO n
pushStraw = do
  lift $ putStrLn "About to push 1"
  push 1
  lift $ putStrLn "About to push 2"
  push 2
  lift $ putStrLn "About to return 99"
  return 99