1
2
3
4
5
6
7
8
9
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
|
module Thread.Jobs where
import Control.Concurrent
import Control.Exception
import qualified Data.Map as M
import qualified Map
data JobInfo a e = (Exception e) =>
JobInfo { jobId :: ThreadId
, result :: MVar (Either e a) }
type Jobs k e a = (Ord k, Exception e) =>
M.Map k (JobInfo a e)
type JobArgs k a = (Ord k) =>
M.Map k a
type JobResults k e a = (Ord k, Exception e) =>
M.Map k (Either e a)
start :: (Ord k, Exception e) => JobArgs k a -> (a -> IO b) -> IO (Jobs k e b)
start args worker = do
arg <- newEmptyMVar
Map.mapM (\a -> do
putMVar arg a
res <- newEmptyMVar
tId <- forkIO $ do
arg_ <- takeMVar arg
res_ <- try $ worker arg_
putMVar res res_
return $ JobInfo tId res
) args
wait :: Jobs k e a -> IO (JobResults k e a)
wait = Map.mapM (takeMVar . result)
end :: Jobs k e a -> IO (JobResults k e a)
end jobs = Map.mapM (\job -> do
killThread $ jobId job
takeMVar $ result job
) jobs
|