diff --git a/Control/Monad/MVar.hs b/Control/Monad/MVar.hs deleted file mode 100644 index 46b0d6a..0000000 --- a/Control/Monad/MVar.hs +++ /dev/null @@ -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) diff --git a/Database/MongoDB/Connection.hs b/Database/MongoDB/Connection.hs index 7cde197..e5ddddf 100644 --- a/Database/MongoDB/Connection.hs +++ 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) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 77e3efb..e348384 100644 --- a/Database/MongoDB/Query.hs +++ b/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 -> - f (liftM StActionT . runReader . runError . unAction) - + liftWith $ \runReader' -> + 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) diff --git a/System/IO/Pipeline.hs b/System/IO/Pipeline.hs index f2f6795..04243c7 100644 --- a/System/IO/Pipeline.hs +++ b/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 diff --git a/System/IO/Pool.hs b/System/IO/Pool.hs index 6ca0bef..0ec9f6c 100644 --- a/System/IO/Pool.hs +++ b/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 diff --git a/mongoDB.cabal b/mongoDB.cabal index abefbf2..eefc7d2 100644 --- a/mongoDB.cabal +++ b/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