From f01ba3ef8ae5e92b3a78c434c1bf3115f5308a2b Mon Sep 17 00:00:00 2001 From: Kei Hibino Date: Wed, 5 Jun 2013 17:32:44 +0900 Subject: [PATCH] Divide Core into moand transformer and concrete monad type. --- relational-join/relational-join.cabal | 3 +- .../Database/Relational/Query/Monad/Core.hs | 63 ++--------------- .../Relational/Query/Monad/Trans/Join.hs | 67 +++++++++++++++++++ 3 files changed, 74 insertions(+), 59 deletions(-) create mode 100644 relational-join/src/Database/Relational/Query/Monad/Trans/Join.hs diff --git a/relational-join/relational-join.cabal b/relational-join/relational-join.cabal index e36771c8..a2260000 100644 --- a/relational-join/relational-join.cabal +++ b/relational-join/relational-join.cabal @@ -31,9 +31,9 @@ library Database.Relational.Query.Sub Database.Relational.Query.Monad.Class Database.Relational.Query.Monad.Trans.Ordering + Database.Relational.Query.Monad.Trans.Aggregate Database.Relational.Query.Monad.Core Database.Relational.Query.Monad.Simple - Database.Relational.Query.Monad.Trans.Aggregate Database.Relational.Query.Monad.Aggregate Database.Relational.Query.Relation Database.Relational.Query.Type @@ -54,6 +54,7 @@ library Database.Relational.Query.Internal.Context Database.Relational.Query.Internal.AggregatingContext Database.Relational.Query.Monad.Qualify + Database.Relational.Query.Monad.Trans.Join Database.Relational.Schema.DB2Syscat.Tabconst Database.Relational.Schema.DB2Syscat.Keycoluse diff --git a/relational-join/src/Database/Relational/Query/Monad/Core.hs b/relational-join/src/Database/Relational/Query/Monad/Core.hs index 266a797c..8e2fa89a 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Core.hs +++ b/relational-join/src/Database/Relational/Query/Monad/Core.hs @@ -1,8 +1,6 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} module Database.Relational.Query.Monad.Core ( - QueryJoin, join', - QueryCore, expr, @@ -14,19 +12,11 @@ module Database.Relational.Query.Monad.Core ( ) where import Prelude hiding (product) -import Control.Monad (liftM, ap) -import Control.Monad.Trans.Class (MonadTrans (lift)) -import Control.Monad.Trans.State (modify, StateT, runStateT) -import Control.Applicative (Applicative (pure, (<*>))) -import Database.Relational.Query.Internal.Context - (Context, primeContext, updateProduct, composeSQL) -import qualified Database.Relational.Query.Internal.Context as Context +import Database.Relational.Query.Internal.Context (updateProduct, composeSQL) +import Database.Relational.Query.Internal.Product (NodeAttr, growProduct) -import Database.Relational.Query.Expr (Expr, fromTriBool) - -import Database.Relational.Query.Internal.Product - (NodeAttr, growProduct, restrictProduct) +import Database.Relational.Query.Expr (Expr) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection @@ -36,56 +26,13 @@ import Database.Relational.Query.Sub (SubQuery) import Database.Relational.Query.Monad.Qualify (Qualify, evalQualifyPrime, qualifyQuery) import Database.Relational.Query.Monad.Class (MonadQuery(on, wheres, unsafeSubQuery)) +import Database.Relational.Query.Monad.Trans.Join + (QueryJoin, join', runQueryPrime, updateContext, updateJoinRestriction, updateRestriction) -newtype QueryJoin m a = - QueryJoin { queryState :: StateT Context m a } - -runQueryJoin :: QueryJoin m a -> Context -> m (a, Context) -runQueryJoin = runStateT . queryState - -runQueryPrime :: QueryJoin m a -> m (a, Context) -runQueryPrime q = runQueryJoin q primeContext - -instance MonadTrans QueryJoin where - lift = QueryJoin . lift - -join' :: Monad m => m a -> QueryJoin m a -join' = lift - -updateContext :: Monad m => (Context -> Context) -> QueryJoin m () -updateContext = QueryJoin . modify - - -updateJoinRestriction :: Monad m => Expr (Maybe Bool) -> QueryJoin m () -updateJoinRestriction e = updateContext (updateProduct d) where - d Nothing = error "on: product is empty!" - d (Just pt) = restrictProduct pt (fromTriBool e) - -updateRestriction :: Monad m => Expr (Maybe Bool) -> QueryJoin m () -updateRestriction e = updateContext (Context.addRestriction e) - --- takeProduct :: QueryJoin (Maybe QueryProductNode) --- takeProduct = queryCore Context.takeProduct - --- restoreLeft :: QueryProductNode -> NodeAttr -> QueryJoin () --- restoreLeft pL naR = updateContext $ Context.restoreLeft pL naR - expr :: Projection ft -> Expr ft expr = project - -instance Monad m => Monad (QueryJoin m) where - return = QueryJoin . return - q0 >>= f = QueryJoin $ queryState q0 >>= queryState . f - -instance Monad m => Functor (QueryJoin m) where - fmap = liftM - -instance Monad m => Applicative (QueryJoin m) where - pure = return - (<*>) = ap - instance MonadQuery (QueryJoin Qualify) where on = updateJoinRestriction wheres = updateRestriction diff --git a/relational-join/src/Database/Relational/Query/Monad/Trans/Join.hs b/relational-join/src/Database/Relational/Query/Monad/Trans/Join.hs new file mode 100644 index 00000000..b73b3e33 --- /dev/null +++ b/relational-join/src/Database/Relational/Query/Monad/Trans/Join.hs @@ -0,0 +1,67 @@ +module Database.Relational.Query.Monad.Trans.Join ( + QueryJoin, join', + + runQueryPrime, + updateContext, + + updateJoinRestriction, updateRestriction + ) where + +import Prelude hiding (product) +import Control.Monad (liftM, ap) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.State (modify, StateT, runStateT) +import Control.Applicative (Applicative (pure, (<*>))) + +import Database.Relational.Query.Internal.Context + (Context, primeContext, updateProduct) +import qualified Database.Relational.Query.Internal.Context as Context + +import Database.Relational.Query.Expr (Expr, fromTriBool) + +import Database.Relational.Query.Internal.Product (restrictProduct) + + +newtype QueryJoin m a = + QueryJoin { queryState :: StateT Context m a } + +runQueryJoin :: QueryJoin m a -> Context -> m (a, Context) +runQueryJoin = runStateT . queryState + +runQueryPrime :: QueryJoin m a -> m (a, Context) +runQueryPrime q = runQueryJoin q primeContext + +instance MonadTrans QueryJoin where + lift = QueryJoin . lift + +join' :: Monad m => m a -> QueryJoin m a +join' = lift + +updateContext :: Monad m => (Context -> Context) -> QueryJoin m () +updateContext = QueryJoin . modify + + +updateJoinRestriction :: Monad m => Expr (Maybe Bool) -> QueryJoin m () +updateJoinRestriction e = updateContext (updateProduct d) where + d Nothing = error "on: product is empty!" + d (Just pt) = restrictProduct pt (fromTriBool e) + +updateRestriction :: Monad m => Expr (Maybe Bool) -> QueryJoin m () +updateRestriction e = updateContext (Context.addRestriction e) + +-- takeProduct :: QueryJoin (Maybe QueryProductNode) +-- takeProduct = queryCore Context.takeProduct + +-- restoreLeft :: QueryProductNode -> NodeAttr -> QueryJoin () +-- restoreLeft pL naR = updateContext $ Context.restoreLeft pL naR + +instance Monad m => Monad (QueryJoin m) where + return = QueryJoin . return + q0 >>= f = QueryJoin $ queryState q0 >>= queryState . f + +instance Monad m => Functor (QueryJoin m) where + fmap = liftM + +instance Monad m => Applicative (QueryJoin m) where + pure = return + (<*>) = ap