It is easy to implement co-routines in Haskell… but only if you know how. No fewer than three people asked me to blog about it, so here’s a quick guide to rolling your own co-routines. To understand this blog, you will need to have a basic understanding of monad transformers.

There are co-routine packages on Hackage, but I have not had much luck with them. The point here, really, is to show you how it all works.

What’s a co-routine?

A co-routine (called a ‘generator’ in Python) is where you create two interleaved flows of control on a single thread. Unlike threads, co-routines switch co-operatively using a ‘yield’ operation. (This is quite a good trick in GUI programming for implementing complex workflow that spans multiple GUI events, since most GUI libraries require everything to be on one thread.)

The example I’m presenting here works in this way: A caller executes a CoroutineT monad transformer, which adds the ‘yield’ operation to the underlying monad (which can be anything). From the caller’s point of view, the ‘yield’ looks like the monad has returned, but with a continuation. In the callee, ‘yield’ appears to block until the caller executes the continuation. In addition, we add the ability to pass a value in both directions.

So we’ve inverted the flow of control in the callee. Continuation passing style (CPS) can also do this, but co-routines are better than CPS because 1. it’s a bit neater, and 2. it allows for recursion.

One application of co-routines is to separate I/O from logic. By way of example I am going to implement an expert system for identifying fruit. I try not to use contrived examples, and as you can see, this time I have completely failed.

In this example, the CoroutineT sits on top of the identity monad, so it’s pure, but the approach works just the same on top of IO or anything else. This example is not deeply nested, but this approach happily supports any level of recursion or nesting.

So here’s our expert system logic. We’ll define CoroutineT shortly. You can read ‘yield’ as ‘askUser’:

type Question = String
data Answer = Y | N deriving Eq

type Expert a = CoroutineT Answer Question Identity a

data Fruit
    = Apple
    | Kiwifruit
    | Banana
    | Orange
    | Lemon
    deriving Show

identifyFruit :: Expert Fruit
identifyFruit = do
    yellow <- yield "Is it yellow?"
    if yellow == Y then do
        long <- yield "Is it long?"
        if long == Y then
            return Banana
          else
            return Lemon
      else do
        orange <- yield "Is it orange?"
        if orange == Y then
           return Orange
         else do
           fuzzy <- yield "Is it fuzzy?"
           if fuzzy == Y then
               return Kiwifruit
             else
               return Apple

Our ‘Expert’ type above…

type Expert a = CoroutineT Answer Question Identity a

…specifies the type we are sending into our co-routine (Answer) and the type we are getting out of it (Question) as viewed from the caller.

Now we just need a main program to drive it. Because the I/O is separated out, we can later replace this with a nice touch-screen GUI for the seriously fruit-impaired.

main :: IO ()
main = do
    putStrLn $ "Expert system for identifying fruit"
    run identifyFruit
  where
    run :: Expert Fruit -> IO ()
    run exp = handle $ runIdentity $ runCoroutineT exp

    handle (Yield q cont) = do
        putStrLn q
        l <- getLine
        case map toLower l of
            "y"   -> run $ cont Y
            "yes" -> run $ cont Y
            "n"   -> run $ cont N
            "no"  -> run $ cont N
            _   -> putStrLn "Please answer 'yes' or 'no'" >> handle (Yield q cont)

    handle (Result fruit) = do
        putStrLn $ "The fruit you have is: "++show fruit

When we run our co-routine, it returns with one of these two events:

• Yield, which happens when yield is executed. It gives us the output value (Question) and the continuation, which when passed the input value (Answer) gives us the same ‘Expert’ type we started with.
• Result, which happens when the co-routine has finished executing.

So how does CoroutineT work?

We’ll start with the types:

data Result i o m a = Yield o (i -> CoroutineT i o m a) | Result a

-- | Co-routine monad transformer
--
--   * i = input value returned by yield
--
--   * o = output value, passed to yield
--
--   * m = next monad in stack
--
--   * a = monad return value
data CoroutineT i o m a = CoroutineT {
        runCoroutineT :: m (Result i o m a)
    }

Hopefully that’s pretty straightforward. ‘yield’ is defined like this:

-- | Suspend processing, returning a @o@ value and a continuation to the caller
yield :: Monad m => o -> CoroutineT i o m i
yield o = CoroutineT $ return $ Yield o (\i -> CoroutineT $ return $ Result i)

The key point here is that the continuation does nothing except return the value, which is what we want it to do when we run a monad that contains only a yield.

Most of the magic is in the definition of >>=, thus:

instance Monad m => Monad (CoroutineT i o m) where
    return a = CoroutineT $ return $ Result a
    f >>= g = CoroutineT $ do
        res1 <- runCoroutineT f
        case res1 of
            Yield o c -> return $ Yield o (\i -> c i >>= g)
            Result a  -> runCoroutineT (g a)
    -- Pass fail to next monad in the stack
    fail err = CoroutineT $ fail err

A typical monad would normally execute f then pass its result to g and execute that, and this is in fact exactly what we do in the Result case. Ho hum.

But there’s no law that says you have to execute g. This is Haskell so we can do whatever we like. g is just a plain old closure representing the continuation.

So what we do in the Yield case is take the continuation that executing f gave us, and bind that to the continuation g, then bail out of the monad (in the same way ErrorT does when it gets an error), handing our constructed continuation to the caller. So we end up with a closure that represents the entire execution state of the monad, and it doesn’t matter how deeply nested we are. It just puts the continuation together in the right way as we unravel everything on our way back to the caller.

Here’s the code in downloadable form:

• expert.hs
• Coroutine.hs

This code is released in the public domain.

Stephen Blackheath, Manawatu, New Zealand

Uhh, hello.  Welcome to my first blog post ever – and thanks Axman6 for letting me be a “guest blogger”.

It’s rather unfashionable on #haskell, but I like XML.  So, 18 months ago, I took over the hexpat package from Evan Martin.  It was going to be a small project – a simple XML parser binding to Expat.  The fastest Haskell XML parser alive.  Or so I thought.

It’s become a passion, a way of life.  It’s XML parsing in Haskell the way I think it should be done.  The best as well as the fastest.  (I like to think big.)

I’ve finally finished adding all the features that I and a number of contributors wanted, and I would now like to announce that hexpat is going beta.  I want to make this package really, really good, so please help by testing and critiquing.  I want to stabilize hexpat, but hexpat-iteratee will be unstable for a while yet.

The future is chunky

The cherry on top of the hexpat galaxy is the still experimental hexpat-iteratee based on Oleg Kiselyov’s iteratee, which is a bit of a hot ticket these days.  It provides lazy XML parsing without the practical issues and philosophical dodginess inherent in Haskell’s lazy I/O through functions like hGetContents.

hexpat-iteratee allows for effectful XML processing done in a functional way, and the magic behind this is Yair Chuchem’s humbly named List package.  It is “merely” a generalization of lists, and I think it deserves to be a common piece of infrastructure.

The example project is a chunked XML-over-TCP movie database lookup server.  Every home should have one.  So, let’s start like all good blogs do, with imports:

{-# LANGUAGE OverloadedStrings #-}
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.ListT
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B (unsafeUseAsCStringLen)
import Data.Iteratee
import Data.Iteratee.IO.Fd
import Data.Iteratee.WrappedByteString
import Data.List.Class as List
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Network
import System.IO
import System.Posix.IO (handleToFd, fdWriteBuf, closeFd)
import System.Posix.Types (Fd)
import Text.XML.Expat.Chunked
import qualified Text.XML.Expat.Chunked as Tree
import Text.XML.Expat.Format
import Foreign.Ptr

The first thing we want to do is listen on a socket.  I could use handles, sockets, or file descriptors. With handles, this code does not work interactively. Disabling the buffering does not seem to work at all in GHC 6.10 or 6.12. Sockets would be ideal, but to save me writing an iteratee driver, I’m left with file descriptors which unfortunately means this code only works on GHC 6.12 on a POSIX system.  fdPutStrBS is the only glue I need then – it writes a ByteString to a Fd.   Here’s the code:

main :: IO ()
main = do
    let port = 6333
    putStrLn $ "listening on port "++show port
    ls <- listenOn $ PortNumber port
    forever $ do
        (h, _, _) <- accept ls
        forkIO $ handleToFd h >>= \fd -> do
            iter <- parse defaultParserOptions (session (fdPutStrBS fd))
            result <- enumFd fd iter >>= run
            print result
          `finally`
            closeFd fd


fdPutStrBS :: Fd -> B.ByteString -> IO ()
fdPutStrBS fd bs = B.unsafeUseAsCStringLen bs $ \(buf, len) ->
        writeFully (castPtr buf) (fromIntegral len)
  where
    writeFully _ len | len == 0 = return ()
    writeFully buf len = do
        written <- fdWriteBuf fd buf len
        if written < 0
            then fail "write failed"
            else writeFully (buf `plusPtr` fromIntegral written) (len - written)

Once we’ve accepted the connection, we get parse (from hexpat-iteratee) to make us an iteratee.  The second argument, “session (fdPutStrBS fd)” is the handler for processing the document.  We then pass this iteratee to iteratee’s enumFd, whose job it is to pull the input data out of the Fd and feed it into the parser. parse is monadic in order that it can start the handler before it receives the first data block through the iteratee. This is necessary in case the handler wants to generate output before it gets any input, which we want to do here.

The handler is a co-routine.  When it runs out of input data, it gets suspended, and control returns to enumFd.

session :: (B.ByteString -> IO ())  -- ^ Write output data to socket
        -> ListOf (UNode IO Text)   -- ^ Input XML document
        -> XMLT IO ()
session writeOut inputXML = do
    let outputXML = formatG $ indent 2 $ Element "server" [] (processRoot inputXML)
    execute $ liftIO . writeOut =<< outputXML
    return ()

formatG is a hexpat function to take a tree node and format it as XML, returning one of Yair’s Lists of ByteStrings.  indent is a filter that adds pretty indenting.  The Element is the top level tag of our output XML tree, and its third argument “processRoot inputXML” evaluates the child nodes of the output document.  The entire processing of the document is in a functional style.

execute here makes all the IO actually happen. It iterates over a List of monadic actions and sequences them. This translates into a sequence of writes of data blocks to the socket.  The elements in the list are monadic, so execute also must execute those in order to extract each output ByteString.

In this way, even though processRoot is pure at the top level, it can contain effectful computations.

processRoot :: ListOf (UNode IO Text) -> ListOf (UNode IO Text)
processRoot root = do
    Element _ _ children <- genericTake 1 root
    child <- children
    extractElements child
  where
    extractElements :: UNode IO Text -> ListOf (UNode IO Text)
    extractElements elt | isElement elt = processCommand elt `cons` mzero
    extractElements _                   = mzero

ListOf is a type function that conceals a long-winded type name.  This function maps the input document to a list of output nodes.

The root of the input document is actually given as a List containing one item – the top-level XML tag.  The reason why we do this is so that we have to ask for it to be pulled.  If it were just passed as a UNode IO Text type, we would have to calculate it before the handler was called, and the handler wouldn’t get a chance to do output before it requests input.

The function is implemented using List’s Monad instance, which behaves exactly like a list monad.  The reason for genericTake 1 root is so we stop processing after the root node and don’t wait for a node that will never come.  I need to fix this in hexpat-iteratee.

`cons` is the generalized list cons operator like : and  `mzero` corresponds to [].

processCommand :: UNode IO Text -> UNode IO Text
processCommand elt@(Element "title" _ _) = Element "title" [] $ joinL $ do
    txt <- textContentM elt
    return $ search txt
processCommand (Element cmd _ _) = Element "unknown" [("command", cmd)] mzero

Here is our command processor.  We have one command <title>foo</title> that finds all movies whose titles contain foo.

joinL is a bit of List magic that lets you drop down into the underlying monad, which in this case is XMLT IO a.  joinL’s type is :: ItemM l (l a) -> l a where ItemM l is a type function giving the list’s monad.  So, the stuff after joinL resolves to a type of :: XMLT IO (ListOf (UNode IO Text)).

search :: Text -> ListOf (UNode IO Text)
search key = joinL $ do
    iter <- liftIO $ parse defaultParserOptions $ \root -> do
        let l = do
                elt@(Element _ _ children) <- genericTake 1 root
                movie <- List.filter isElement children
                return movie
        execute l
        return l
    eMovies <- liftIO $ fileDriver iter "movies.xml"
    case eMovies of
        Left err -> fail $ "failed to read 'movies.xml': "++show err
        Right movies -> return $ List.filter matches movies
  where
    matches elt = key `T.isInfixOf` fromMaybe "" (getAttribute elt "title")

Here’s where our handler does some real I/O.  We read our database from a flat file using the same method of parsing.  Passing possibly unexecuted nodes outside the XMLT monad is a bit wrong, and needs to be addressed in the design, but here it works as long as I execute them.  Alternatively a pure XML parse would work.  hexpat has functions to convert between pure and monadic node types.

So, I build and run the server, and here is the result, using Unix’s nc command as my client.  I typed this:

<a>
<title>of the</title>

The output is:

<?xml version="1.0" encoding="UTF-8"?>
<server>
 <title>
   <movie id="dvzrwfvryd" disc="41" title="War of the Worlds (2005)"
        director="Steven Spielberg" genre="Sci Fi Thriller" rating="6"
        description="Tom Cruise alert" imdbID="tt0407304"/>
   <movie id="xxvjgxpokp" disc="44" title="Shaun of the Dead"
        director="Edgar Wright" genre="Comedy Horror" rating="8"
        description="British send-up zombie movie" imdbID="tt0365748"/>
   <movie id="duvcjsygqi" disc="104" title="March of the Penguins (La Marche de l&apos;empereur)"
        director="Luc Jacquet" genre="Documentary" description="" imdbID="tt0428803"/>
   <movie id="dawcezoiro" disc="109" title="Pirates of the Caribbean: Dead Man&apos;s Chest"
        director="Gore Verbinski" genre="Action/Comedy" rating="7" description="" imdbID="tt0383574"/>
 </title>

(New lines added for readability)

And the session can process more commands interactively.

And pickled

I should also mention my related hexpat-pickle package which is a shameless rip-off of the picklers from Uwe Schmidt’s excellent hxt package.  I find it a very practical and quick way to bang out XML picklers.  (It doesn’t work with hexpat-iteratee yet.)

Bye bye

Here’s the code in downloadable form.  Make sure you use the monads-fd and transformers packages instead of mtl.  Also hexpat-iteratee and text.

I hope you found this interesting.  I hope the XML haters of #haskell will be miraculously transformed into XML tolerators, and I hope you’ll help me improve hexpat. – Stephen Blackheath, Manawatu, New Zealand