HasMongoContext instead of liftDB
This commit is contained in:
parent
bd3d90f740
commit
ab5fcb1f78
1 changed files with 14 additions and 29 deletions
|
@ -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
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue