correctness and speed fixes
[maximus:mandulia.git] / JobQueue.hs
1 {-
2 Mandulia -- Mandelbrot/Julia explorer
3 Copyright (C) 2010  Claude Heiland-Allen <claudiusmaximus@goto10.org>
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program.  If not, see <http://www.gnu.org/licenses/>.
17 -}
18
19 module JobQueue(JobQueue(), jobQueue, getJob, putJob, withJob, completed, reprioritise) where
20
21 import Control.Concurrent.MVar
22 import Data.List (delete)
23 import Data.Maybe (maybeToList)
24
25 type JobQueue j = MVar (JobQueue' j)
26
27 data JobQueue' j =
28   JobQueue'
29     { qDone    :: [j]
30     , qPending :: [j]
31     , qTodo    :: [j]
32     , qNext    :: MVar j
33     }
34
35 jobQueue :: IO (JobQueue j)
36 jobQueue = do
37   nj <- newEmptyMVar
38   newMVar JobQueue'{ qDone = [], qPending = [], qTodo = [], qNext = nj }
39
40 getJob :: JobQueue j -> IO j
41 getJob s = do
42   q <- takeMVar s
43   next <- tryTakeMVar $ qNext q
44   case next of
45     Nothing ->
46       case qTodo q of
47         []      -> do
48           putMVar s q
49           j <- takeMVar $ qNext q
50           modifyMVar_ s $ \q' -> return q'{ qPending = j : qPending q' }
51           return j
52         (j:js)  -> do
53           putMVar s q{ qTodo = js }
54           putMVar (qNext q) j
55           j' <- takeMVar $ qNext q
56           modifyMVar_ s $ \q' -> return q'{ qPending = j' : qPending q' }
57           return j'
58     Just j ->      do
59           putMVar s q{ qPending = j : qPending q }
60           return j
61
62 putJob :: Eq j => JobQueue j -> j -> IO ()
63 putJob s j = do
64   q <- takeMVar s
65   putMVar s q{ qDone = j : qDone q, qPending = delete j (qPending q) }
66
67 withJob :: Eq j => JobQueue j -> (j -> IO j) -> IO ()
68 withJob s action = putJob s =<< action =<< getJob s
69
70 completed :: JobQueue j -> IO [j]
71 completed s = do
72   q <- takeMVar s
73   let js = qDone q
74   putMVar s q{ qDone = [] }
75   return js
76
77 reprioritise :: Eq j => JobQueue j -> ([j] -> [j]) -> IO ()
78 reprioritise s f = do
79   q <- takeMVar s
80   j0 <- tryTakeMVar $ qNext q
81   let jobs = filter (`notElem` qDone q ++ qPending q) (f (maybeToList j0 ++ qTodo q))
82   case jobs of
83     []     -> do
84       putMVar s q{ qTodo = [] }
85     (j:js) -> do
86       putMVar (qNext q) j
87       putMVar s q{ qTodo = js }