mandulia-0.8.0.1: src/JobQueue.hs

{-
Mandulia -- Mandelbrot/Julia explorer
Copyright (C) 2010  Claude Heiland-Allen <claude@mathr.co.uk>

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

module JobQueue(JobQueue(), jobQueue, getJob, putJob, withJob, completed, reprioritise) where

import Control.Concurrent.MVar
import Data.List (delete)
import Data.Maybe (maybeToList)

type JobQueue j = MVar (JobQueue' j)

data JobQueue' j =
  JobQueue'
    { qDone    :: [j]
    , qPending :: [j]
    , qTodo    :: [j]
    , qNext    :: MVar j
    }

jobQueue :: IO (JobQueue j)
jobQueue = do
  nj <- newEmptyMVar
  newMVar JobQueue'{ qDone = [], qPending = [], qTodo = [], qNext = nj }

getJob :: JobQueue j -> IO j
getJob s = do
  q <- takeMVar s
  next <- tryTakeMVar $ qNext q
  case next of
    Nothing ->
      case qTodo q of
        []      -> do
          putMVar s q
          j <- takeMVar $ qNext q
          modifyMVar_ s $ \q' -> return q'{ qPending = j : qPending q' }
          return j
        (j:js)  -> do
          putMVar s q{ qTodo = js }
          putMVar (qNext q) j
          j' <- takeMVar $ qNext q
          modifyMVar_ s $ \q' -> return q'{ qPending = j' : qPending q' }
          return j'
    Just j ->      do
          putMVar s q{ qPending = j : qPending q }
          return j

putJob :: Eq j => JobQueue j -> j -> IO ()
putJob s j = do
  q <- takeMVar s
  putMVar s q{ qDone = j : qDone q, qPending = delete j (qPending q) }

withJob :: Eq j => JobQueue j -> (j -> IO j) -> IO ()
withJob s action = putJob s =<< action =<< getJob s

completed :: JobQueue j -> IO [j]
completed s = do
  q <- takeMVar s
  let js = qDone q
  putMVar s q{ qDone = [] }
  return js

reprioritise :: Eq j => JobQueue j -> ([j] -> [j]) -> IO ()
reprioritise s f = do
  q <- takeMVar s
  j0 <- tryTakeMVar $ qNext q
  let jobs = filter (`notElem` qDone q ++ qPending q) (f (maybeToList j0 ++ qTodo q))
  case jobs of
    []     -> do
      putMVar s q{ qTodo = [] }
    (j:js) -> do
      putMVar (qNext q) j
      putMVar s q{ qTodo = js }