Add modifyMVar for Action monad
This commit is contained in:
parent
ef819eb1aa
commit
dd6c5057f5
2 changed files with 29 additions and 22 deletions
|
@ -65,9 +65,9 @@ shuffle :: [a] -> IO [a]
|
|||
-- ^ Randomly shuffle items in list
|
||||
shuffle list = shuffle' list (length list) <$> newStdGen
|
||||
|
||||
loop :: (Functor m, Monad m) => m (Maybe a) -> m [a]
|
||||
loop :: Monad m => m (Maybe a) -> m [a]
|
||||
-- ^ Repeatedy execute action, collecting results, until it returns Nothing
|
||||
loop act = act >>= maybe (return []) (\a -> (a :) <$> loop act)
|
||||
loop act = act >>= maybe (return []) (\a -> (a :) `liftM` loop act)
|
||||
|
||||
untilSuccess :: (MonadError e m, Error e) => (a -> m b) -> [a] -> m b
|
||||
-- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw 'strMsg' error if list is empty.
|
||||
|
|
|
@ -57,17 +57,17 @@ import Data.Monoid (mappend)
|
|||
#endif
|
||||
import Data.Typeable (Typeable)
|
||||
|
||||
import qualified Control.Concurrent.MVar as MV
|
||||
#if MIN_VERSION_base(4,6,0)
|
||||
import Control.Concurrent.MVar.Lifted (MVar, newMVar, mkWeakMVar,
|
||||
readMVar, modifyMVar)
|
||||
readMVar)
|
||||
#else
|
||||
import Control.Concurrent.MVar.Lifted (MVar, newMVar, addMVarFinalizer,
|
||||
readMVar, modifyMVar)
|
||||
readMVar)
|
||||
#endif
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Exception (SomeException, catch)
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.Base (MonadBase)
|
||||
import Control.Monad.Error (Error(..))
|
||||
import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask, asks, local)
|
||||
import Control.Monad.Trans (MonadIO, liftIO)
|
||||
|
@ -840,7 +840,7 @@ findOne q = do
|
|||
pipe <- asks mongoPipe
|
||||
qr <- queryRequest False q {limit = 1}
|
||||
rq <- liftIO $ request pipe [] qr
|
||||
Batch _ _ docs <- fulfill rq
|
||||
Batch _ _ docs <- liftDB $ fulfill rq
|
||||
return (listToMaybe docs)
|
||||
|
||||
fetch :: (MonadIO m) => Query -> Action m Document
|
||||
|
@ -929,7 +929,7 @@ explain q = do -- same as findOne but with explain set to true
|
|||
pipe <- asks mongoPipe
|
||||
qr <- queryRequest True q {limit = 1}
|
||||
r <- liftIO $ request pipe [] qr
|
||||
Batch _ _ docs <- fulfill r
|
||||
Batch _ _ docs <- liftDB $ fulfill r
|
||||
return $ if null docs then error ("no explain: " ++ show q) else head docs
|
||||
|
||||
count :: (MonadIO m) => Query -> Action m Int
|
||||
|
@ -998,7 +998,7 @@ fromReply limit Reply{..} = do
|
|||
CursorNotFound -> throwIO $ CursorNotFoundFailure rCursorId
|
||||
QueryError -> throwIO $ QueryFailure (at "code" $ head rDocuments) (at "$err" $ head rDocuments)
|
||||
|
||||
fulfill :: (MonadIO m) => DelayedBatch -> Action m Batch
|
||||
fulfill :: DelayedBatch -> Action IO Batch
|
||||
-- ^ Demand and wait for result, raise failure if exception
|
||||
fulfill = liftIO
|
||||
|
||||
|
@ -1018,11 +1018,11 @@ newCursor db col batchSize dBatch = do
|
|||
where mkWeakMVar = addMVarFinalizer
|
||||
#endif
|
||||
|
||||
nextBatch :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m [Document]
|
||||
nextBatch :: MonadIO m => Cursor -> Action m [Document]
|
||||
-- ^ Return next batch of documents in query result, which will be empty if finished.
|
||||
nextBatch (Cursor fcol batchSize var) = modifyMVar var $ \dBatch -> do
|
||||
nextBatch (Cursor fcol batchSize var) = liftDB $ modifyMVar var $ \dBatch -> do
|
||||
-- Pre-fetch next batch promise from server and return current batch.
|
||||
Batch mLimit cid docs <- fulfill' fcol batchSize dBatch
|
||||
Batch mLimit cid docs <- liftDB $ fulfill' fcol batchSize dBatch
|
||||
let newLimit = do
|
||||
limit <- mLimit
|
||||
return $ limit - (min limit $ fromIntegral $ length docs)
|
||||
|
@ -1037,7 +1037,7 @@ nextBatch (Cursor fcol batchSize var) = modifyMVar var $ \dBatch -> do
|
|||
return (emptyBatch, resultDocs)
|
||||
(_, _) -> (, resultDocs) <$> getNextBatch
|
||||
|
||||
fulfill' :: (MonadIO m) => FullCollection -> BatchSize -> DelayedBatch -> Action m Batch
|
||||
fulfill' :: FullCollection -> BatchSize -> DelayedBatch -> Action IO Batch
|
||||
-- Discard pre-fetched batch if empty with nonzero cid.
|
||||
fulfill' fcol batchSize dBatch = do
|
||||
b@(Batch limit cid docs) <- fulfill dBatch
|
||||
|
@ -1051,13 +1051,13 @@ nextBatch' fcol batchSize limit cid = do
|
|||
liftIO $ request pipe [] (GetMore fcol batchSize' cid, remLimit)
|
||||
where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit
|
||||
|
||||
next :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m (Maybe Document)
|
||||
next :: MonadIO m => Cursor -> Action m (Maybe Document)
|
||||
-- ^ Return next document in query result, or Nothing if finished.
|
||||
next (Cursor fcol batchSize var) = modifyMVar var nextState where
|
||||
next (Cursor fcol batchSize var) = liftDB $ modifyMVar var nextState where
|
||||
-- Pre-fetch next batch promise from server when last one in current batch is returned.
|
||||
-- nextState:: DelayedBatch -> Action m (DelayedBatch, Maybe Document)
|
||||
nextState dBatch = do
|
||||
Batch mLimit cid docs <- fulfill' fcol batchSize dBatch
|
||||
Batch mLimit cid docs <- liftDB $ fulfill' fcol batchSize dBatch
|
||||
if mLimit == (Just 0)
|
||||
then return (return $ Batch (Just 0) 0 [], Nothing)
|
||||
else
|
||||
|
@ -1075,27 +1075,29 @@ next (Cursor fcol batchSize var) = modifyMVar var nextState where
|
|||
return (dBatch', Just doc)
|
||||
[] -> if cid == 0
|
||||
then return (return $ Batch (Just 0) 0 [], Nothing) -- finished
|
||||
else fmap (,Nothing) $ nextBatch' fcol batchSize mLimit cid
|
||||
else do
|
||||
nb <- nextBatch' fcol batchSize mLimit cid
|
||||
return (nb, Nothing)
|
||||
|
||||
nextN :: (MonadIO m, MonadBaseControl IO m) => Int -> Cursor -> Action m [Document]
|
||||
nextN :: MonadIO m => Int -> Cursor -> Action m [Document]
|
||||
-- ^ Return next N documents or less if end is reached
|
||||
nextN n c = catMaybes `liftM` replicateM n (next c)
|
||||
|
||||
rest :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m [Document]
|
||||
rest :: MonadIO m => Cursor -> Action m [Document]
|
||||
-- ^ Return remaining documents in query result
|
||||
rest c = loop (next c)
|
||||
|
||||
closeCursor :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m ()
|
||||
closeCursor (Cursor _ _ var) = modifyMVar var $ \dBatch -> do
|
||||
closeCursor :: MonadIO m => Cursor -> Action m ()
|
||||
closeCursor (Cursor _ _ var) = liftDB $ modifyMVar var $ \dBatch -> do
|
||||
Batch _ cid _ <- fulfill dBatch
|
||||
unless (cid == 0) $ do
|
||||
pipe <- asks mongoPipe
|
||||
liftIOE ConnectionFailure $ P.send pipe [KillCursors [cid]]
|
||||
return $ (return $ Batch (Just 0) 0 [], ())
|
||||
|
||||
isCursorClosed :: (MonadIO m, MonadBase IO m) => Cursor -> Action m Bool
|
||||
isCursorClosed :: MonadIO m => Cursor -> Action m Bool
|
||||
isCursorClosed (Cursor _ _ var) = do
|
||||
Batch _ cid docs <- fulfill =<< readMVar var
|
||||
Batch _ cid docs <- liftDB $ fulfill =<< readMVar var
|
||||
return (cid == 0 && null docs)
|
||||
|
||||
-- ** Aggregate
|
||||
|
@ -1242,6 +1244,11 @@ eval :: (MonadIO m, Val v) => Javascript -> Action m v
|
|||
-- ^ Run code on server
|
||||
eval code = at "retval" `liftM` runCommand ["$eval" =: code]
|
||||
|
||||
modifyMVar :: MVar a -> (a -> Action IO (a, b)) -> Action IO b
|
||||
modifyMVar v f = do
|
||||
ctx <- ask
|
||||
liftIO $ MV.modifyMVar v (\x -> runReaderT (f x) ctx)
|
||||
|
||||
|
||||
{- Authors: Tony Hannan <tony@10gen.com>
|
||||
Copyright 2011 10gen Inc.
|
||||
|
|
Loading…
Reference in a new issue