mandulia-0.4: src/ResourcePool.hs

{-
Mandulia -- Mandelbrot/Julia explorer
Copyright (C) 2010  Claude Heiland-Allen <claudiusmaximus@goto10.org>

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 ResourcePool(ResourcePool(), resourcePool, acquire, release, withResource) where

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

type ResourcePool r = MVar (ResourcePool' r)

data ResourcePool' r =
  ResourcePool'
    { rAlloc     :: IO r
    , rBound     :: Int
    , rCount     :: Int
    , rResources :: [r]
    , rNext      :: MVar r
    }

resourcePool :: IO r -> Int -> IO (ResourcePool r)
resourcePool alloc bound = do
  nr <- newEmptyMVar
  newMVar ResourcePool'
    { rAlloc = alloc
    , rBound = bound
    , rCount = 0
    , rResources = []
    , rNext = nr
    }

acquire :: ResourcePool r -> IO r
acquire p = do
  r <- takeMVar p
  next <- tryTakeMVar $ rNext r
  case next of
    Nothing ->
      case rResources r of
        [] -> if rCount r < rBound r
                then do
                  nr <- rAlloc r
                  putMVar p r{ rCount = rCount r + 1 }
                  return nr
                else do
                  putMVar p r
                  takeMVar $ rNext r
        (nr:rs) ->   do
              putMVar p r{ rResources = rs }
              return nr
    Just nr ->      do
              putMVar p r
              return nr

release :: ResourcePool r -> r -> IO ()
release p x = do
  r <- takeMVar p
  r0 <- tryTakeMVar $ rNext r
  let rs = maybeToList r0 ++ rResources r
  putMVar p r{ rResources = rs }
  putMVar (rNext r) x

withResource :: ResourcePool r -> (r -> IO b) -> IO b
withResource p action = do
  r <- acquire p
  b <- action r
  release p r
  return b