Use MonadFail instead of Monad

Database/MongoDB/Admin.hs

@@ -33,6 +33,7 @@ import Control.Applicative ((<$>))
 #endif
 import Control.Concurrent (forkIO, threadDelay)
 import Control.Monad (forever, unless, liftM)
+import Control.Monad.Fail(MonadFail)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.Maybe (maybeToList)
 import Data.Set (Set)
@@ -76,7 +77,7 @@ renameCollection from to = do
     db <- thisDatabase
     useDb admin $ runCommand ["renameCollection" =: db <.> from, "to" =: db <.> to, "dropTarget" =: True]
 
-dropCollection :: (MonadIO m) => Collection -> Action m Bool
+dropCollection :: (MonadIO m, MonadFail m) => Collection -> Action m Bool
 -- ^ Delete the given collection! Return True if collection existed (and was deleted); return False if collection did not exist (and no action).
 dropCollection coll = do
     resetIndexCache

Database/MongoDB/Connection.hs

@@ -24,12 +24,14 @@ module Database.MongoDB.Connection (
 import Prelude hiding (lookup)
 import Data.IORef (IORef, newIORef, readIORef)
 import Data.List (intersect, partition, (\\), delete)
+import Data.Maybe (fromJust)
 
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative ((<$>))
 #endif
 
 import Control.Monad (forM_)
+import Control.Monad.Fail(MonadFail)
 import System.IO.Unsafe (unsafePerformIO)
 import System.Timeout (timeout)
 import Text.ParserCombinators.Parsec (parse, many1, letter, digit, char, eof,
@@ -81,7 +83,7 @@ showHostPort (Host hostname port) = hostname ++ ":" ++ portname  where
     portname = case port of
         PortNumber p -> show p
 
-readHostPortM :: (Monad m) => String -> m Host
+readHostPortM :: (MonadFail m) => String -> m Host
 -- ^ Read string \"hostname:port\" as @Host hosthame (PortNumber port)@ or \"hostname\" as @host hostname@ (default port). Fail if string does not match either syntax.
 -- TODO: handle Service and UnixSocket port
 readHostPortM = either (fail . show) return . parse parser "readHostPort" where
@@ -97,7 +99,7 @@ readHostPortM = either (fail . show) return . parse parser "readHostPort" where
 
 readHostPort :: String -> Host
 -- ^ Read string \"hostname:port\" as @Host hostname (PortNumber port)@ or \"hostname\" as @host hostname@ (default port). Error if string does not match either syntax.
-readHostPort = runIdentity . readHostPortM
+readHostPort = fromJust . readHostPortM
 
 type Secs = Double
 

Database/MongoDB/GridFS.hs

@@ -26,6 +26,7 @@ module Database.MongoDB.GridFS
 import Control.Applicative((<$>))
 
 import Control.Monad(when)
+import Control.Monad.Fail(MonadFail)
 import Control.Monad.IO.Class
 import Control.Monad.Trans(lift)
 
@@ -69,7 +70,7 @@ openBucket name = do
 
 data File = File {bucket :: Bucket, document :: Document}
 
-getChunk :: (Monad m, MonadIO m) => File -> Int -> Action m (Maybe S.ByteString)
+getChunk :: (MonadFail m, MonadIO m) => File -> Int -> Action m (Maybe S.ByteString)
 -- ^ Get a chunk of a file
 getChunk (File bucket doc) i = do
   files_id <- B.look "_id" doc
@@ -98,7 +99,7 @@ fetchFile bucket sel = do
   doc <- fetch $ select sel $ files bucket
   return $ File bucket doc
 
-deleteFile :: (MonadIO m) => File -> Action m ()
+deleteFile :: (MonadIO m, MonadFail m) => File -> Action m ()
 -- ^ Delete files in the bucket
 deleteFile (File bucket doc) = do
   files_id <- B.look "_id" doc
@@ -110,7 +111,7 @@ putChunk :: (Monad m, MonadIO m) => Bucket -> ObjectId -> Int -> L.ByteString ->
 putChunk bucket files_id i chunk = do
   insert_ (chunks bucket) ["files_id" =: files_id, "n" =: i, "data" =: Binary (L.toStrict chunk)]
 
-sourceFile :: (Monad m, MonadIO m) => File -> Producer (Action m) S.ByteString
+sourceFile :: (MonadFail m, MonadIO m) => File -> Producer (Action m) S.ByteString
 -- ^ A producer for the contents of a file
 sourceFile file = yieldChunk 0 where
   yieldChunk i = do

Database/MongoDB/Query.hs

@@ -49,6 +49,7 @@ module Database.MongoDB.Query (
 import Prelude hiding (lookup)
 import Control.Exception (Exception, throwIO)
 import Control.Monad (unless, replicateM, liftM, liftM2)
+import Control.Monad.Fail(MonadFail)
 import Data.Default.Class (Default(..))
 import Data.Int (Int32, Int64)
 import Data.Either (lefts, rights)
@@ -1065,7 +1066,7 @@ defFamUpdateOpts ups = FamUpdate
 -- Returns a single updated document (new option is set to true).
 --
 -- see 'findAndModifyOpts' if you want to use findAndModify in a differnt way
-findAndModify :: MonadIO m
+findAndModify :: (MonadIO m, MonadFail m)
               => Query
               -> Document -- ^ updates
               -> Action m (Either String Document)
@@ -1080,7 +1081,7 @@ findAndModify q ups = do
 
 -- | runs the findAndModify command,
 -- allows more options than 'findAndModify'
-findAndModifyOpts :: MonadIO m
+findAndModifyOpts :: (MonadIO m, MonadFail m)
                   => Query
                   ->FindAndModifyOpts
                   -> Action m (Either String (Maybe Document))
@@ -1105,8 +1106,8 @@ findAndModifyOpts (Query {
     return $ case lookupErr result of
         Just e -> leftErr e
         Nothing -> case lookup "value" result of
-            Left err   -> leftErr $ "no document found: " `mappend` err
-            Right mdoc -> case mdoc of
+            Nothing   -> leftErr "no document found"
+            Just mdoc -> case mdoc of
                 Just doc@(_:_) -> Right (Just doc)
                 Just [] -> case famOpts of
                     FamUpdate { famUpsert = True, famNew = False } -> Right Nothing
@@ -1118,9 +1119,10 @@ findAndModifyOpts (Query {
         `mappend` "\nerror: " `mappend` err
 
     -- return Nothing means ok, Just is the error message
-    lookupErr result = case lookup "lastErrorObject" result of
-        Right errObject -> lookup "err" errObject
-        Left err -> Just err
+    lookupErr :: Document -> Maybe String
+    lookupErr result = do
+        errObject <- lookup "lastErrorObject" result
+        lookup "err" errObject
 
 explain :: (MonadIO m) => Query -> Action m Document
 -- ^ Return performance stats of query execution
@@ -1301,7 +1303,7 @@ isCursorClosed (Cursor _ _ var) = do
 type Pipeline = [Document]
 -- ^ The Aggregate Pipeline
 
-aggregate :: MonadIO m => Collection -> Pipeline -> Action m [Document]
+aggregate :: (MonadIO m, MonadFail m) => Collection -> Pipeline -> Action m [Document]
 -- ^ Runs an aggregate and unpacks the result. See <http://docs.mongodb.org/manual/core/aggregation/> for details.
 aggregate aColl agg = do
     aggregateCursor aColl agg def >>= rest
@@ -1312,7 +1314,7 @@ data AggregateConfig = AggregateConfig {}
 instance Default AggregateConfig where
   def = AggregateConfig {}
 
-aggregateCursor :: MonadIO m => Collection -> Pipeline -> AggregateConfig -> Action m Cursor
+aggregateCursor :: (MonadIO m, MonadFail m) => Collection -> Pipeline -> AggregateConfig -> Action m Cursor
 -- ^ Runs an aggregate and unpacks the result. See <http://docs.mongodb.org/manual/core/aggregation/> for details.
 aggregateCursor aColl agg _ = do
     response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg, "cursor" =: ([] :: Document)]

mongoDB.cabal

@@ -57,6 +57,7 @@ Library
                     , base16-bytestring >= 0.1.1.6
                     , base64-bytestring >= 1.0.0.1
                     , nonce >= 1.0.5
+                    , fail
 
   if flag(_old-network)
      -- "Network.BSD" is only available in network < 2.9