diff --git a/relational-join/src/Database/Relational/Query/Internal/Product.hs b/relational-join/src/Database/Relational/Query/Internal/Product.hs index 18f7145d..5f10140b 100644 --- a/relational-join/src/Database/Relational/Query/Internal/Product.hs +++ b/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 diff --git a/relational-join/src/Database/Relational/Query/Monad/Trans/JoinState.hs b/relational-join/src/Database/Relational/Query/Monad/Trans/JoinState.hs index 0544c8b5..8a032430 100644 --- a/relational-join/src/Database/Relational/Query/Monad/Trans/JoinState.hs +++ b/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 diff --git a/relational-join/src/Database/Relational/Query/Sub.hs b/relational-join/src/Database/Relational/Query/Sub.hs index c6df57c0..3a4cdf69 100644 --- a/relational-join/src/Database/Relational/Query/Sub.hs +++ b/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