Usage example of Free monad - compilable and working code for an Gabriel Gonzalez's article "From zero to cooperative threads in 33 lines of Haskell code"

From_zero_to_cooperative_threads_in_33_lines_of_Haskell_code.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveAnyClass #-}

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

data ThreadF next = Fork  next next
                  | Yield next
                  | Done
                  deriving (Functor,Applicative, Monad,MonadIO)

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 t = go (singleton t)  -- Begin with a single thread
  where
    go ts = case (viewl ts) of
        -- The queue is empty: we're done!
        EmptyL   -> return ()

        -- The queue is non-empty: Process the first thread
        t :< ts' -> do
            x <- runFreeT t  -- Run this thread's effects
            case x of
                -- New threads go to the back of the queue
                Free (Fork t1 t2) -> go (t1 <| (ts' |> t2))

                -- Yielding threads go to the back of the queue
                Free (Yield   t') -> go (ts' |> t')

                -- Thread done: Remove the thread from the queue
                Free  Done        -> go ts'
                Pure  _           -> go ts'

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

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

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

main :: IO ()
main = do
   roundRobin mainThread
   
 {-
 dependencies:
- base >= 4.7 && < 5
- free
- containers
 -}