{-# 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
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)
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
intHandler
:: Int -> IO ()
testHandler
:: Test
-> IO ()
main = do
w <- startWorker [
Handler intHandler,
Handler strHandler,
Handler testHandler]
send w False
send w 'a'
send w "foo"
send w (Test True "bar")
stopWorker w
ey0jIExBTkdVQUdFIEV4aXN0ZW50aWFsUXVhbnRpZmljYXRpb24sCiAgICAgICAgICAgICBEZXJpdmVEYXRhVHlwZWFibGUsCiAgICAgICAgICAgICBQYXR0ZXJuU2lnbmF0dXJlcyAjLX0KaW1wb3J0IERhdGEuVHlwZWFibGUKaW1wb3J0IENvbnRyb2wuQ29uY3VycmVudAppbXBvcnQgQ29udHJvbC5Db25jdXJyZW50Lk1WYXIKaW1wb3J0IENvbnRyb2wuQ29uY3VycmVudC5DaGFuCgotLSBDb3JlIGRhdGEgdHlwZXMKCmRhdGEgTWVzc2FnZSA9IGZvcmFsbCB0IC4gVHlwZWFibGUgdCA9PiBNZXNzYWdlIHQgfCBTdG9wTWVzc2FnZQogICAgZGVyaXZpbmcgVHlwZWFibGUKCmRhdGEgSGFuZGxlciA9IGZvcmFsbCB0IC4gVHlwZWFibGUgdCA9PiBIYW5kbGVyICh0IC0+IElPICgpKQoKCi0tIFdvcmtlciB0aHJlYWQKCmRhdGEgV29ya2VyID0gV29ya2VyIChDaGFuIE1lc3NhZ2UpIChNVmFyICgpKQoKd29ya2VyVGhyZWFkIDo6IFtIYW5kbGVyXSAtPiBDaGFuIE1lc3NhZ2UgLT4gTVZhciAoKSAtPiBJTyAoKQp3b3JrZXJUaHJlYWQgaGFuZGxlcnMgY2hhbiBmaW5pc2ggPSBsb29wIHdoZXJlCiAgICBsb29wID0gZG8KICAgICAgICBtZXNzYWdlIDwtIHJlYWRDaGFuIGNoYW4KICAgICAgICBjYXNlIG1lc3NhZ2Ugb2YKICAgICAgICAgICAgU3RvcE1lc3NhZ2UgLT4gcHV0TVZhciBmaW5pc2ggKCkKICAgICAgICAgICAgTWVzc2FnZSB2YWwgLT4gZG8KICAgICAgICAgICAgICAgIGZvbGRyICh0cnlIYW5kbGVyIHZhbCkgKHB1dFN0ckxuICJVbmhhbmRsZWQgbWVzc2FnZSIpIGhhbmRsZXJzCiAgICAgICAgICAgICAgICBsb29wCiAgICB0cnlIYW5kbGVyIHZhbCAoSGFuZGxlciBoKSByZXN0ID0gbWF5YmUgcmVzdCBoIChjYXN0IHZhbCkKCnN0YXJ0V29ya2VyIDo6IFtIYW5kbGVyXSAtPiBJTyBXb3JrZXIKc3RhcnRXb3JrZXIgaGFuZGxlcnMgPSBkbwogICAgY2hhbiA8LSBuZXdDaGFuCiAgICBmaW5pc2ggPC0gbmV3RW1wdHlNVmFyCiAgICBmb3JrSU8gKHdvcmtlclRocmVhZCBoYW5kbGVycyBjaGFuIGZpbmlzaCkKICAgIHJldHVybiAkIFdvcmtlciBjaGFuIGZpbmlzaAoKc2VuZCA6OiBUeXBlYWJsZSBtID0+IFdvcmtlciAtPiBtIC0+IElPICgpCnNlbmQgKFdvcmtlciBjaGFuIF8pIG1lc3NhZ2UgPSBkbwogICAgd3JpdGVDaGFuIGNoYW4gJCBNZXNzYWdlIG1lc3NhZ2UKCnN0b3BXb3JrZXIgOjogV29ya2VyIC0+IElPICgpCnN0b3BXb3JrZXIgKFdvcmtlciBjaGFuIGZpbmlzaCkgPSBkbwogICAgd3JpdGVDaGFuIGNoYW4gJCBTdG9wTWVzc2FnZQogICAgdGFrZU1WYXIgZmluaXNoCgoKLS0gU29tZSB0ZXN0cwoKZGF0YSBUZXN0ID0gVGVzdCBCb29sIFN0cmluZyBkZXJpdmluZyBUeXBlYWJsZQoKaW50SGFuZGxlciA6OiBJbnQgLT4gSU8gKCkKaW50SGFuZGxlciB2YWwgPSBwdXRTdHJMbiAkICJJbnQ6ICIgKysgc2hvdyAodmFsICogMikKCnN0ckhhbmRsZXIgOjogU3RyaW5nIC0+IElPICgpCnN0ckhhbmRsZXIgdmFsID0gcHV0U3RyTG4gJCAiU3RyaW5nOiAiICsrIHJldmVyc2UgdmFsCgp0ZXN0SGFuZGxlciA6OiBUZXN0IC0+IElPICgpCnRlc3RIYW5kbGVyIChUZXN0IGIgcykgPSBwdXRTdHJMbiAkICJUZXN0OiAiICsrIHNob3cgYiArKyAiICIgKysgc2hvdyBzCgptYWluID0gZG8KICAgIHcgPC0gc3RhcnRXb3JrZXIgWwogICAgICAgIEhhbmRsZXIgaW50SGFuZGxlciwKICAgICAgICBIYW5kbGVyIChcKHZhbDo6Q2hhcikgLT4gcHV0U3RyTG4gJCAiQ2hhcjogIiArKyBzaG93IHZhbCksCiAgICAgICAgSGFuZGxlciBzdHJIYW5kbGVyLAogICAgICAgIEhhbmRsZXIgdGVzdEhhbmRsZXJdCiAgICBzZW5kIHcgKDU6OkludCkKICAgIHNlbmQgdyBGYWxzZQogICAgc2VuZCB3ICdhJwogICAgc2VuZCB3ICJmb28iCiAgICBzZW5kIHcgKFRlc3QgVHJ1ZSAiYmFyIikKICAgIHN0b3BXb3JrZXIgdwogICAgcHV0U3RyTG4gIkZpbmlzaGVkISIK