re-generalize product-tree to deal with builder and finalized list.

relational-query/src/Database/Relational/Query/Internal/Product.hs

@@ -18,34 +18,36 @@ import Control.Applicative (pure, empty)
 import Data.Monoid ((<>))
 
 import Database.Relational.Query.Context (Flat)
-import Database.Relational.Query.Internal.Sub (NodeAttr (..), ProductTree (..), Node (..), Projection, Qualified, SubQuery)
+import Database.Relational.Query.Internal.Sub
+  (NodeAttr (..), ProductTree (..), Node (..), Projection, Qualified, SubQuery,
+   ProductTreeBuilder, ProductBuilder)
 
 
 -- | Push new tree into product right term.
-growRight :: Maybe Node              -- ^ Current tree
-          -> (NodeAttr, ProductTree) -- ^ New tree to push into right
-          -> Node                    -- ^ Result node
+growRight :: Maybe ProductBuilder           -- ^ Current tree
+          -> (NodeAttr, ProductTreeBuilder) -- ^ New tree to push into right
+          -> ProductBuilder                 -- ^ Result node
 growRight = d  where
   d Nothing  (naR, q) = Node naR q
   d (Just l) (naR, q) = Node Just' $ Join l (Node naR q) empty
 
 -- | Push new leaf node into product right term.
-growProduct :: Maybe Node                     -- ^ Current tree
+growProduct :: Maybe ProductBuilder           -- ^ Current tree
             -> (NodeAttr, Qualified SubQuery) -- ^ New leaf to push into right
-            -> Node                           -- ^ Result node
+            -> ProductBuilder                 -- ^ Result node
 growProduct =  match  where
   match t (na, q) =  growRight t (na, Leaf q)
 
 -- | Add restriction into top product of product tree.
-restrictProduct' :: ProductTree                  -- ^ Product to restrict
+restrictProduct' :: ProductTreeBuilder           -- ^ Product to restrict
                  -> Projection Flat (Maybe Bool) -- ^ Restriction to add
-                 -> ProductTree                  -- ^ Result product
+                 -> ProductTreeBuilder           -- ^ Result product
 restrictProduct' =  d  where
   d (Join lp rp rs) rs' = Join lp rp (rs <> pure rs')
   d leaf'@(Leaf _)         _   = leaf' -- or error on compile
 
 -- | Add restriction into top product of product tree node.
-restrictProduct :: Node                         -- ^ Target node which has product to restrict
+restrictProduct :: ProductBuilder               -- ^ Target node which has product to restrict
                 -> Projection Flat (Maybe Bool) -- ^ Restriction to add
-                -> Node                         -- ^ Result node
+                -> ProductBuilder               -- ^ Result node
 restrictProduct (Node a t) e = Node a (restrictProduct' t e)

relational-query/src/Database/Relational/Query/Internal/Sub.hs

@@ -15,6 +15,7 @@ module Database.Relational.Query.Internal.Sub
          -- * Product tree type
        , NodeAttr (..), ProductTree (..), Node (..)
        , JoinProduct, QueryProduct, QueryProductNode
+       , ProductTreeBuilder, ProductBuilder
 
        , Projection, untypeProjection, typedProjection
 
@@ -75,18 +76,24 @@ data NodeAttr = Just' | Maybe deriving Show
 
 type QS = Qualified SubQuery
 
+type QueryRestrictionsBuilder = DList (Projection Context.Flat (Maybe Bool))
+
 -- | Product tree type. Product tree is constructed by left node and right node.
-data ProductTree = Leaf QS
-                 | Join !Node !Node !(DList (Projection Context.Flat (Maybe Bool)))
-                   deriving Show
+data ProductTree rs
+  = Leaf QS
+  | Join !(Node rs) !(Node rs) !rs
+  deriving Show
 
 -- | Product node. node attribute and product tree.
-data Node = Node !NodeAttr !ProductTree  deriving Show
+data Node rs = Node !NodeAttr !(ProductTree rs)  deriving Show
 
 -- | Product tree specialized by 'SubQuery'.
-type QueryProduct = ProductTree
+type QueryProduct = ProductTree QueryRestrictionsBuilder
 -- | Product node specialized by 'SubQuery'.
-type QueryProductNode = Node
+type QueryProductNode = Node QueryRestrictionsBuilder
+
+type ProductTreeBuilder = ProductTree QueryRestrictionsBuilder
+type ProductBuilder = Node QueryRestrictionsBuilder
 
 -- | Type for join product of query.
 type JoinProduct = Maybe QueryProduct

relational-query/src/Database/Relational/Query/Sub.hs

@@ -326,11 +326,11 @@ unsafeProjectFromColumns =  typedProjection . untypedProjectionFromColumns
 
 
 -- | Get node attribute.
-nodeAttr :: Node -> NodeAttr
+nodeAttr :: Node rs -> NodeAttr
 nodeAttr (Node a _) = a  where
 
 -- | Get tree from node.
-nodeTree :: Node -> ProductTree
+nodeTree :: Node rs -> ProductTree rs
 nodeTree (Node _ t) = t
 
 -- | Show product tree of query into SQL. StringSQL result.