Forklift - a pattern for performing monadic actions in a worker thread

ForkLift.hs

-- see also
-- http://apfelmus.nfshost.com/blog/2012/06/07-forklift.html

module ForkLift where

import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class

import Control.Monad.Trans.State

data ForkLift m = ForkLift { requests :: Chan (m ()) }

newForkLift :: MonadIO m => (m () -> IO ()) -> IO (ForkLift m)
newForkLift unlift = do
    channel <- newChan
    let loop = forever . join . liftIO $ readChan channel
    forkIO $ unlift loop
    return $ ForkLift channel

carry :: MonadIO m => ForkLift m -> m a -> IO a
carry forklift act = do
    ref <- newEmptyMVar
    writeChan (requests forklift) $ do
        liftIO . putMVar ref =<< act
    takeMVar ref


test :: IO ()
test = do
    state <- newForkLift (flip evalStateT (0::Int))
    carry state $ modify (+10)
    carry state $ modify (+10)
    print =<< carry state get