Add implementation which directly merge QueryJoin monads.

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

@@ -8,10 +8,13 @@ module Database.Relational.Query.Join (
   record, record', expr, compose, (>*<), (!), (!?), flatten,
   relation, relation',
 
-  query, query', queryMaybe, queryMaybe', from
+  query, query', queryMaybe, queryMaybe', from,
+
+  queryMerge, queryMergeMaybe
   ) where
 
 import Prelude hiding (product)
+import Data.Maybe (fromMaybe)
 import Control.Monad (liftM, ap)
 import Control.Applicative (Applicative (pure, (<*>)))
 
@@ -85,6 +88,15 @@ updateContext uf =
 updateProduct :: NodeAttr -> Qualified (PrimeRelation p r) -> QueryJoin ()
 updateProduct attr qrel = updateContext (updateProduct' (`growProduct` (attr, fmap Relation.toSubQuery qrel)))
 
+mergeProduct :: NodeAttr -> Maybe QueryProduct -> Maybe QueryProduct -> Maybe QueryProduct
+mergeProduct attr mpL mpR =
+  Just $
+  Product.product attr
+  (mayEmptyProduct "left"  mpL)
+  (mayEmptyProduct "right" mpR)
+  Nothing
+  where mayEmptyProduct s = fromMaybe (error $ "mergeAnother: Empty product: " ++ s)
+
 updateJoinRestriction :: Expr Bool -> QueryJoin ()
 updateJoinRestriction e = updateContext (updateProduct' d)  where
   d  Nothing  = error "addProductRestriction: product is empty!"
@@ -93,6 +105,12 @@ updateJoinRestriction e = updateContext (updateProduct' d)  where
 updateRestriction :: Expr Bool -> QueryJoin ()
 updateRestriction e = updateContext (updateRestriction' e)
 
+mergeRestriction :: Maybe (Expr Bool) -> Maybe (Expr Bool) -> Maybe (Expr Bool)
+mergeRestriction = d  where
+  d Nothing     e1        = e1
+  d e0@(Just _) Nothing   = e0
+  d (Just e0)   (Just e1) = Just $ e0 `Projectable.and` e1
+
 updateOrderBy :: Order -> Expr t -> QueryJoin ()
 updateOrderBy order e = updateContext (updateOrderBy' order e)
 
@@ -185,6 +203,26 @@ queryMaybe' =  fmap (record' . fmap Relation.toMaybe) . queryWithAttr Maybe
 from :: Table r -> QueryJoin (Projection r)
 from =  query . table
 
+unsafeMergeAnother :: NodeAttr -> QueryJoin a -> QueryJoin a
+unsafeMergeAnother attr q1 =
+  QueryJoin
+  $ \st0 -> let p0        = product st0
+                (pj, st1) = runQueryJoin q1 (st0 { product = Nothing})
+                p1        = fmap (Product.unsafeUpdateNodeAttr attr) $ product st1
+            in  (pj, st1 { product     = mergeProduct Just' p0 p1
+                         , restriction = mergeRestriction (restriction st0) (restriction st1)
+                         , orderByRev  = orderByRev st1 ++ orderByRev st0
+                         })
+
+queryMergeWithAttr :: NodeAttr -> QueryJoin (Projection r) -> QueryJoin (Projection r)
+queryMergeWithAttr =  unsafeMergeAnother
+
+queryMerge :: QueryJoin (Projection r) -> QueryJoin (Projection r)
+queryMerge =  queryMergeWithAttr Just'
+
+queryMergeMaybe :: QueryJoin (Projection a) -> QueryJoin (Projection (Maybe a))
+queryMergeMaybe =  fmap Projection.just . queryMergeWithAttr Maybe
+
 relation :: QueryJoin (Projection r) -> PrimeRelation a r
 relation q = finalizeRelation projection product' (restriction st) (orderByRev st)  where
   (projection, st) = runQueryPrime q

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

@@ -1,12 +1,12 @@
 module Database.Relational.Query.Product (
-  QueryProduct, ProductTree, growProduct, restrictProduct,
-  NodeAttr (Just', Maybe),
+  NodeAttr (Just', Maybe), unsafeUpdateNodeAttr,
+  QueryProduct, ProductTree, growProduct, product, restrictProduct,
   Product,
   tree,
   productSQL
   ) where
 
-import Prelude hiding (and)
+import Prelude hiding (and, product)
 import Database.Relational.Query.Expr (Expr, showExpr)
 import Database.Relational.Query.Projectable (valueTrue, and)
 import Database.Relational.Query.AliasId (Qualified)
@@ -31,6 +31,11 @@ joinAttr =  d  where
   d (Leaf jt _)     = jt
   d (Join jt _ _ _) = jt
 
+unsafeUpdateNodeAttr :: NodeAttr -> ProductTree q -> ProductTree q
+unsafeUpdateNodeAttr a = d  where
+  d (Leaf _ q)     = Leaf a q
+  d (Join _ l r c) = Join a l r c
+
 
 instance Foldable ProductTree where
   foldMap f pq = rec pq where
@@ -44,6 +49,9 @@ growProduct =  d  where
   d Nothing  (ja, q) = Leaf ja q
   d (Just t) (ja, q) = Join Just' t (Leaf ja q) Nothing
 
+product :: NodeAttr -> ProductTree q -> ProductTree q -> Maybe (Expr Bool) -> ProductTree q
+product =  Join
+
 restrictProduct :: ProductTree q -> Expr Bool -> ProductTree q
 restrictProduct =  d  where
   d (Join ja lp rp Nothing)   rs' = Join ja lp rp (Just rs')