simplified Control.Pipe.Common following Twan van Laarhoven's pipe-conduit hybrid

pipe_conduit.hs

-- http://www.reddit.com/r/haskell/comments/rbgvz/conduits_vs_pipes_using_void_as_an_input_or

import Control.Monad
import Control.Applicative
import Data.Void
import System.IO

data Pipe m i o r =
  Finished (Maybe i) r
  | PipeM (m (Pipe m i o r)) (m r)
  | NeedInput (i -> Pipe m i o r) (Pipe m Void o r)
  | HaveOutput (Pipe m i o r) (m r) o

instance (Monad m) => Functor (Pipe m i o) where
  fmap f c = case c of
      Finished ma r        -> Finished ma (f r)
      PipeM mc mr          -> PipeM    (liftM (fmap f) mc)      (liftM f mr)
      NeedInput fc pipe    -> NeedInput (\i -> fmap f (fc i))   (fmap f pipe)
      HaveOutput pipe mr o -> HaveOutput      (fmap f pipe)     (liftM f mr) o

instance (Monad m) => Applicative (Pipe m i o) where
    pure = Finished Nothing
    f <*> x = case f of
      Finished _ r         -> fmap r x
      PipeM mc mr          -> PipeM (liftM (<*> x) mc)      (mr `ap` close x) 
      NeedInput fc pipe    -> NeedInput (\i -> fc i <*> x)  (pipe <*> convert x)
      HaveOutput pipe mr o -> HaveOutput      (pipe <*> x)  (mr `ap` close x)  o


instance Monad m => Monad (Pipe m i o) where
  return = Finished Nothing
  m >>= f = case m of
    Finished _ r         -> f r
    PipeM mc mr          -> PipeM (liftM (>>= f) mc)       (mr >>= close . f) 
    NeedInput fc pipe    -> NeedInput (\i -> fc i >>= f)   (pipe >>= convert . f)
    HaveOutput pipe mr o -> HaveOutput      (pipe >>= f)   (mr >>= close . f)  o

joinPipe :: Monad m => Pipe m i o (Pipe m i o r) -> Pipe m i o r
joinPipe (Finished _ pipe) = pipe
joinPipe (PipeM mc mr)  = PipeM          (liftM joinPipe mc)     (join $ liftM close mr)
joinPipe (NeedInput fc pipe) = NeedInput (\i -> joinPipe (fc i)) (joinPipe $ liftM convert pipe)
joinPipe (HaveOutput pipe mr o) = HaveOutput   (joinPipe pipe)   (join $ liftM close mr) o

close :: Monad m => Pipe m i o r -> m r
close (NeedInput _ a)    = close a
close (HaveOutput _ a _) = a
close (Finished _ a)     = return a
close (PipeM _ a)        = a

convert :: Monad m => Pipe m i o r -> Pipe m Void o r
convert (NeedInput _ pipe)     = pipe
convert (HaveOutput pipe mr o) = HaveOutput (convert pipe) mr o
convert (Finished _ r)         = Finished Nothing r
convert (PipeM mc mr)          = PipeM (liftM convert mc) mr


await :: Monad m => Pipe m i o i
await = NeedInput (Finished Nothing) (convert await)

yield :: Monad m => o -> Pipe m i o ()
yield o = HaveOutput (Finished Nothing ()) (return ()) o

pipe :: (Monad m) => (i -> o) -> Pipe m i o r
pipe f = forever $ await >>= yield . f

-- skipping the rearrangement needed for MonadTrans
pipeLift :: Monad m => m r -> Pipe m i o r
pipeLift mx = PipeM (liftM pure mx) mx

discard :: (Monad m) => Pipe m i o r
discard = forever await


infixr 9 <+< -- , >->
infixl 9 >+> -- , <-<
(>+>) = flip (<+<)

(<+<) :: Monad m => Pipe m o u r -> Pipe m i o r -> Pipe m i u r
p1' <+< p2' = case (p1', p2') of
  (HaveOutput p1 _ x1, p2                 ) -> yield x1 >>         p1 <+< p2
  (PipeM m1  m2      , p2                 ) -> pipeLift m1  >>= \p1 -> p1 <+< p2
  (Finished _ r1     , _                  ) -> Finished Nothing r1
  (NeedInput f1 _    , HaveOutput p2 _ x2 ) -> f1 x2 <+< p2
  (p1                , NeedInput f2 _     ) -> await    >>= \x  -> p1 <+< f2 x
  (p1                , PipeM m2 m         ) -> pipeLift m2  >>= \p2 -> p1 <+< p2
  (_                 , Finished m r2      ) -> Finished m r2


-- I guess this should this be using the closing elements?
runPipe :: (Monad m) => Pipe m () Void r -> m r
runPipe p' = case p' of
    Finished ms r           -> return r
    PipeM mp mr             -> mp >>= runPipe
    NeedInput f pipe        -> runPipe $ f ()
    HaveOutput pipe mr o    -> runPipe pipe
  
  
  
  
-- testing 

take' :: Int -> Pipe IO a a ()
take' n = do
   replicateM_ n $ do
       x <- await
       yield x
   pipeLift $ putStrLn "You shall not pass!"

fromList :: Monad m => [a] -> Pipe m () a ()
fromList = mapM_ yield

printer :: (Show a) => Pipe IO a Void r
printer = forever $ do
     x <- await
     pipeLift $ print x
     
pipeline :: Pipe IO () Void ()
pipeline =  (fromList [(1::Int)..]) >+> take' 3 >+> printer 

prompt :: Pipe IO () Int a
prompt = forever $ do
    pipeLift $ putStrLn "Enter a number: "
    n <- read <$> pipeLift getLine
    yield n
    
print' :: (Show a) => Int -> Pipe IO a Void ()
print' n = printer <+< take' n 

deliver :: (Monad m) => Int -> Pipe m a Void [a]
deliver n = replicateM n await

readFile' :: Handle -> Pipe IO () String ()
readFile' h = do
    eof <- pipeLift $ hIsEOF h
    if eof
      then return ()
      else do
          s <- pipeLift $ hGetLine h
          yield s
          readFile' h

read' n file = 
   do  pipeLift $ putStrLn "Opening file ..."
       h <- pipeLift $ openFile file ReadMode
       take' n <+< readFile' h
       pipeLift $ putStrLn "Closing file ..."
       pipeLift $ hClose h
       
       
pipe1 = printer <+< take' 3 <+< prompt
pipe2 = (print' 3 >> print' 4) <+< fromList [1..]
pipe3 = printer <+< (take' 3 >> take' 4) <+< fromList [1..]
pipe4 = deliver 3 <+< (fromList [1..10] >> return [])
pipe5 file =  (pipeLift $ putStrLn "I don't need input") <+< read' 2 file
pipe6 file = printer <+< read' 2 file

Looks great!

One thing: runPipe should have type Monad m => Pipe m Void Void r -> m r. You can use pipe when handling NeedInput because there's no input.