Use MVar from lifted-base

This commit is contained in:
Tony Hannan 2012-01-23 20:45:10 -05:00
parent d0aeb42e7c
commit 2f23e78c28
6 changed files with 9 additions and 74 deletions

View file

@ -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)

View file

@ -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)

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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