Use MVar from lifted-base
This commit is contained in:
parent
d0aeb42e7c
commit
2f23e78c28
6 changed files with 9 additions and 74 deletions
|
@ -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)
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue