Divide Core into moand transformer and concrete monad type.

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

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

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