Use MonadFail instead of Monad

This commit is contained in:
Victor Denisov 2019-12-31 12:28:52 -08:00
commit e2e8288b32
5 changed files with 22 additions and 15 deletions

View file

@ -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

View file

@ -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_, guard)
import Control.Monad.Fail(MonadFail)
import System.IO.Unsafe (unsafePerformIO)
import System.Timeout (timeout)
import Text.ParserCombinators.Parsec (parse, many1, letter, digit, char, anyChar, eof,
@ -82,7 +84,7 @@ showHostPort (Host hostname (PortNumber port)) = hostname ++ ":" ++ show port
showHostPort (Host _ (UnixSocket path)) = "unix:" ++ path
#endif
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 port
readHostPortM = either (fail . show) return . parse parser "readHostPort" where
@ -104,7 +106,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

View file

@ -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

View file

@ -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)]

View file

@ -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