basvandijk avatar basvandijk committed 4b62d63

Support monad-control-0.3. Fixes: #5

Comments (0)

Files changed (2)

 {-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ScopedTypeVariables #-}
 
+#if MIN_VERSION_monad_control(0,3,0)
+{-# LANGUAGE FlexibleContexts #-}
+#endif
+
 -- |
 -- Module:      Data.Pool
 -- Copyright:   (c) 2011 MailRank, Inc.
 import Control.Concurrent.STM
 import Control.Exception (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 Data.Hashable (hash)
 import Data.List (partition)
 import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
 import System.Mem.Weak (addFinalizer)
 import qualified Data.Vector as V
 
+#if MIN_VERSION_monad_control(0,3,0)
+import Control.Monad.Trans.Control (MonadBaseControl, control)
+import Control.Monad.Base (liftBase)
+#else
+import Control.Monad.IO.Control (MonadControlIO, controlIO)
+import Control.Monad.IO.Class (liftIO)
+#define control controlIO
+#define liftBase liftIO
+#endif
+
 -- | A single resource pool entry.
 data Entry a = Entry {
       entry :: a
 -- 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 ::
+#if MIN_VERSION_monad_control(0,3,0)
+    (MonadBaseControl IO m)
+#else
+    (MonadControlIO m)
+#endif
+  => 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
+  i <- liftBase $ ((`mod` numStripes) . hash) <$> myThreadId
   let LocalPool{..} = localPools V.! i
-  resource <- liftIO . join . atomically $ do
+  resource <- liftBase . join . atomically $ do
     ents <- readTVar entries
     case ents of
       (Entry{..}:es) -> writeTVar entries es >> return (return entry)
         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
+  liftBase $ do
     now <- getCurrentTime
     atomically $ modifyTVar_ entries (Entry resource now:)
   return ret

resource-pool.cabal

     hashable,
     monad-control >= 0.2.0.1,
     transformers,
+    transformers-base >= 0.4,
     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.