Bryan O'Sullivan avatar Bryan O'Sullivan committed 8c7a1c2 Merge

Merge pull request #1 from informatikr/master

Generalisation of 'withResource' to allow any instance of MonadCatchIO

Comments (0)

Files changed (2)

 import Control.Applicative ((<$>))
 import Control.Concurrent (forkIO, killThread, myThreadId, threadDelay)
 import Control.Concurrent.STM
-import Control.Exception (SomeException, catch, onException)
+import Control.Exception (SomeException, catch)
 import Control.Monad (forM_, forever, join, liftM2, unless, when)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.CatchIO (MonadCatchIO, onException)
 import Data.Hashable (hash)
 import Data.List (partition)
 import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
 -- 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 :: Pool a -> (a -> IO b) -> IO b
+withResource :: MonadCatchIO io => Pool a -> (a -> io b) -> io b
 withResource Pool{..} act = do
-  i <- ((`mod` numStripes) . hash) <$> myThreadId
+  i <- liftIO $ ((`mod` numStripes) . hash) <$> myThreadId
   let LocalPool{..} = localPools V.! i
-  resource <- join . atomically $ do
+  resource <- liftIO . join . atomically $ do
     ents <- readTVar entries
     case ents of
       (Entry{..}:es) -> writeTVar entries es >> return create
         writeTVar inUse $! used + 1
         return $ do
           create `onException` atomically (modifyTVar_ inUse (subtract 1))
-  ret <- act resource `onException` do
+  ret <- act resource `onException` (liftIO $ do
            destroy resource `catch` \(_::SomeException) -> return ()
-           atomically (modifyTVar_ inUse (subtract 1))
-  now <- getCurrentTime
-  atomically $ modifyTVar_ entries (Entry resource now:)
+           atomically (modifyTVar_ inUse (subtract 1)))
+  liftIO $ do
+      now <- getCurrentTime
+      atomically $ modifyTVar_ entries (Entry resource now:)
   return ret
 
 modifyTVar_ :: TVar a -> (a -> a) -> STM ()

resource-pool.cabal

   build-depends:       
     base == 4.*,
     hashable,
+    MonadCatchIO-transformers,
+    transformers,
     stm,
     time,
     vector >= 0.7
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.