eventloop-0.4.1.0: src/Eventloop/Utility/Concurrent.hs

module Eventloop.Utility.Concurrent
    ( Thread
    , fork
    , join
    , terminateThread
    ) where

import Control.Exception
import Control.Concurrent
import Control.Concurrent.MVar

type WaitOn = MVar ()
data Thread = Thread ThreadId WaitOn


fork :: IO () -> IO Thread
fork action 
    = do
        waitOn <- newEmptyMVar
        tid <- forkFinally action (setTerminated waitOn)
        return (Thread tid waitOn)

        
setTerminated :: WaitOn -> (Either SomeException a) -> IO ()
setTerminated waitOn (Right _)
    = putMVar waitOn ()
    
setTerminated waitOn (Left someException)
    = do
        putMVar waitOn ()
        throw someException
    
        
        
join :: Thread -> IO ()
join (Thread threadId waitOn)
    = do
        takeMVar waitOn
        return ()
        
terminateThread :: Thread -> IO ()
terminateThread (Thread tid _)
    = do
        killThread tid