fork download
copy 
  1. {-# LANGUAGE ExistentialQuantification,
  2.              DeriveDataTypeable,
  3.              PatternSignatures #-}
  4. import Data.Typeable
  5. import Control.Concurrent
  6. import Control.Concurrent.MVar
  7. import Control.Concurrent.Chan
  8.  
  9. -- Core data types
  10.  
  11. data Message = forall t . Typeable t => Message t | StopMessage
  12.     deriving Typeable
  13.  
  14. data Handler = forall t . Typeable t => Handler (t -> IO ())
  15.  
  16.  
  17. -- Worker thread
  18.  
  19. data Worker = Worker (Chan Message) (MVar ())
  20.  
  21. workerThread :: [Handler] -> Chan Message -> MVar () -> IO ()
  22. workerThread handlers chan finish = loop where
  23.     loop = do
  24.         message <- readChan chan
  25.         case message of
  26.             StopMessage -> putMVar finish ()
  27.             Message val -> do
  28.                 foldr (tryHandler val) (putStrLn "Unhandled message") handlers
  29.                 loop
  30.     tryHandler val (Handler h) rest = maybe rest h (cast val)
  31.  
  32. startWorker :: [Handler] -> IO Worker
  33. startWorker handlers = do
  34.     chan <- newChan
  35.     finish <- newEmptyMVar
  36.     forkIO (workerThread handlers chan finish)
  37.     return $ Worker chan finish
  38.  
  39. send :: Typeable m => Worker -> m -> IO ()
  40. send (Worker chan _) message = do
  41.     writeChan chan $ Message message
  42.  
  43. stopWorker :: Worker -> IO ()
  44. stopWorker (Worker chan finish) = do
  45.     writeChan chan $ StopMessage
  46.     takeMVar finish
  47.  
  48.  
  49. -- Some tests
  50.  
  51. data Test = Test Bool String deriving Typeable
  52.  
  53. intHandler :: Int -> IO ()
  54. intHandler val = putStrLn $ "Int: " ++ show (val * 2)
  55.  
  56. strHandler :: String -> IO ()
  57. strHandler val = putStrLn $ "String: " ++ reverse val
  58.  
  59. testHandler :: Test -> IO ()
  60. testHandler (Test b s) = putStrLn $ "Test: " ++ show b ++ " " ++ show s
  61.  
  62. main = do
  63.     w <- startWorker [
  64.         Handler intHandler,
  65.         Handler (\(val::Char) -> putStrLn $ "Char: " ++ show val),
  66.         Handler strHandler,
  67.         Handler testHandler]
  68.     send w (5::Int)
  69.     send w False
  70.     send w 'a'
  71.     send w "foo"
  72.     send w (Test True "bar")
  73.     stopWorker w
  74.     putStrLn "Finished!"
  75.  
Success #stdin #stdout 0.02s 3556KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Int: 10
Unhandled message
Char: 'a'
String: oof
Test: True "bar"
Finished!
https://ideone.com/OMVamc
language:
Haskell (ghc 8.4.4)
created:
11 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!