Bonding (xkcd.com/1188) for haskell

Bonding.hs

{-# LANGUAGE RecursiveDo #-}

import Control.Concurrent (ThreadId, throwTo, yield, forkIO)
import Control.Exception (Exception, catch)
import Control.Monad (forever)

wait :: IO ()
wait = forever yield

data Ball = Ball deriving Show

instance Exception Ball

type Person = ThreadId

person :: Person -> IO Person
person target = forkIO $
	forever $ wait `catch` (\Ball -> throwTo target Ball)

main :: IO ()
main = mdo
	parent <- person child
	child <- person parent
	throwTo parent Ball
	wait