Move to monad-control

This commit is contained in:
Michael Snoyman 2011-08-25 16:29:39 +03:00
parent 4307fea5aa
commit a320c363e4
4 changed files with 37 additions and 50 deletions

View file

@ -5,14 +5,15 @@
module Control.Monad.MVar (
MVar,
module Control.Monad.MVar,
liftIO
liftIO,
MonadControlIO
) where
import Control.Concurrent.MVar (MVar)
import qualified Control.Concurrent.MVar as IO
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Error (MonadIO (liftIO))
import Control.Monad.IO.Control (MonadControlIO, controlIO)
import Control.Exception.Control (mask, onException)
newEmptyMVar :: (MonadIO m) => m (MVar a)
newEmptyMVar = liftIO IO.newEmptyMVar
@ -41,39 +42,24 @@ tryPutMVar var = liftIO . IO.tryPutMVar var
isEmptyMVar :: (MonadIO m) => MVar a -> m Bool
isEmptyMVar = liftIO . IO.isEmptyMVar
class (MonadIO m) => MonadMVar m where
modifyMVar :: MVar a -> (a -> m (a, b)) -> m b
addMVarFinalizer :: MVar a -> m () -> m ()
modifyMVar :: MonadControlIO 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
modifyMVar_ :: (MonadMVar m) => MVar a -> (a -> m a) -> m ()
addMVarFinalizer :: MonadControlIO m => MVar a -> m () -> m ()
addMVarFinalizer mvar f = controlIO $ \run ->
return $ liftIO $ addMVarFinalizer mvar (run f >> return ())
modifyMVar_ :: (MonadControlIO m) => MVar a -> (a -> m a) -> m ()
modifyMVar_ var act = modifyMVar var $ \a -> do
a' <- act a
return (a', ())
withMVar :: (MonadMVar m) => MVar a -> (a -> m b) -> m b
withMVar :: (MonadControlIO m) => MVar a -> (a -> m b) -> m b
withMVar var act = modifyMVar var $ \a -> do
b <- act a
return (a, b)
instance MonadMVar IO where
modifyMVar = IO.modifyMVar
addMVarFinalizer = IO.addMVarFinalizer
instance (MonadMVar m, Error e) => MonadMVar (ErrorT e m) where
modifyMVar var f = ErrorT $ modifyMVar var $ \a -> do
e <- runErrorT (f a)
return $ either ((a, ) . Left) (fmap Right) e
addMVarFinalizer var (ErrorT act) = ErrorT $
addMVarFinalizer var (act >> return ()) >> return (Right ())
-- NOTE, error is silently dropped
instance (MonadMVar m) => MonadMVar (ReaderT r m) where
modifyMVar var f = ReaderT $ \r -> modifyMVar var $ \a -> runReaderT (f a) r
addMVarFinalizer var (ReaderT act) = ReaderT (addMVarFinalizer var . act)
instance (MonadMVar m) => MonadMVar (StateT s m) where
modifyMVar var f = StateT $ \s -> modifyMVar var $ \a -> do
((a', b), s') <- runStateT (f a) s
return (a', (b, s'))
addMVarFinalizer var (StateT act) = StateT $ \s ->
addMVarFinalizer var (act s >> return ()) >> return ((), s)

View file

@ -39,7 +39,7 @@ import qualified Data.Set as S
import System.IO.Unsafe (unsafePerformIO)
import Control.Concurrent (forkIO, threadDelay)
import Database.MongoDB.Internal.Util (MonadIO', (<.>), true1)
import Control.Monad.MVar (MonadMVar)
import Control.Monad.MVar (MonadControlIO)
-- * Admin
@ -122,7 +122,7 @@ dropIndex coll idxName = do
resetIndexCache
runCommand ["deleteIndexes" =: coll, "index" =: idxName]
getIndexes :: (MonadMVar m, Functor m) => Collection -> Action m [Document]
getIndexes :: (MonadControlIO m, Functor m) => Collection -> Action m [Document]
-- ^ Get all indexes on this collection
getIndexes coll = do
db <- thisDatabase
@ -175,7 +175,7 @@ resetIndexCache = do
-- ** User
allUsers :: (MonadMVar m, Functor m) => Action m [Document]
allUsers :: (MonadControlIO m, Functor m) => Action m [Document]
-- ^ Fetch all users of this database
allUsers = map (exclude ["_id"]) <$> (rest =<< find
(select [] "system.users") {sort = ["user" =: (1 :: Int)], project = ["user" =: (1 :: Int), "readOnly" =: (1 :: Int)]})
@ -242,7 +242,7 @@ storageSize c = at "storageSize" <$> collectionStats c
totalIndexSize :: (MonadIO' m) => Collection -> Action m Int
totalIndexSize c = at "totalIndexSize" <$> collectionStats c
totalSize :: (MonadMVar m, MonadIO' m) => Collection -> Action m Int
totalSize :: (MonadControlIO m, MonadIO' m) => Collection -> Action m Int
totalSize coll = do
x <- storageSize coll
xs <- mapM isize =<< getIndexes coll

View file

@ -58,7 +58,7 @@ import Data.Word (Word32)
-- * Monad
newtype Action m a = Action (ErrorT Failure (ReaderT Context m) a)
deriving (Functor, Applicative, Monad, MonadIO, MonadMVar, MonadError Failure)
deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO, MonadError Failure)
-- ^ A monad on top of m (which must be a MonadIO) that may access the database and may fail with a DB 'Failure'
instance MonadTrans Action where lift = Action . lift . lift
@ -139,11 +139,11 @@ call ns r = Action $ do
return (liftIOE ConnectionFailure promise)
-- | If you stack a monad on top of 'Action' then make it an instance of this class and use 'liftDB' to execute a DB Action within it. Instances already exist for the basic mtl transformers.
class (Monad m, MonadMVar (BaseMonad m), Applicative (BaseMonad m), Functor (BaseMonad m)) => MonadDB m where
class (Monad m, MonadControlIO (BaseMonad m), Applicative (BaseMonad m), Functor (BaseMonad m)) => MonadDB m where
type BaseMonad m :: * -> *
liftDB :: Action (BaseMonad m) a -> m a
instance (MonadMVar m, Applicative m, Functor m) => MonadDB (Action m) where
instance (MonadControlIO m, Applicative m, Functor m) => MonadDB (Action m) where
type BaseMonad (Action m) = m
liftDB = id
@ -192,7 +192,7 @@ auth usr pss = do
type Collection = UString
-- ^ Collection name (not prefixed with database)
allCollections :: (MonadMVar m, Functor m) => Action m [Collection]
allCollections :: (MonadControlIO m, Functor m) => Action m [Collection]
-- ^ List all collections in this database
allCollections = do
db <- thisDatabase
@ -369,7 +369,7 @@ query :: Selector -> Collection -> Query
-- ^ Selects documents in collection that match selector. It uses no query options, projects all fields, does not skip any documents, does not limit result size, uses default batch size, does not sort, does not hint, and does not snapshot.
query sel col = Query [] (Select sel col) [] 0 0 [] False 0 []
find :: (MonadMVar m) => Query -> Action m Cursor
find :: (MonadControlIO m) => Query -> Action m Cursor
-- ^ Fetch documents satisfying query
find q@Query{selection, batchSize} = do
db <- thisDatabase
@ -464,7 +464,7 @@ fulfill = Action . liftIOE id
data Cursor = Cursor FullCollection BatchSize (MVar DelayedBatch)
-- ^ Iterator over results of a query. Use 'next' to iterate or 'rest' to get all results. A cursor is closed when it is explicitly closed, all results have been read from it, garbage collected, or not used for over 10 minutes (unless 'NoCursorTimeout' option was specified in 'Query'). Reading from a closed cursor raises a 'CursorNotFoundFailure'. Note, a cursor is not closed when the pipe is closed, so you can open another pipe to the same server and continue using the cursor.
newCursor :: (MonadMVar m) => Database -> Collection -> BatchSize -> DelayedBatch -> Action m Cursor
newCursor :: (MonadControlIO m) => Database -> Collection -> BatchSize -> DelayedBatch -> Action m Cursor
-- ^ Create new cursor. If you don't read all results then close it. Cursor will be closed automatically when all results are read from it or when eventually garbage collected.
newCursor db col batchSize dBatch = do
var <- newMVar dBatch
@ -472,7 +472,7 @@ newCursor db col batchSize dBatch = do
addMVarFinalizer var (closeCursor cursor)
return cursor
nextBatch :: (MonadMVar m) => Cursor -> Action m [Document]
nextBatch :: (MonadControlIO 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
-- Pre-fetch next batch promise from server and return current batch.
@ -483,7 +483,7 @@ nextBatch (Cursor fcol batchSize var) = modifyMVar var $ \dBatch -> do
nextBatch' limit cid = request [] (GetMore fcol batchSize' cid, remLimit)
where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit
next :: (MonadMVar m) => Cursor -> Action m (Maybe Document)
next :: (MonadControlIO 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
-- Pre-fetch next batch promise from server when last one in current batch is returned.
@ -502,15 +502,15 @@ next (Cursor fcol batchSize var) = modifyMVar var nextState where
nextBatch' limit cid = request [] (GetMore fcol batchSize' cid, remLimit)
where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit
nextN :: (MonadMVar m, Functor m) => Int -> Cursor -> Action m [Document]
nextN :: (MonadControlIO m, Functor m) => Int -> Cursor -> Action m [Document]
-- ^ Return next N documents or less if end is reached
nextN n c = catMaybes <$> replicateM n (next c)
rest :: (MonadMVar m, Functor m) => Cursor -> Action m [Document]
rest :: (MonadControlIO m, Functor m) => Cursor -> Action m [Document]
-- ^ Return remaining documents in query result
rest c = loop (next c)
closeCursor :: (MonadMVar m) => Cursor -> Action m ()
closeCursor :: (MonadControlIO m) => Cursor -> Action m ()
closeCursor (Cursor _ _ var) = modifyMVar var $ \dBatch -> do
Batch _ cid _ <- fulfill dBatch
unless (cid == 0) $ send [KillCursors [cid]]
@ -618,7 +618,7 @@ mapReduce :: Collection -> MapFun -> ReduceFun -> MapReduce
-- ^ MapReduce on collection with given map and reduce functions. Remaining attributes are set to their defaults, which are stated in their comments.
mapReduce col map' red = MapReduce col map' red [] [] 0 Inline Nothing [] False
runMR :: (MonadMVar m, Applicative m) => MapReduce -> Action m Cursor
runMR :: (MonadControlIO m, Applicative m) => MapReduce -> Action m Cursor
-- ^ Run MapReduce and return cursor of results. Error if map/reduce fails (because of bad Javascript)
runMR mr = do
res <- runMR' mr

View file

@ -17,7 +17,8 @@ build-depends:
network -any,
parsec -any,
random -any,
random-shuffle -any
random-shuffle -any,
monad-control >= 0.2 && < 0.3
stability: alpha
homepage: http://github.com/TonyGen/mongoDB-haskell
package-url: