Turn Action into a type synonym, not a newtype

This commit is contained in:
Michael Snoyman 2013-12-26 17:32:21 +02:00
parent ab5fcb1f78
commit 3a97c2cbdb

View file

@ -46,7 +46,7 @@ module Database.MongoDB.Query (
import Prelude hiding (lookup)
import Control.Applicative (Applicative, (<$>))
import Control.Exception (Exception, throwIO)
import Control.Monad (unless, replicateM, liftM)
import Control.Monad (unless, replicateM)
import Data.Int (Int32)
import Data.Maybe (listToMaybe, catMaybes)
import Data.Word (Word32)
@ -60,13 +60,11 @@ import Control.Concurrent.MVar.Lifted (MVar, newMVar, mkWeakMVar,
import Control.Concurrent.MVar.Lifted (MVar, newMVar, addMVarFinalizer,
readMVar, modifyMVar)
#endif
import Control.Monad.Base (MonadBase(liftBase))
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, MonadTrans, lift, liftIO)
import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl(..),
MonadTransControl(..), StM, StT,
defaultLiftBaseWith, defaultRestoreM)
import Control.Monad.Trans (MonadIO, liftIO)
import Control.Monad.Trans.Control (MonadBaseControl(..))
import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool),
Javascript, at, valueAt, lookup, look, genObjectId, (=:),
(=?))
@ -91,30 +89,12 @@ import qualified Database.MongoDB.Internal.Protocol as P
-- * Monad
newtype Action m a = Action {unAction :: ReaderT MongoContext m a}
deriving (Functor, Applicative, Monad, MonadIO)
type Action = ReaderT MongoContext
-- ^ A monad on top of m (which must be a MonadIO) that may access the database and may fail with a DB 'Failure'
instance MonadBase b m => MonadBase b (Action m) where
liftBase = Action . liftBase
instance (MonadIO m, MonadBaseControl b m) => MonadBaseControl b (Action m) where
newtype StM (Action m) a = StMT {unStMT :: ComposeSt Action m a}
liftBaseWith = defaultLiftBaseWith StMT
restoreM = defaultRestoreM unStMT
instance MonadTrans Action where
lift = Action . lift
instance MonadTransControl Action where
newtype StT Action a = StActionT {unStAction :: StT (ReaderT MongoContext) a}
liftWith f = Action $ liftWith $ \runReader' ->
f (liftM StActionT . runReader' . unAction)
restoreT = Action . restoreT . liftM unStAction
access :: (MonadIO m) => Pipe -> AccessMode -> Database -> Action m a -> m a
-- ^ Run action against database on server at other end of pipe. Use access mode for any reads and writes. Return Left on connection failure or read/write failure.
access myPipe myAccessMode myDatabase (Action action) = runReaderT action MongoContext{..}
access myPipe myAccessMode myDatabase action = runReaderT action MongoContext{..}
-- | A connection failure, or a read or write exception like cursor expired or inserting a duplicate key.
-- Note, unexpected data from the server is not a Failure, rather it is a programming error (you should call 'error' in this case) because the client and server are incompatible and requires a programming change.
@ -154,7 +134,7 @@ slaveOk = ReadStaleOk
accessMode :: (Monad m) => AccessMode -> Action m a -> Action m a
-- ^ Run action with given 'AccessMode'
accessMode mode (Action act) = Action $ local (\ctx -> ctx {myAccessMode = mode}) act
accessMode mode act = local (\ctx -> ctx {myAccessMode = mode}) act
readMode :: AccessMode -> ReadMode
readMode ReadStaleOk = StaleOk
@ -179,13 +159,13 @@ myWriteMode = writeMode . myAccessMode
send :: (MonadIO m) => [Notice] -> Action m ()
-- ^ Send notices as a contiguous batch to server with no reply. Throw 'ConnectionFailure' if pipe fails.
send ns = Action $ do
send ns = do
pipe <- asks myPipe
liftIOE ConnectionFailure $ P.send pipe ns
call :: (MonadIO m) => [Notice] -> Request -> Action m (IO Reply)
-- ^ Send notices and request as a contiguous batch to server and return reply promise, which will block when invoked until reply arrives. This call will throw 'ConnectionFailure' if pipe fails on send, and promise will throw 'ConnectionFailure' if pipe fails on receive.
call ns r = Action $ do
call ns r = do
pipe <- asks myPipe
promise <- liftIOE ConnectionFailure $ P.call pipe ns r
return (liftIOE ConnectionFailure promise)
@ -198,7 +178,7 @@ instance HasMongoContext MongoContext where
liftDB :: (MonadReader env m, HasMongoContext env, MonadIO m)
=> Action IO a
-> m a
liftDB (Action m) = do
liftDB m = do
env <- ask
liftIO $ runReaderT m (mongoContext env)
@ -212,11 +192,11 @@ allDatabases = map (at "name") . at "databases" <$> useDb "admin" (runCommand1 "
thisDatabase :: (Monad m) => Action m Database
-- ^ Current database in use
thisDatabase = Action $ asks myDatabase
thisDatabase = asks myDatabase
useDb :: (Monad m) => Database -> Action m a -> Action m a
-- ^ Run action against given database
useDb db (Action act) = Action $ local (\ctx -> ctx {myDatabase = db}) act
useDb db act = local (\ctx -> ctx {myDatabase = db}) act
-- * Authentication
@ -272,7 +252,7 @@ data WriteMode =
write :: (MonadIO m) => Notice -> Action m ()
-- ^ Send write to server, and if write-mode is 'Safe' then include getLastError request and raise 'WriteFailure' if it reports an error.
write notice = Action (asks myWriteMode) >>= \mode -> case mode of
write notice = asks myWriteMode >>= \mode -> case mode of
NoConfirm -> send [notice]
Confirm params -> do
let q = query (("getlasterror" =: (1 :: Int)) : params) "$cmd"
@ -483,7 +463,7 @@ distinct k (Select sel col) = at "values" <$> runCommand ["distinct" =: col, "ke
queryRequest :: (Monad m) => Bool -> Query -> Action m (Request, Limit)
-- ^ Translate Query to Protocol.Query. If first arg is true then add special $explain attribute.
queryRequest isExplain Query{..} = do
ctx <- Action ask
ctx <- ask
return $ queryRequest' (myReadMode ctx) (myDatabase ctx)
where
queryRequest' rm db = (P.Query{..}, remainingLimit) where
@ -535,7 +515,7 @@ fromReply limit Reply{..} = do
fulfill :: (MonadIO m) => DelayedBatch -> Action m Batch
-- ^ Demand and wait for result, raise failure if exception
fulfill = Action . liftIO
fulfill = liftIO
-- *** Cursor