Connect qualify monad for nested query monad case.

relational-join/relational-join.cabal

@@ -52,6 +52,7 @@ library
                        Database.Relational.Query.Internal.Product
                        Database.Relational.Query.Internal.Context
                        Database.Relational.Query.Internal.AggregatingContext
+                       Database.Relational.Query.Monad.Qualify
                        Database.Relational.Query.Monad.Unsafe
 
                        Database.Relational.Schema.DB2Syscat.Tabconst

relational-join/src/Database/Relational/Query/Internal/Context.hs

@@ -1,6 +1,10 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Database.Relational.Query.Internal.Context (
+  AliasIdContext,
+
+  primeAliasIdContext,
+
   Context,
 
   primeContext,
@@ -43,16 +47,20 @@ import qualified Language.SQL.Keyword as SQL
 
 -- Base contexts
 
+newtype AliasIdContext = AliasIdContext { currentAliasId :: AliasId }
+
+primeAliasIdContext :: AliasIdContext
+primeAliasIdContext =  AliasIdContext primAlias
+
 data Context = Context
-               { currentAliasId :: AliasId
-               , product :: Maybe QueryProductNode
+               { product :: Maybe QueryProductNode
                , restriction :: Maybe (Expr Bool)
                }
 
 primeContext :: Context
-primeContext =  Context primAlias Nothing Nothing
+primeContext =  Context Nothing Nothing
 
-nextAlias :: Context -> (AliasId, Context)
+nextAlias :: AliasIdContext -> (AliasId, AliasIdContext)
 nextAlias s = (cur, s { currentAliasId =  newAliasId cur })  where
   cur = currentAliasId s
 

relational-join/src/Database/Relational/Query/Monad/Aggregate.hs

@@ -28,6 +28,7 @@ import Database.Relational.Query.Sub (SubQuery, subQuery)
 import Database.Relational.Query.Internal.AggregatingContext (AggregatingContext, primeAggregatingContext)
 import qualified Database.Relational.Query.Internal.AggregatingContext as Context
 
+import Database.Relational.Query.Monad.Qualify (Qualify)
 import Database.Relational.Query.Monad.Unsafe (UnsafeMonadQuery(unsafeSubQuery))
 import Database.Relational.Query.Monad.Class (MonadQuery, MonadAggregate)
 import qualified Database.Relational.Query.Monad.Class as MonadQuery
@@ -103,14 +104,16 @@ appendGroupBys q = second appendGroupBys' `liftM` runAggregatingPrime q
 type QueryAggregate    = Orderings Aggregation (Aggregatings QueryCore)
 type AggregatedQuery r = OrderedQuery Aggregation (Aggregatings QueryCore) r
 
-expandSQL :: AggregatedQuery r -> ((String, Projection r), (String -> String, String -> String))
+expandSQL :: QueryAggregate (Aggregation r) -> Qualify ((String, Projection r), (String -> String, String -> String))
 expandSQL q = Core.expandSQL $ assoc <$> appendGroupBys (Ordering.appendOrderBys q)  where
   assoc ((a, b), c) = (Aggregation.projection a, (b, c))
 
-toSQL :: AggregatedQuery r -> String
-toSQL q =  appOrd $ appGrp sql  where
-  ((sql, _pj), (appOrd, appGrp)) = expandSQL q
+toSQL :: QueryAggregate (Aggregation r) -> Qualify String
+toSQL q = do
+  ((sql, _pj), (appOrd, appGrp)) <- expandSQL q
+  return . appOrd $ appGrp sql
 
-toSubQuery :: AggregatedQuery r -> SubQuery
-toSubQuery q = subQuery (appOrd $ appGrp sql) (Projection.width pj)  where
-  ((sql, pj), (appOrd, appGrp))  = expandSQL q
+toSubQuery :: QueryAggregate (Aggregation r) -> Qualify SubQuery
+toSubQuery q = do
+  ((sql, pj), (appOrd, appGrp)) <- expandSQL q
+  return $ subQuery (appOrd $ appGrp sql) (Projection.width pj)

relational-join/src/Database/Relational/Query/Monad/Core.hs

@@ -1,32 +1,32 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
 
 module Database.Relational.Query.Monad.Core (
+  QueryJoin, join',
+
   QueryCore,
 
   expr,
 
   unsafeSubQueryWithAttr,
-  unsafeQueryMergeWithAttr,
+  -- unsafeQueryMergeWithAttr,
 
   expandSQL
   ) where
 
 import Prelude hiding (product)
 import Control.Monad (liftM, ap)
-import Control.Monad.Trans.State (State, state, runState, modify)
+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, nextAlias, updateProduct, composeSQL)
+  (Context, primeContext, updateProduct, composeSQL)
 import qualified Database.Relational.Query.Internal.Context as Context
 
-import Database.Relational.Query.Internal.AliasId (AliasId, Qualified)
-import qualified Database.Relational.Query.Internal.AliasId as AliasId
-
 import Database.Relational.Query.Expr (Expr, fromTriBool)
 
 import Database.Relational.Query.Internal.Product
-  (NodeAttr, QueryProductNode, growProduct, restrictProduct)
+  (NodeAttr, growProduct, restrictProduct)
 
 import Database.Relational.Query.Projection (Projection)
 import qualified Database.Relational.Query.Projection as Projection
@@ -34,90 +34,90 @@ import Database.Relational.Query.Projectable (Projectable(project))
 
 import Database.Relational.Query.Sub (SubQuery)
 
+import Database.Relational.Query.Monad.Qualify (Qualify, evalQualifyPrime, qualifyQuery)
 import Database.Relational.Query.Monad.Class (MonadQuery(on, wheres))
-import Database.Relational.Query.Monad.Unsafe
-  (UnsafeMonadQuery(unsafeSubQuery))
-
-newtype QueryCore a =
-  QueryCore { queryState :: State Context a }
-
-runQueryCore :: QueryCore a -> Context -> (a, Context)
-runQueryCore =  runState . queryState
-
-queryCore :: (Context -> (a, Context)) -> QueryCore a
-queryCore =  QueryCore . state
-
-runQueryPrime :: QueryCore a -> (a, Context)
-runQueryPrime q = runQueryCore q primeContext
-
-newAlias :: QueryCore AliasId
-newAlias =  queryCore nextAlias
-
-updateContext :: (Context -> Context) -> QueryCore ()
-updateContext =  QueryCore . modify
+import Database.Relational.Query.Monad.Unsafe (UnsafeMonadQuery(unsafeSubQuery))
 
 
-updateJoinRestriction :: Expr (Maybe Bool) -> QueryCore ()
+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 :: Expr (Maybe Bool) -> QueryCore ()
+updateRestriction :: Monad m => Expr (Maybe Bool) -> QueryJoin m ()
 updateRestriction e = updateContext (Context.addRestriction e)
 
-takeProduct :: QueryCore (Maybe QueryProductNode)
-takeProduct =  queryCore Context.takeProduct
+-- takeProduct :: QueryJoin (Maybe QueryProductNode)
+-- takeProduct =  queryCore Context.takeProduct
 
-restoreLeft :: QueryProductNode -> NodeAttr -> QueryCore ()
-restoreLeft pL naR = updateContext $ Context.restoreLeft pL naR
+-- restoreLeft :: QueryProductNode -> NodeAttr -> QueryJoin ()
+-- restoreLeft pL naR = updateContext $ Context.restoreLeft pL naR
 
 expr :: Projection ft -> Expr ft
 expr =  project
 
 
-instance Monad QueryCore where
-  return      = QueryCore . return
-  q0 >>= f    = QueryCore $ queryState q0 >>= queryState . f
+instance Monad m => Monad (QueryJoin m) where
+  return      = QueryJoin . return
+  q0 >>= f    = QueryJoin $ queryState q0 >>= queryState . f
 
-instance Functor QueryCore where
+instance Monad m => Functor (QueryJoin m) where
   fmap = liftM
 
-instance Applicative QueryCore where
+instance Monad m => Applicative (QueryJoin m) where
   pure  = return
   (<*>) = ap
 
-instance MonadQuery QueryCore where
+instance MonadQuery (QueryJoin Qualify) where
   on     =  updateJoinRestriction
   wheres =  updateRestriction
 
-qualify :: rel -> QueryCore (Qualified rel)
-qualify rel =
-  do n <- newAlias
-     return $ AliasId.qualify rel n
+type QueryCore = QueryJoin Qualify
 
-unsafeSubQueryWithAttr :: NodeAttr -> SubQuery -> QueryCore (Projection t)
-unsafeSubQueryWithAttr attr sub = do
-  qsub <- qualify sub
+unsafeSubQueryWithAttr ::  NodeAttr -> Qualify SubQuery -> QueryJoin Qualify (Projection t)
+unsafeSubQueryWithAttr attr qualSub = do
+  qsub <- join' (qualSub >>= qualifyQuery)
   updateContext (updateProduct (`growProduct` (attr, qsub)))
   return $ Projection.fromQualifiedSubQuery qsub
 
-unsafeMergeAnother :: NodeAttr -> QueryCore a -> QueryCore a
-unsafeMergeAnother naR qR = do
-  mayPL <- takeProduct
-  v     <- qR
-  maybe (return ()) (\pL -> restoreLeft pL naR) mayPL
-  return v
+-- unsafeMergeAnother :: NodeAttr -> QueryJoin a -> QueryJoin a
+-- unsafeMergeAnother naR qR = do
+--   mayPL <- takeProduct
+--   v     <- qR
+--   maybe (return ()) (\pL -> restoreLeft pL naR) mayPL
+--   return v
 
-unsafeQueryMergeWithAttr :: NodeAttr -> QueryCore (Projection r) -> QueryCore (Projection r)
-unsafeQueryMergeWithAttr =  unsafeMergeAnother
+-- unsafeQueryMergeWithAttr :: NodeAttr -> QueryJoin (Projection r) -> QueryJoin (Projection r)
+-- unsafeQueryMergeWithAttr =  unsafeMergeAnother
 
-instance UnsafeMonadQuery QueryCore where
+instance UnsafeMonadQuery (QueryJoin Qualify) where
   unsafeSubQuery          = unsafeSubQueryWithAttr
   -- unsafeMergeAnotherQuery = unsafeQueryMergeWithAttr
 
-expandSQL :: QueryCore (Projection r, st) -> ((String, Projection r), st)
-expandSQL qp = ((composeSQL pj c, pj), st)  where
-  ((pj, st), c) = runQueryPrime qp
+expandSQL :: Monad m => QueryJoin m (Projection r, t) -> m ((String, Projection r), t)
+expandSQL qp = do
+  ((pj, st), c) <- runQueryPrime qp
+  return ((composeSQL pj c, pj), st)
 
-instance Show (QueryCore (Projection r)) where
-  show = fst . fst . expandSQL . fmap (\x -> (,) x ())
+instance Show (QueryJoin Qualify (Projection r)) where
+  show = fst . fst . doExpand
+    where doExpand = evalQualifyPrime . expandSQL . fmap (\x -> (,) x ())

relational-join/src/Database/Relational/Query/Monad/Qualify.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module Database.Relational.Query.Monad.Qualify (
+  Qualify, evalQualifyPrime, newAlias, qualifyQuery
+  ) where
+
+import Control.Monad (liftM, ap)
+import Control.Monad.Trans.State
+  (State, state, runState)
+import Control.Applicative (Applicative (pure, (<*>)))
+
+import Database.Relational.Query.Internal.AliasId (AliasId, Qualified)
+import qualified Database.Relational.Query.Internal.AliasId as AliasId
+import Database.Relational.Query.Internal.Context
+  (AliasIdContext, primeAliasIdContext, nextAlias)
+
+
+newtype Qualify a =
+  Qualify { runQualify' :: State AliasIdContext a }
+
+runQualify :: Qualify a -> AliasIdContext -> (a, AliasIdContext)
+runQualify =  runState . runQualify'
+
+runQualifyPrime :: Qualify a -> (a, AliasIdContext)
+runQualifyPrime q = runQualify q primeAliasIdContext
+
+evalQualifyPrime :: Qualify a -> a
+evalQualifyPrime =  fst . runQualifyPrime
+
+qualifyState :: (AliasIdContext -> (a, AliasIdContext)) -> Qualify a
+qualifyState =  Qualify . state
+
+instance Monad Qualify where
+  return      = Qualify . return
+  q0 >>= f    = Qualify $ runQualify' q0 >>= runQualify' . f
+
+instance Functor Qualify where
+  fmap = liftM
+
+instance Applicative Qualify where
+  pure  = return
+  (<*>) = ap
+
+newAlias :: Qualify AliasId
+newAlias =  qualifyState nextAlias
+
+qualifyQuery :: query -> Qualify (Qualified query)
+qualifyQuery query =
+  do n <- newAlias
+     return $ AliasId.qualify query n
+
+-- qualifyQuery :: Qualify query -> Qualify (Qualified query)
+-- qualifyQuery qualSub = do
+--   sub  <- qualSub
+--   qualifyQuery' sub

relational-join/src/Database/Relational/Query/Monad/Simple.hs

@@ -11,11 +11,10 @@ module Database.Relational.Query.Monad.Simple (
   toSubQuery
   ) where
 
--- import Database.Relational.Query.Internal.Product (NodeAttr)
-
 import Database.Relational.Query.Projection (Projection)
 import qualified Database.Relational.Query.Projection as Projection
 
+import Database.Relational.Query.Monad.Qualify (Qualify)
 import Database.Relational.Query.Monad.Ordering (Orderings, orderings, OrderedQuery)
 import qualified Database.Relational.Query.Monad.Ordering as Ordering
 import Database.Relational.Query.Monad.Core (QueryCore)
@@ -33,13 +32,15 @@ simple =  orderings
 -- unsafeMergeAnotherOrderBys :: NodeAttr -> QuerySimple (Projection r) -> QuerySimple (Projection r)
 -- unsafeMergeAnotherOrderBys =  Ordering.unsafeMergeAnotherOrderBys
 
-expandSQL :: SimpleQuery r -> ((String, Projection r), String -> String)
+expandSQL :: SimpleQuery r -> Qualify ((String, Projection r), String -> String)
 expandSQL =  Core.expandSQL . Ordering.appendOrderBys
 
-toSQL :: SimpleQuery r -> String
-toSQL q = append sql  where
-  ((sql, _), append)  = expandSQL q
+toSQL :: SimpleQuery r -> Qualify String
+toSQL q = do
+  ((sql, _), append) <- expandSQL q
+  return $ append sql  where
 
-toSubQuery :: SimpleQuery r -> SubQuery
-toSubQuery q = subQuery (append sql) (Projection.width pj)  where
-  ((sql, pj), append) = expandSQL q
+toSubQuery :: SimpleQuery r -> Qualify SubQuery
+toSubQuery q = do
+  ((sql, pj), append) <- expandSQL q
+  return $ subQuery (append sql) (Projection.width pj)

relational-join/src/Database/Relational/Query/Monad/Unsafe.hs

@@ -1,4 +1,3 @@
-
 module Database.Relational.Query.Monad.Unsafe (
   UnsafeMonadQuery (..)
   ) where
@@ -6,7 +5,8 @@ module Database.Relational.Query.Monad.Unsafe (
 import Database.Relational.Query.Internal.Product (NodeAttr)
 import Database.Relational.Query.Projection (Projection)
 import Database.Relational.Query.Sub (SubQuery)
+import Database.Relational.Query.Monad.Qualify (Qualify)
 
 class (Functor m, Monad m) => UnsafeMonadQuery m where
-  unsafeSubQuery          :: NodeAttr -> SubQuery -> m (Projection t)
+  unsafeSubQuery          :: NodeAttr -> Qualify SubQuery -> m (Projection r)
   -- unsafeMergeAnotherQuery :: NodeAttr -> m (Projection r) -> m (Projection r)

relational-join/src/Database/Relational/Query/Relation.hs

@@ -14,11 +14,12 @@ module Database.Relational.Query.Relation (
 
   sqlFromRelation,
 
-  subQueryFromRelation,
+  -- subQueryFromRelation,
 
   nested, width
   ) where
 
+import Database.Relational.Query.Monad.Qualify (Qualify, evalQualifyPrime)
 import Database.Relational.Query.Monad.Class (MonadQuery (on))
 import qualified Database.Relational.Query.Monad.Unsafe as UnsafeMonadQuery
 import Database.Relational.Query.Monad.Simple (QuerySimple, SimpleQuery)
@@ -57,15 +58,19 @@ from :: Table r -> Relation r
 from =  table
 
 
-subQueryFromRelation :: PrimeRelation p r -> SubQuery
-subQueryFromRelation =  d  where
-  d (SubQuery sub)    = sub
+subQueryQualifyFromRelation :: PrimeRelation p r -> Qualify SubQuery
+subQueryQualifyFromRelation =  d  where
+  d (SubQuery sub)    = return $ sub
   d (SimpleRel qp)    = Simple.toSubQuery qp
   d (AggregateRel qp) = Aggregate.toSubQuery qp
 
-queryWithAttr :: MonadQuery m => NodeAttr -> PrimeRelation p r -> m (PlaceHolders p, Projection r)
+subQueryFromRelation :: PrimeRelation p r -> SubQuery
+subQueryFromRelation =  evalQualifyPrime . subQueryQualifyFromRelation
+
+queryWithAttr :: MonadQuery m
+              => NodeAttr -> PrimeRelation p r -> m (PlaceHolders p, Projection r)
 queryWithAttr attr = addPlaceHolders . q where
-  q = UnsafeMonadQuery.unsafeSubQuery attr . subQueryFromRelation
+  q = UnsafeMonadQuery.unsafeSubQuery attr . subQueryQualifyFromRelation
   -- d (PrimeRelation q) = UnsafeMonadQuery.unsafeMergeAnotherQuery attr q
 
 query' :: MonadQuery m => PrimeRelation p r -> m (PlaceHolders p, Projection r)
@@ -182,12 +187,15 @@ on' =  ($)
 infixl 8 `inner'`, `left'`, `right'`, `full'`, `inner`, `left`, `right`, `full`, `on'`
 
 
-sqlFromRelation :: PrimeRelation p r -> String
-sqlFromRelation =  d  where
-  d (SubQuery sub)    = SubQuery.toSQL sub
+sqlQualifyFromRelation :: PrimeRelation p r -> Qualify String
+sqlQualifyFromRelation =  d  where
+  d (SubQuery sub)    = return $ SubQuery.toSQL sub
   d (SimpleRel qp)    = Simple.toSQL qp
   d (AggregateRel qp) = Aggregate.toSQL qp
 
+sqlFromRelation :: PrimeRelation p r -> String
+sqlFromRelation =  evalQualifyPrime . sqlQualifyFromRelation
+
 instance Show (PrimeRelation p r) where
   show = sqlFromRelation