-
-
Save norm2782/97ce5cef88ededac573a to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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