HasMongoContext instead of liftDB

This commit is contained in:
Michael Snoyman 2013-12-26 17:28:44 +02:00
parent bd3d90f740
commit ab5fcb1f78

View file

@ -6,7 +6,8 @@ module Database.MongoDB.Query (
-- * Monad -- * Monad
Action, access, Failure(..), ErrorCode, Action, access, Failure(..), ErrorCode,
AccessMode(..), GetLastError, master, slaveOk, accessMode, AccessMode(..), GetLastError, master, slaveOk, accessMode,
MonadDB(..), liftDB,
MongoContext, HasMongoContext(..),
-- * Database -- * Database
Database, allDatabases, useDb, thisDatabase, Database, allDatabases, useDb, thisDatabase,
-- ** Authentication -- ** Authentication
@ -60,15 +61,12 @@ import Control.Concurrent.MVar.Lifted (MVar, newMVar, addMVarFinalizer,
readMVar, modifyMVar) readMVar, modifyMVar)
#endif #endif
import Control.Monad.Base (MonadBase(liftBase)) import Control.Monad.Base (MonadBase(liftBase))
import Control.Monad.Error (ErrorT, Error(..)) import Control.Monad.Error (Error(..))
import Control.Monad.Reader (ReaderT, runReaderT, ask, asks, local) import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask, asks, local)
import Control.Monad.RWS (RWST)
import Control.Monad.State (StateT)
import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO) import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO)
import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl(..), import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl(..),
MonadTransControl(..), StM, StT, MonadTransControl(..), StM, StT,
defaultLiftBaseWith, defaultRestoreM) defaultLiftBaseWith, defaultRestoreM)
import Control.Monad.Writer (WriterT, Monoid)
import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool), import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool),
Javascript, at, valueAt, lookup, look, genObjectId, (=:), Javascript, at, valueAt, lookup, look, genObjectId, (=:),
(=?)) (=?))
@ -192,30 +190,17 @@ call ns r = Action $ do
promise <- liftIOE ConnectionFailure $ P.call pipe ns r promise <- liftIOE ConnectionFailure $ P.call pipe ns r
return (liftIOE ConnectionFailure promise) 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 HasMongoContext env where
class (Monad m, MonadBaseControl IO (BaseMonad m), Applicative (BaseMonad m), Functor (BaseMonad m)) => MonadDB m where mongoContext :: env -> MongoContext
type BaseMonad m :: * -> * instance HasMongoContext MongoContext where
liftDB :: Action (BaseMonad m) a -> m a mongoContext = id
instance (MonadBaseControl IO m, Applicative m, Functor m) => MonadDB (Action m) where liftDB :: (MonadReader env m, HasMongoContext env, MonadIO m)
type BaseMonad (Action m) = m => Action IO a
liftDB = id -> m a
liftDB (Action m) = do
instance (MonadDB m, Error e) => MonadDB (ErrorT e m) where env <- ask
type BaseMonad (ErrorT e m) = BaseMonad m liftIO $ runReaderT m (mongoContext env)
liftDB = lift . liftDB
instance (MonadDB m) => MonadDB (ReaderT r m) where
type BaseMonad (ReaderT r m) = BaseMonad m
liftDB = lift . liftDB
instance (MonadDB m) => MonadDB (StateT s m) where
type BaseMonad (StateT s m) = BaseMonad m
liftDB = lift . liftDB
instance (MonadDB m, Monoid w) => MonadDB (WriterT w m) where
type BaseMonad (WriterT w m) = BaseMonad m
liftDB = lift . liftDB
instance (MonadDB m, Monoid w) => MonadDB (RWST r w s m) where
type BaseMonad (RWST r w s m) = BaseMonad m
liftDB = lift . liftDB
-- * Database -- * Database