From a399e81925bac6f281a37c3e1ae859087c38bb6d Mon Sep 17 00:00:00 2001
From: Tony Hannan <tony@10gen.com>
Date: Wed, 26 Jan 2011 14:25:12 -0500
Subject: [PATCH] Access monad no longer needs to be a MonadMVar

---
 Database/MongoDB/Query.hs | 32 ++++++++++++++++++++++++++------
 mongoDB.cabal             |  6 +++---
 2 files changed, 29 insertions(+), 9 deletions(-)

diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs
index baf531c..26d46ba 100644
--- a/Database/MongoDB/Query.hs
+++ b/Database/MongoDB/Query.hs
@@ -70,11 +70,30 @@ access w mos pool act = do
 	either (return . Left . ConnectionFailure) (runAction act w mos) ePipe
 
 -- | A monad with access to a 'Pipe', 'MasterOrSlaveOk', and 'WriteMode', and throws 'Failure' on read, write, or pipe failure
-class (Context Pipe m, Context MasterOrSlaveOk m, Context WriteMode m, Throw Failure m, MonadIO' m, MonadMVar m) => Access m
-instance (Context Pipe m, Context MasterOrSlaveOk m, Context WriteMode m, Throw Failure m, MonadIO' m, MonadMVar m) => Access m
+class (Context Pipe m, Context MasterOrSlaveOk m, Context WriteMode m, Throw Failure m, MonadIO' m) => Access m
+instance (Context Pipe m, Context MasterOrSlaveOk m, Context WriteMode m, Throw Failure m, MonadIO' m) => Access m
+
+wrapIO :: (Access m) => (WriteMode -> MasterOrSlaveOk -> Pipe -> IO (Either Failure a)) -> m a
+-- ^ Lift IO with Access context and failure into Access monad
+wrapIO act = do
+	writeMod <- context
+	mos <- context
+	pipe <- context
+	e <- liftIO (act writeMod mos pipe)
+	either throw return e
+
+modifyMVar' :: (Access m) => MVar a -> (a -> Action IO (a, b)) -> m b
+modifyMVar' var act = wrapIO $ \w m p -> modifyMVar var $ \a -> do
+	e <- runAction (act a) w m p
+	return $ either ((a,) . Left) (Right <$>) e
+	
+addMVarFinalizer' :: (Access m) => MVar a -> Action IO () -> m ()
+addMVarFinalizer' var act = wrapIO $ \w m p -> do
+	addMVarFinalizer var $ runAction act w m p >> return ()  -- ignore any failure
+	return (Right ())
 
 newtype Action m a = Action (ErrorT Failure (ReaderT WriteMode (ReaderT MasterOrSlaveOk (ReaderT Pipe m))) a)
-	deriving (Context Pipe, Context MasterOrSlaveOk, Context WriteMode, Throw Failure, MonadIO, MonadMVar, Monad, Applicative, Functor)
+	deriving (Context Pipe, Context MasterOrSlaveOk, Context WriteMode, Throw Failure, MonadIO, Monad, Applicative, Functor)
 -- ^ Monad with access to a 'Pipe', 'MasterOrSlaveOk', and 'WriteMode', and throws a 'Failure' on read, write or pipe failure
 
 instance MonadTrans Action where
@@ -440,13 +459,14 @@ newCursor :: (Access m) => Database -> Collection -> BatchSize -> DelayedCursorS
 newCursor (Database db) col batch cs = do
 	var <- newMVar cs
 	let cursor = Cursor (db <.> col) batch var
-	addMVarFinalizer var (closeCursor cursor)
+	addMVarFinalizer' var (closeCursor cursor)
 	return cursor
 
 next :: (Access m) => Cursor -> m (Maybe Document)
 -- ^ Return next document in query result, or Nothing if finished.
-next (Cursor fcol batch var) = modifyMVar var nextState where
+next (Cursor fcol batch var) = modifyMVar' var nextState where
 	-- Pre-fetch next batch promise from server when last one in current batch is returned.
+	nextState:: DelayedCursorState -> Action IO (DelayedCursorState, Maybe Document)
 	nextState dcs = do
 		CS limit cid docs <- mapErrorIO id dcs
 		case docs of
@@ -470,7 +490,7 @@ rest :: (Access m) => Cursor -> m [Document]
 rest c = loop (next c)
 
 closeCursor :: (Access m) => Cursor -> m ()
-closeCursor (Cursor _ _ var) = modifyMVar var kill' where
+closeCursor (Cursor _ _ var) = modifyMVar' var kill' where
  	kill' dcs = first return <$> (kill =<< mapErrorIO id dcs)
 	kill (CS _ cid _) = (CS 0 0 [],) <$> if cid == 0 then return () else send [KillCursors [cid]]
 
diff --git a/mongoDB.cabal b/mongoDB.cabal
index dca2bbf..eb68eb0 100644
--- a/mongoDB.cabal
+++ b/mongoDB.cabal
@@ -1,5 +1,5 @@
 name: mongoDB
-version: 0.9.1
+version: 0.9.2
 build-type: Simple
 license: OtherLicense
 license-file: LICENSE
@@ -21,8 +21,8 @@ stability: alpha
 homepage: http://github.com/TonyGen/mongoDB-haskell
 package-url:
 bug-reports:
-synopsis: A driver for MongoDB
-description: This module lets you connect to MongoDB (www.mongodb.org) and do inserts, queries, updates, etc.
+synopsis: MongoDB driver
+description: This module lets you connect to MongoDB (www.mongodb.org) and do inserts, queries, updates, etc. Please see the example in Database.MongoDB and the tutorial from the homepage.
 category: Database
 author: Tony Hannan <tony@10gen.com> & Scott Parish <srp@srparish.net>
 tested-with: