Skip to content

Instantly share code, notes, and snippets.

@norm2782
Created December 9, 2011 12:59
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save norm2782/97ce5cef88ededac573a to your computer and use it in GitHub Desktop.
Save norm2782/97ce5cef88ededac573a to your computer and use it in GitHub Desktop.
diff --git a/Data/Pool.hs b/Data/Pool.hs
index 853ae0a..3a43bdb 100644
--- a/Data/Pool.hs
+++ b/Data/Pool.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ScopedTypeVariables #-}
+{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ScopedTypeVariables,
+ FlexibleContexts #-}
-- |
-- Module: Data.Pool
@@ -26,12 +27,12 @@ module Data.Pool
) where
import Control.Applicative ((<$>))
-import Control.Concurrent (forkIO, killThread, myThreadId, threadDelay)
+import Control.Concurrent.Lifted (fork, killThread, myThreadId, threadDelay)
import Control.Concurrent.STM
-import Control.Exception (SomeException, catch, onException)
+import Control.Exception.Lifted (SomeException, catch, onException)
import Control.Monad (forM_, forever, join, liftM2, unless, when)
-import Control.Monad.IO.Class (liftIO)
-import Control.Monad.IO.Control (MonadControlIO, controlIO)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Trans.Control (MonadBaseControl, control)
import Data.Hashable (hash)
import Data.List (partition)
import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
@@ -116,7 +117,7 @@ createPool create destroy numStripes idleTime maxResources = do
modError "pool " $ "invalid maximum resource count " ++ show maxResources
localPools <- atomically . V.replicateM numStripes $
liftM2 LocalPool (newTVar 0) (newTVar [])
- reaperId <- forkIO $ reaper destroy idleTime localPools
+ reaperId <- fork $ reaper destroy idleTime localPools
let p = Pool {
create
, destroy
@@ -164,7 +165,7 @@ reaper destroy idleTime pools = forever $ do
-- destroy a pooled resource, as doing so will almost certainly cause
-- a subsequent user (who expects the resource to be valid) to throw
-- an exception.
-withResource :: MonadControlIO m => Pool a -> (a -> m b) -> m b
+withResource :: (MonadIO m, MonadBaseControl IO m) => Pool a -> (a -> m b) -> m b
{-# SPECIALIZE withResource :: Pool a -> (a -> IO b) -> IO b #-}
withResource Pool{..} act = do
i <- liftIO $ ((`mod` numStripes) . hash) <$> myThreadId
@@ -179,7 +180,7 @@ withResource Pool{..} act = do
writeTVar inUse $! used + 1
return $
create `onException` atomically (modifyTVar_ inUse (subtract 1))
- ret <- controlIO $ \runInIO -> runInIO (act resource) `onException` (do
+ ret <- control $ \runInIO -> runInIO (act resource) `onException` (do
destroy resource `catch` \(_::SomeException) -> return ()
atomically (modifyTVar_ inUse (subtract 1)))
liftIO $ do
diff --git a/resource-pool.cabal b/resource-pool.cabal
index 01dd057..63a07dd 100644
--- a/resource-pool.cabal
+++ b/resource-pool.cabal
@@ -1,5 +1,5 @@
name: resource-pool
-version: 0.2.0.3
+version: 0.3
synopsis: A high-performance striped resource pooling implementation
description:
A high-performance striped pooling abstraction for managing
@@ -30,7 +30,8 @@ library
build-depends:
base == 4.*,
hashable,
- monad-control >= 0.2.0.1,
+ monad-control >= 0.3.0.1,
+ lifted-base >= 0.1.0.1,
transformers,
stm,
time,
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment