Thread.hs http://www.haskellforall.com/2013/06/from-zero-to-cooperative-threads-in-33.html

Thread.hs

{-# LANGUAGE DeriveFunctor #-}
module Main where

import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Free
import Data.Sequence

data ThreadF next = Fork next next
                  | Yield next
                  | Done
                  deriving (Functor)

type Thread = FreeT ThreadF

yield :: (Monad m) => Thread m ()
yield = liftF (Yield ())

done :: (Monad m) => Thread m r
done = liftF Done

cFork :: (Monad m) => Thread m Bool
cFork = liftF (Fork False True)

fork :: (Monad m) => Thread m a -> Thread m ()
fork thread = do
  child <- cFork
  when child $ do
    _ <- thread
    done

roundRobin :: (Monad m) => Thread m a -> m ()
roundRobin thread = go (singleton thread)
  where
    go ts = case viewl ts of
      EmptyL -> return ()
      t :< ts' -> do
        x <- runFreeT t
        case x of
          Free (Fork t1 t2) -> go (t1 <| (ts' |> t2))
          Free (Yield t') -> go (ts' |> t')
          Free Done -> go ts'
          Pure _ -> go ts'

mainThread :: Thread IO ()
mainThread = do
  lift $ putStrLn "Forking thread #1"
  fork thread1
  lift $ putStrLn "Forking thread #2"
  fork thread2

thread1 :: Thread IO ()
thread1 = forM_ [1..10] $ \i -> do
  lift $ print i
  yield

thread2 :: Thread IO ()
thread2 = replicateM_ 3 $ do
  lift $ putStrLn "Hello"
  yield

main :: IO ()
main = roundRobin mainThread