{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Database.Relational.SqlSyntax.Fold -- Copyright : 2013-2019 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines sub-query structure used in query products. module Database.Relational.SqlSyntax.Fold ( -- * Sub-query showSQL, toSQL, unitSQL, width, -- * Qualified Sub-query queryWidth, corrSubQueryTerm, -- * Sub-query columns column, -- * Tuple and Record tupleFromJoinedSubQuery, recordRawColumns, -- * Query restriction composeWhere, composeHaving, -- * Aggregation composeGroupBy, composePartitionBy, -- * Ordering composeOrderBy, ) where import Control.Applicative ((<$>), pure) import Data.Monoid (mempty, (<>), mconcat) import Data.Traversable (traverse) import Language.SQL.Keyword (Keyword(..), (|*|)) import qualified Language.SQL.Keyword as SQL import Database.Relational.Internal.ContextType (Flat, Aggregated) import Database.Relational.Internal.Config (Config (productUnitSupport), ProductUnitSupport (PUSupported, PUNotSupported), ) import Database.Relational.Internal.UntypedTable ((!)) import qualified Database.Relational.Internal.UntypedTable as UntypedTable import Database.Relational.Internal.String (StringSQL, stringSQL, rowStringSQL, showStringSQL, ) import qualified Database.Relational.Internal.Literal as Lit import Database.Relational.SqlSyntax.Types (SubQuery (..), Record, Tuple, Predicate, Column (..), CaseClause(..), WhenClauses (..), NodeAttr (Just', Maybe), ProductTree (Leaf, Join), JoinProduct, Duplication (..), SetOp (..), BinOp (..), Qualifier (..), Qualified (..), AggregateBitKey (..), AggregateSet (..), AggregateElem (..), AggregateColumnRef, Order (..), Nulls (..), OrderingTerm, ) import qualified Database.Relational.SqlSyntax.Types as Syntax -- | Compose duplication attribute string. showsDuplication :: Duplication -> StringSQL showsDuplication = dup where dup All = ALL dup Distinct = DISTINCT showsSetOp' :: SetOp -> StringSQL showsSetOp' = d where d Union = UNION d Except = EXCEPT d Intersect = INTERSECT showsSetOp :: SetOp -> Duplication -> StringSQL showsSetOp op dup0 = showsSetOp' op <> mayDup dup0 where mayDup dup@All = showsDuplication dup mayDup Distinct = mempty -- | Alias string from qualifier showQualifier :: Qualifier -> StringSQL showQualifier (Qualifier i) = stringSQL $ 'T' : show i -- | Binary operator to qualify. (<.>) :: Qualifier -> StringSQL -> StringSQL i <.> n = showQualifier i SQL.<.> n columnN :: Int -> StringSQL columnN i = stringSQL $ 'f' : show i asColumnN :: StringSQL -> Int -> StringSQL c `asColumnN` n =c `SQL.as` columnN n -- | Qualified expression from qualifier and projection index. columnFromId :: Qualifier -> Int -> StringSQL columnFromId qi i = qi <.> columnN i -- | Width of 'SubQuery'. width :: SubQuery -> Int width = d where d (Table u) = UntypedTable.width' u d (Bin _ l _) = width l d (Flat _ up _ _ _ _) = Syntax.tupleWidth up d (Aggregated _ up _ _ _ _ _ _) = Syntax.tupleWidth up -- | Width of 'Qualified' 'SubQUery'. queryWidth :: Qualified SubQuery -> Int queryWidth = width . Syntax.unQualify -- | Generate SQL from table for top-level. fromTableToSQL :: UntypedTable.Untyped -> StringSQL fromTableToSQL t = SELECT <> SQL.fold (|*|) (UntypedTable.columns' t) <> FROM <> stringSQL (UntypedTable.name' t) -- | Generate normalized column SQL from table. fromTableToNormalizedSQL :: UntypedTable.Untyped -> StringSQL fromTableToNormalizedSQL t = SELECT <> SQL.fold (|*|) columns' <> FROM <> stringSQL (UntypedTable.name' t) where columns' = zipWith asColumnN (UntypedTable.columns' t) [(0 :: Int)..] -- | Generate normalized column SQL from joined tuple. selectPrefixSQL :: Tuple -> Duplication -> StringSQL selectPrefixSQL up da = SELECT <> showsDuplication da <> SQL.fold (|*|) columns' where columns' = zipWith asColumnN (map showColumn up) [(0 :: Int)..] -- | Normalized column SQL for union like operations -- to keep compatibility with engines like Sqlite and MySQL. -- SQL with no ordering term is not paren-ed. normalizedSQL :: SubQuery -> StringSQL normalizedSQL = d where d (Table t) = fromTableToNormalizedSQL t d sub@(Bin {}) = showUnitSQL sub d sub@(Flat _ _ _ _ _ ots) | null ots = showSQL sub | otherwise = showUnitSQL sub d sub@(Aggregated _ _ _ _ _ _ _ ots) | null ots = showSQL sub | otherwise = showUnitSQL sub -- | SQL string for nested-query and toplevel-SQL. toSQLs :: SubQuery -> (StringSQL, StringSQL) -- ^ sub-query SQL and top-level SQL toSQLs = d where d (Table u) = (stringSQL $ UntypedTable.name' u, fromTableToSQL u) d (Bin (BinOp (op, da)) l r) = (SQL.paren q, q) where q = mconcat [normalizedSQL l, showsSetOp op da, normalizedSQL r] d (Flat cf up da pd rs od) = (SQL.paren q, q) where q = selectPrefixSQL up da <> showsJoinProduct (productUnitSupport cf) pd <> composeWhere rs <> composeOrderBy od d (Aggregated cf up da pd rs ag grs od) = (SQL.paren q, q) where q = selectPrefixSQL up da <> showsJoinProduct (productUnitSupport cf) pd <> composeWhere rs <> composeGroupBy ag <> composeHaving grs <> composeOrderBy od showUnitSQL :: SubQuery -> StringSQL showUnitSQL = fst . toSQLs -- | SQL string for nested-qeury. unitSQL :: SubQuery -> String unitSQL = showStringSQL . showUnitSQL -- | SQL StringSQL for toplevel-SQL. showSQL :: SubQuery -> StringSQL showSQL = snd . toSQLs -- | SQL string for toplevel-SQL. toSQL :: SubQuery -> String toSQL = showStringSQL . showSQL -- | Term of qualified table or qualified subquery, -- used in join-clause of SELECT, correlated UPDATE and DELETE statements. -- When SubQuery is table, expression will be like