Move concrete product definitions.

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

@@ -10,29 +10,16 @@
 -- This module defines product structure to compose SQL join.
 module Database.Relational.Query.Internal.Product (
   -- * Product tree type
-  NodeAttr (Just', Maybe),
-  ProductTree, Node, QueryProduct, QueryProductNode,
-  nodeTree, growRight, -- growLeft,
+  NodeAttr (..), ProductTree (..),
+  Node (Node), node, nodeAttr, nodeTree,
+  growRight, -- growLeft,
   growProduct, product, restrictProduct,
-
-  -- * Compose joined SQL
-  queryProductSQL
   ) where
 
 import Prelude hiding (and, product)
 import Database.Relational.Query.Context (Flat)
-import Database.Relational.Query.Expr (fromTriBool, exprAnd)
+import Database.Relational.Query.Expr (exprAnd)
 import qualified Database.Relational.Query.Expr as Expr
-import Database.Relational.Query.Expr.Unsafe (showExpr)
-import Database.Relational.Query.Projectable (valueTrue)
-import Database.Relational.Query.Sub (SubQuery, Qualified)
-import qualified Database.Relational.Query.Sub as SubQuery
-
-import Database.Relational.Query.Internal.ShowS
-  (showUnwordsSQL, showWordSQL, showUnwords)
-import Language.SQL.Keyword (Keyword(..))
-
-import Data.Maybe (fromMaybe)
 import Data.Monoid ((<>))
 import Data.Foldable (Foldable (foldMap))
 
@@ -63,11 +50,6 @@ instance Foldable ProductTree where
     rec (Leaf q) = f q
     rec (Join (Node _ lp) (Node _ rp) _ ) = rec lp <> rec rp
 
--- | Product tree specialized by 'SubQuery'.
-type QueryProduct = ProductTree (Qualified SubQuery)
--- | Product node specialized by 'SubQuery'.
-type QueryProductNode = Node (Qualified SubQuery)
-
 -- | Make product node from node attribute and product tree.
 node :: NodeAttr      -- ^ Node attribute
      -> ProductTree q -- ^ Product tree
@@ -119,27 +101,3 @@ restrictProduct :: Node q    -- ^ Target node which has product to restrict
                 -> Expr Bool -- ^ Restriction to add
                 -> Node q    -- ^ Result node
 restrictProduct (Node a t) e = node a (restrictProduct' t e)
-
-
--- | Show product tree of query into SQL. ShowS result.
-showQueryProduct :: QueryProduct -> ShowS
-showQueryProduct =  rec  where
-  joinType Just' Just' = INNER
-  joinType Just' Maybe = LEFT
-  joinType Maybe Just' = RIGHT
-  joinType Maybe Maybe = FULL
-  urec (Node _ p@(Leaf _))     = rec p
-  urec (Node _ p@(Join _ _ _)) = showParen True (rec p)
-  rec (Leaf q)               = showString $ SubQuery.qualifiedForm q
-  rec (Join left' right' rs) =
-    showUnwords
-    [urec left',
-     showUnwordsSQL [joinType (nodeAttr left') (nodeAttr right'), JOIN],
-     urec right',
-     showWordSQL ON,
-     showString . showExpr
-     . fromMaybe (fromTriBool valueTrue) {- or error on compile -}  $ rs]
-
--- | Show product tree of query into SQL.
-queryProductSQL :: QueryProduct -> String
-queryProductSQL =  ($ "") . showQueryProduct

relational-join/src/Database/Relational/Query/Monad/Trans/JoinState.hs

@@ -24,8 +24,8 @@ module Database.Relational.Query.Monad.Trans.JoinState (
 
 import Prelude hiding (product)
 
-import Database.Relational.Query.Internal.Product (QueryProductNode, QueryProduct, queryProductSQL)
 import qualified Database.Relational.Query.Internal.Product as Product
+import Database.Relational.Query.Sub (QueryProductNode, QueryProduct, queryProductSQL)
 
 import Language.SQL.Keyword (Keyword(..), unwordsSQL)
 import qualified Language.SQL.Keyword as SQL
@@ -62,5 +62,5 @@ composeFrom' pd =
 -- | Compose SQL String from 'JoinContext' object.
 composeFrom :: JoinContext -> String
 composeFrom =  composeFrom'
-              . maybe (error "relation: empty product!") (Product.nodeTree)
+              . maybe (error "relation: empty product!") Product.nodeTree
               . product

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

@@ -29,16 +29,29 @@ module Database.Relational.Query.Sub (
   ProjectionUnit, UntypedProjection,
 
   untypedProjectionFromColumns, untypedProjectionFromSubQuery,
-  widthOfProjectionUnit, columnOfProjectionUnit
+  widthOfProjectionUnit, columnOfProjectionUnit,
+
+  -- * Product of sub-queries
+  QueryProduct, QueryProductNode,
+
+  queryProductSQL
   ) where
 
+import Data.Maybe (fromMaybe)
 import Data.List (intercalate)
 import Data.Array (Array, listArray)
 import qualified Data.Array as Array
 
+import Database.Relational.Query.Expr (valueExpr)
+import Database.Relational.Query.Expr.Unsafe (showExpr)
+import Database.Relational.Query.Internal.Product
+  (NodeAttr(Just', Maybe), ProductTree (Leaf, Join),
+   Node (Node), nodeAttr)
 import Database.Relational.Query.Table (Table, (!))
 import qualified Database.Relational.Query.Table as Table
 
+import Database.Relational.Query.Internal.ShowS
+  (showUnwordsSQL, showWordSQL, showUnwords)
 import Language.SQL.Keyword (Keyword(..), unwordsSQL)
 import qualified Language.SQL.Keyword as SQL
 import qualified Language.SQL.Keyword.ConcatString as SQLs
@@ -237,3 +250,32 @@ columnOfProjectionUnit =  d  where
                   | otherwise          = error $ "index out of bounds (unit): " ++ show i
     where (mn, mx) = Array.bounds a
   d (Sub sq) i = column sq i
+
+
+-- | Product tree specialized by 'SubQuery'.
+type QueryProduct = ProductTree (Qualified SubQuery)
+-- | Product node specialized by 'SubQuery'.
+type QueryProductNode = Node (Qualified SubQuery)
+
+-- | Show product tree of query into SQL. ShowS result.
+showQueryProduct :: QueryProduct -> ShowS
+showQueryProduct =  rec  where
+  joinType Just' Just' = INNER
+  joinType Just' Maybe = LEFT
+  joinType Maybe Just' = RIGHT
+  joinType Maybe Maybe = FULL
+  urec (Node _ p@(Leaf _))     = rec p
+  urec (Node _ p@(Join _ _ _)) = showParen True (rec p)
+  rec (Leaf q)               = showString $ qualifiedForm q
+  rec (Join left' right' rs) =
+    showUnwords
+    [urec left',
+     showUnwordsSQL [joinType (nodeAttr left') (nodeAttr right'), JOIN],
+     urec right',
+     showWordSQL ON,
+     showString . showExpr
+     . fromMaybe (valueExpr True) {- or error on compile -}  $ rs]
+
+-- | Show product tree of query into SQL.
+queryProductSQL :: QueryProduct -> String
+queryProductSQL =  ($ "") . showQueryProduct