{-# LANGUAGE GADTs, Trustworthy #-}

-- | Implements rudimentary thread pools.
module Control.CUtils.ThreadPool (
-- ** Thread pools
ThreadPool(..), Interruptible(..),
-- Pool, createPool,
NoPool(..), BoxedThreadPool(..)) where

import Control.Concurrent
import Control.Monad
import Control.Monad.Loops
import Data.Word
import Data.Array.IO
import Data.IORef

data Pool = Pool
	!Int
	!(Chan(IO ()))

-- | Thread pools support some standard operations...
class ThreadPool pool where
	addToPool :: pool -> IO () -> IO ()

class Interruptible pool where
	stopPool :: pool -> IO ()

createPool :: Word32 -> Int -> IO Pool
createPool channelSize workers = do
	chn <- newChan
	stop <- newIORef False
	let loop = whileM_(return True)$readChan chn>>=id
	sequence_$replicate workers$forkIO loop -- Start workers
	return$!Pool workers chn

instance ThreadPool Pool where
	addToPool (Pool _ channel) m = writeChan channel m

instance Interruptible Pool where
	stopPool (Pool n channel) = replicateM_ n$writeChan channel$myThreadId>>=killThread

data NoPool = NoPool -- Use if you don't want to use a thread pool.

instance ThreadPool NoPool where
	addToPool _ = void.forkIO

data BoxedThreadPool where
	BoxedThreadPool :: (ThreadPool pool) => pool -> BoxedThreadPool

instance ThreadPool BoxedThreadPool where
	addToPool (BoxedThreadPool pool) = addToPool pool