- 01
- 02
- 03
- 04
- 05
- 06
- 07
- 08
- 09
- 10
- 11
- 12
- 13
- 14
- 15
- 16
- 17
- 18
- 19
- 20
- 21
- 22
- 23
- 24
- 25
- 26
- 27
- 28
- 29
- 30
- 31
- 32
- 33
- 34
- 35
- 36
- 37
- 38
- 39
- 40
- 41
- 42
- 43
- 44
- 45
- 46
- 47
- 48
- 49
- 50
- 51
- 52
- 53
- 54
- 55
- 56
- 57
- 58
- 59
- 60
- 61
- 62
- 63
- 64
- 65
- 66
- 67
- 68
- 69
- 70
- 71
- 72
- 73
- 74
- 75
{-# LANGUAGE ExistentialQuantification,
DeriveDataTypeable,
PatternSignatures #-}
import Data.Typeable
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Concurrent.Chan
-- Core data types
data Message = forall t . Typeable t => Message t | StopMessage
deriving Typeable
data Handler = forall t . Typeable t => Handler (t -> IO ())
-- Worker thread
data Worker = Worker (Chan Message) (MVar ())
workerThread :: [Handler] -> Chan Message -> MVar () -> IO ()
workerThread handlers chan finish = loop where
loop = do
message <- readChan chan
case message of
StopMessage -> putMVar finish ()
Message val -> do
foldr (tryHandler val) (putStrLn "Unhandled message") handlers
loop
tryHandler val (Handler h) rest = maybe rest h (cast val)
startWorker :: [Handler] -> IO Worker
startWorker handlers = do
chan <- newChan
finish <- newEmptyMVar
forkIO (workerThread handlers chan finish)
return $ Worker chan finish
send :: Typeable m => Worker -> m -> IO ()
send (Worker chan _) message = do
writeChan chan $ Message message
stopWorker :: Worker -> IO ()
stopWorker (Worker chan finish) = do
writeChan chan $ StopMessage
takeMVar finish
-- Some tests
data Test = Test Bool String deriving Typeable
intHandler :: Int -> IO ()
intHandler val = putStrLn $ "Int: " ++ show (val * 2)
strHandler :: String -> IO ()
strHandler val = putStrLn $ "String: " ++ reverse val
testHandler :: Test -> IO ()
testHandler (Test b s) = putStrLn $ "Test: " ++ show b ++ " " ++ show s
main = do
w <- startWorker [
Handler intHandler,
Handler (\(val::Char) -> putStrLn $ "Char: " ++ show val),
Handler strHandler,
Handler testHandler]
send w (5::Int)
send w False
send w 'a'
send w "foo"
send w (Test True "bar")
stopWorker w
putStrLn "Finished!"
Follow us!