Use MVar from lifted-base

Control/Monad/MVar.hs

@@ -1,64 +0,0 @@
-{- | Lift MVar operations so you can do them within monads stacked on top of IO. Analogous to MonadIO -}
-
-{-# LANGUAGE FlexibleContexts, TupleSections #-}
-
-module Control.Monad.MVar (
-	MVar,
-	module Control.Monad.MVar,
-	liftIO,
-) where
-
-import Control.Concurrent.MVar (MVar)
-import qualified Control.Concurrent.MVar as IO
-import Control.Monad.Error (MonadIO (liftIO))
-import Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith)
-import Control.Exception.Lifted (mask, onException)
-
-newEmptyMVar :: (MonadIO m) => m (MVar a)
-newEmptyMVar = liftIO IO.newEmptyMVar
-
-newMVar :: (MonadIO m) => a -> m (MVar a)
-newMVar = liftIO . IO.newMVar
-
-takeMVar :: (MonadIO m) => MVar a -> m a
-takeMVar = liftIO . IO.takeMVar
-
-putMVar :: (MonadIO m) => MVar a -> a -> m ()
-putMVar var = liftIO . IO.putMVar var
-
-readMVar :: (MonadIO m) => MVar a -> m a
-readMVar = liftIO . IO.readMVar
-
-swapMVar :: (MonadIO m) => MVar a -> a -> m a
-swapMVar var = liftIO . IO.swapMVar var
-
-tryTakeMVar :: (MonadIO m) => MVar a -> m (Maybe a)
-tryTakeMVar = liftIO . IO.tryTakeMVar
-
-tryPutMVar :: (MonadIO m) => MVar a -> a -> m Bool
-tryPutMVar var = liftIO . IO.tryPutMVar var
-
-isEmptyMVar :: (MonadIO m) => MVar a -> m Bool
-isEmptyMVar = liftIO . IO.isEmptyMVar
-
-modifyMVar :: (MonadIO m, MonadBaseControl IO m) => MVar a -> (a -> m (a, b)) -> m b
-modifyMVar m io =
-  mask $ \restore -> do
-    a      <- takeMVar m
-    (a',b) <- restore (io a) `onException` putMVar m a
-    putMVar m a'
-    return b
-
-addMVarFinalizer :: (MonadIO m, MonadBaseControl IO m) => MVar a -> m () -> m ()
-addMVarFinalizer mv f = liftBaseWith $ \run ->
-  IO.addMVarFinalizer mv (run f >> return ())
-
-modifyMVar_ :: (MonadIO m, MonadBaseControl IO m) => MVar a -> (a -> m a) -> m ()
-modifyMVar_ var act = modifyMVar var $ \a -> do
-	a' <- act a
-	return (a', ())
-
-withMVar :: (MonadIO m, MonadBaseControl IO m) => MVar a -> (a -> m b) -> m b
-withMVar var act = modifyMVar var $ \a -> do
-	b <- act a
-	return (a, b)

Database/MongoDB/Connection.hs

@@ -23,7 +23,7 @@ import Network (HostName, PortID(..), connectTo)
 import Text.ParserCombinators.Parsec as T (parse, many1, letter, digit, char, eof, spaces, try, (<|>))
 import Control.Monad.Identity (runIdentity)
 import Control.Monad.Error (ErrorT(..), lift, throwError)
-import Control.Monad.MVar
+import Control.Concurrent.MVar.Lifted
 import Control.Monad (forM_)
 import Control.Applicative ((<$>))
 import Data.UString (UString, unpack)

Database/MongoDB/Query.hs

@@ -44,7 +44,7 @@ import Data.Bson (Document, at, valueAt, lookup, look, Field(..), (=:), (=?), La
 import Database.MongoDB.Internal.Protocol (Pipe, Notice(..), Request(GetMore, qOptions, qFullCollection, qSkip, qBatchSize, qSelector, qProjector), Reply(..), QueryOption(..), ResponseFlag(..), InsertOption(..), UpdateOption(..), DeleteOption(..), CursorId, FullCollection, Username, Password, pwKey)
 import qualified Database.MongoDB.Internal.Protocol as P (send, call, Request(Query))
 import Database.MongoDB.Internal.Util (MonadIO', loop, liftIOE, true1, (<.>))
-import Control.Monad.MVar
+import Control.Concurrent.MVar.Lifted
 import Control.Monad.Error
 import Control.Monad.Reader
 import Control.Monad.State (StateT)
@@ -76,11 +76,9 @@ instance MonadTrans Action where
 
 instance MonadTransControl Action where
     newtype StT Action a = StActionT {unStAction :: StT (ReaderT Context) (StT (ErrorT Failure) a)}
-
     liftWith f = Action $ liftWith $ \runError ->
-                            liftWith $ \runReader ->
+                            liftWith $ \runReader' ->
-                              f (liftM StActionT . runReader . runError . unAction)
+                              f (liftM StActionT . runReader' . runError . unAction)
-
     restoreT = Action . restoreT . restoreT . liftM unStAction
 
 access :: (MonadIO m) => Pipe -> AccessMode -> Database -> Action m a -> m (Either Failure a)
@@ -500,6 +498,7 @@ nextBatch (Cursor fcol batchSize var) = modifyMVar var $ \dBatch -> do
 	dBatch' <- if cid /= 0 then nextBatch' fcol batchSize limit cid else return $ return (Batch 0 0 [])
 	return (dBatch', docs)
 
+fulfill' :: (MonadIO m) => FullCollection -> BatchSize -> DelayedBatch -> Action m Batch
 -- Discard pre-fetched batch if empty with nonzero cid.
 fulfill' fcol batchSize dBatch = do
 	b@(Batch limit cid docs) <- fulfill dBatch
@@ -507,6 +506,7 @@ fulfill' fcol batchSize dBatch = do
 		then nextBatch' fcol batchSize limit cid >>= fulfill
 		else return b
 
+nextBatch' :: (MonadIO m) => FullCollection -> BatchSize -> Limit -> CursorId -> Action m DelayedBatch
 nextBatch' fcol batchSize limit cid = request [] (GetMore fcol batchSize' cid, remLimit)
 	where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit
 
@@ -541,7 +541,7 @@ closeCursor (Cursor _ _ var) = modifyMVar var $ \dBatch -> do
 	unless (cid == 0) $ send [KillCursors [cid]]
 	return $ (return $ Batch 0 0 [], ())
 
-isCursorClosed :: (MonadIO m) => Cursor -> Action m Bool
+isCursorClosed :: (MonadIO m, MonadBase IO m) => Cursor -> Action m Bool
 isCursorClosed (Cursor _ _ var) = do
 		Batch _ cid docs <- fulfill =<< readMVar var
 		return (cid == 0 && null docs)

System/IO/Pipeline.hs

@@ -16,7 +16,7 @@ import Prelude hiding (length)
 import GHC.Conc (ThreadStatus(..), threadStatus)
 import Control.Concurrent (ThreadId, forkIO, killThread)
 import Control.Concurrent.Chan
-import Control.Monad.MVar
+import Control.Concurrent.MVar.Lifted
 import Control.Monad.Error
 
 onException :: (Monad m) => ErrorT e m a -> m () -> ErrorT e m a

System/IO/Pool.hs

@@ -5,7 +5,7 @@
 module System.IO.Pool where
 
 import Control.Applicative ((<$>))
-import Control.Monad.MVar
+import Control.Concurrent.MVar.Lifted
 import Data.Array.IO
 import Data.Maybe (catMaybes)
 import Control.Monad.Error

mongoDB.cabal

@@ -35,7 +35,6 @@ data-dir: ""
 extra-source-files:
 extra-tmp-files:
 exposed-modules:
-    Control.Monad.MVar
     Database.MongoDB
     Database.MongoDB.Admin
     Database.MongoDB.Connection