Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Support monad-control-0.3. Fixes: #5

  • Loading branch information...
commit b728aec66adb01102665544f34f7fb6958fe8df6 1 parent 9eaf633
Bas van Dijk authored December 09, 2011
32  Data/Pool.hs
... ...
@@ -1,5 +1,9 @@
1 1
 {-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ScopedTypeVariables #-}
2 2
 
  3
+#if MIN_VERSION_monad_control(0,3,0)
  4
+{-# LANGUAGE FlexibleContexts #-}
  5
+#endif
  6
+
3 7
 -- |
4 8
 -- Module:      Data.Pool
5 9
 -- Copyright:   (c) 2011 MailRank, Inc.
@@ -30,8 +34,6 @@ import Control.Concurrent (forkIO, killThread, myThreadId, threadDelay)
30 34
 import Control.Concurrent.STM
31 35
 import Control.Exception (SomeException, catch, onException)
32 36
 import Control.Monad (forM_, forever, join, liftM2, unless, when)
33  
-import Control.Monad.IO.Class (liftIO)
34  
-import Control.Monad.IO.Control (MonadControlIO, controlIO)
35 37
 import Data.Hashable (hash)
36 38
 import Data.List (partition)
37 39
 import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
@@ -39,6 +41,16 @@ import Prelude hiding (catch)
39 41
 import System.Mem.Weak (addFinalizer)
40 42
 import qualified Data.Vector as V
41 43
 
  44
+#if MIN_VERSION_monad_control(0,3,0)
  45
+import Control.Monad.Trans.Control (MonadBaseControl, control)
  46
+import Control.Monad.Base (liftBase)
  47
+#else
  48
+import Control.Monad.IO.Control (MonadControlIO, controlIO)
  49
+import Control.Monad.IO.Class (liftIO)
  50
+#define control controlIO
  51
+#define liftBase liftIO
  52
+#endif
  53
+
42 54
 -- | A single resource pool entry.
43 55
 data Entry a = Entry {
44 56
       entry :: a
@@ -164,12 +176,18 @@ reaper destroy idleTime pools = forever $ do
164 176
 -- destroy a pooled resource, as doing so will almost certainly cause
165 177
 -- a subsequent user (who expects the resource to be valid) to throw
166 178
 -- an exception.
167  
-withResource :: MonadControlIO m => Pool a -> (a -> m b) -> m b
  179
+withResource ::
  180
+#if MIN_VERSION_monad_control(0,3,0)
  181
+    (MonadBaseControl IO m)
  182
+#else
  183
+    (MonadControlIO m)
  184
+#endif
  185
+  => Pool a -> (a -> m b) -> m b
168 186
 {-# SPECIALIZE withResource :: Pool a -> (a -> IO b) -> IO b #-}
169 187
 withResource Pool{..} act = do
170  
-  i <- liftIO $ ((`mod` numStripes) . hash) <$> myThreadId
  188
+  i <- liftBase $ ((`mod` numStripes) . hash) <$> myThreadId
171 189
   let LocalPool{..} = localPools V.! i
172  
-  resource <- liftIO . join . atomically $ do
  190
+  resource <- liftBase . join . atomically $ do
173 191
     ents <- readTVar entries
174 192
     case ents of
175 193
       (Entry{..}:es) -> writeTVar entries es >> return (return entry)
@@ -179,10 +197,10 @@ withResource Pool{..} act = do
179 197
         writeTVar inUse $! used + 1
180 198
         return $
181 199
           create `onException` atomically (modifyTVar_ inUse (subtract 1))
182  
-  ret <- controlIO $ \runInIO -> runInIO (act resource) `onException` (do
  200
+  ret <- control $ \runInIO -> runInIO (act resource) `onException` (do
183 201
            destroy resource `catch` \(_::SomeException) -> return ()
184 202
            atomically (modifyTVar_ inUse (subtract 1)))
185  
-  liftIO $ do
  203
+  liftBase $ do
186 204
     now <- getCurrentTime
187 205
     atomically $ modifyTVar_ entries (Entry resource now:)
188 206
   return ret
1  resource-pool.cabal
@@ -32,6 +32,7 @@ library
32 32
     hashable,
33 33
     monad-control >= 0.2.0.1,
34 34
     transformers,
  35
+    transformers-base >= 0.4,
35 36
     stm,
36 37
     time,
37 38
     vector >= 0.7

0 notes on commit b728aec

Please sign in to comment.
Something went wrong with that request. Please try again.