module Database.Relational.Query.Sub (
SubQuery, fromTable, flatSubQuery, aggregatedSubQuery,
union, except, intersect,
showSQL, toSQL, unitSQL, width,
Qualifier (Qualifier),
Qualified, qualifier, unQualify, qualify,
queryWidth,
column,
ProjectionUnit, UntypedProjection,
untypedProjectionFromColumns, untypedProjectionFromJoinedSubQuery, untypedProjectionFromScalarSubQuery,
widthOfUntypedProjection, columnsOfUntypedProjection,
projectionColumns, unsafeProjectionStringSql, unsafeProjectFromColumns,
QueryProduct, QueryProductNode, JoinProduct,
composeWhere, composeHaving
) where
import Data.Array (listArray)
import qualified Data.Array as Array
import Data.Monoid (mempty, (<>), mconcat)
import Data.DList (toList)
import qualified Database.Relational.Query.Context as Context
import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, rowStringSQL, showStringSQL)
import Database.Relational.Query.Internal.Product
(nodeAttr, nodeTree)
import Database.Relational.Query.Internal.Sub
(SubQuery (..), Projection, untypeProjection, typedProjection,
UntypedProjection, ProjectionUnit (..),
JoinProduct, QueryProduct, QueryProductNode,
NodeAttr (Just', Maybe), ProductTree (Leaf, Join),
SetOp (..), BinOp (..), Qualifier (..), Qualified (..),
QueryRestriction)
import Database.Relational.Query.Component
(ColumnSQL, columnSQL', showsColumnSQL,
Config (productUnitSupport), ProductUnitSupport (PUSupported, PUNotSupported),
Duplication (..), showsDuplication,
AggregateElem, composeGroupBy, OrderingTerms, composeOrderBy)
import Database.Relational.Query.Table (Table, (!))
import qualified Database.Relational.Query.Table as Table
import Database.Relational.Query.Pure (showConstantTermsSQL')
import Language.SQL.Keyword (Keyword(..), (|*|))
import qualified Language.SQL.Keyword as SQL
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
fromTable :: Table r
-> SubQuery
fromTable = Table . Table.unType
flatSubQuery :: Config
-> UntypedProjection
-> Duplication
-> JoinProduct
-> QueryRestriction Context.Flat
-> OrderingTerms
-> SubQuery
flatSubQuery = Flat
aggregatedSubQuery :: Config
-> UntypedProjection
-> Duplication
-> JoinProduct
-> QueryRestriction Context.Flat
-> [AggregateElem]
-> QueryRestriction Context.Aggregated
-> OrderingTerms
-> SubQuery
aggregatedSubQuery = Aggregated
setBin :: SetOp -> Duplication -> SubQuery -> SubQuery -> SubQuery
setBin op = Bin . BinOp . (,) op
union :: Duplication -> SubQuery -> SubQuery -> SubQuery
union = setBin Union
except :: Duplication -> SubQuery -> SubQuery -> SubQuery
except = setBin Except
intersect :: Duplication -> SubQuery -> SubQuery -> SubQuery
intersect = setBin Intersect
width :: SubQuery -> Int
width = d where
d (Table u) = Table.width' u
d (Bin _ l _) = width l
d (Flat _ up _ _ _ _) = widthOfUntypedProjection up
d (Aggregated _ up _ _ _ _ _ _) = widthOfUntypedProjection up
fromTableToSQL :: Table.Untyped -> StringSQL
fromTableToSQL t =
SELECT <> SQL.fold (|*|) [showsColumnSQL c | c <- Table.columns' t] <>
FROM <> stringSQL (Table.name' t)
fromTableToNormalizedSQL :: Table.Untyped -> StringSQL
fromTableToNormalizedSQL t = SELECT <> SQL.fold (|*|) columns' <>
FROM <> stringSQL (Table.name' t) where
columns' = zipWith asColumnN
(Table.columns' t)
[(0 :: Int)..]
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
selectPrefixSQL :: UntypedProjection -> Duplication -> StringSQL
selectPrefixSQL up da = SELECT <> showsDuplication da <>
SQL.fold (|*|) columns' where
columns' = zipWith asColumnN
(columnsOfUntypedProjection up)
[(0 :: Int)..]
toSQLs :: SubQuery
-> (StringSQL, StringSQL)
toSQLs = d where
d (Table u) = (stringSQL $ Table.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
unitSQL :: SubQuery -> String
unitSQL = showStringSQL . showUnitSQL
showSQL :: SubQuery -> StringSQL
showSQL = snd . toSQLs
toSQL :: SubQuery -> String
toSQL = showStringSQL . showSQL
qualifier :: Qualified a -> Qualifier
qualifier (Qualified _ i) = i
unQualify :: Qualified a -> a
unQualify (Qualified a _) = a
qualify :: a -> Qualifier -> Qualified a
qualify = Qualified
columnN :: Int -> StringSQL
columnN i = stringSQL $ 'f' : show i
asColumnN :: ColumnSQL -> Int -> StringSQL
c `asColumnN` n = showsColumnSQL c `SQL.as` columnN n
showQualifier :: Qualifier -> StringSQL
showQualifier (Qualifier i) = stringSQL $ 'T' : show i
(<.>) :: Qualifier -> ColumnSQL -> ColumnSQL
i <.> n = fmap (showQualifier i SQL.<.>) n
columnFromId :: Qualifier -> Int -> ColumnSQL
columnFromId qi i = qi <.> columnSQL' (columnN i)
qualifiedSQLas :: Qualified StringSQL -> StringSQL
qualifiedSQLas q = unQualify q <> showQualifier (qualifier q)
queryWidth :: Qualified SubQuery -> Int
queryWidth = width . unQualify
column :: Qualified SubQuery -> Int -> ColumnSQL
column qs = d (unQualify qs) where
q = qualifier qs
d (Table u) i = q <.> (u ! i)
d (Bin {}) i = q `columnFromId` i
d (Flat _ up _ _ _ _) i = columnOfUntypedProjection up i
d (Aggregated _ up _ _ _ _ _ _) i = columnOfUntypedProjection up i
qualifiedForm :: Qualified SubQuery -> StringSQL
qualifiedForm = qualifiedSQLas . fmap showUnitSQL
projectionUnitFromColumns :: [ColumnSQL] -> ProjectionUnit
projectionUnitFromColumns cs = Columns $ listArray (0, length cs 1) cs
projectionUnitFromScalarSubQuery :: SubQuery -> ProjectionUnit
projectionUnitFromScalarSubQuery = Scalar
unitUntypedProjection :: ProjectionUnit -> UntypedProjection
unitUntypedProjection = (:[])
untypedProjectionFromColumns :: [ColumnSQL] -> UntypedProjection
untypedProjectionFromColumns = unitUntypedProjection . projectionUnitFromColumns
untypedProjectionFromScalarSubQuery :: SubQuery -> UntypedProjection
untypedProjectionFromScalarSubQuery = unitUntypedProjection . projectionUnitFromScalarSubQuery
untypedProjectionFromJoinedSubQuery :: Qualified SubQuery -> UntypedProjection
untypedProjectionFromJoinedSubQuery qs = d $ unQualify qs where
normalized = unitUntypedProjection . Normalized $ fmap width qs
d (Table _) = untypedProjectionFromColumns . map (column qs)
$ take (queryWidth qs) [0..]
d (Bin {}) = normalized
d (Flat {}) = normalized
d (Aggregated {}) = normalized
widthOfProjectionUnit :: ProjectionUnit -> Int
widthOfProjectionUnit = d where
d (Columns a) = mx mn + 1 where (mn, mx) = Array.bounds a
d (Normalized qw) = unQualify qw
d (Scalar _) = 1
columnOfProjectionUnit :: ProjectionUnit -> Int -> ColumnSQL
columnOfProjectionUnit = d where
d (Columns a) i | mn <= i && i <= mx = a Array.! i
| otherwise = error $ "index out of bounds (unit): " ++ show i
where (mn, mx) = Array.bounds a
d (Normalized qw) i | i < w = qualifier qw `columnFromId` i
| otherwise = error $ "index out of bounds (normalized unit): " ++ show i
where w = unQualify qw
d (Scalar sub) 0 = columnSQL' $ showUnitSQL sub
d (Scalar _) i = error $ "index out of bounds (scalar unit): " ++ show i
widthOfUntypedProjection :: UntypedProjection -> Int
widthOfUntypedProjection = sum . map widthOfProjectionUnit
columnOfUntypedProjection :: UntypedProjection
-> Int
-> ColumnSQL
columnOfUntypedProjection up i' = rec up i' where
rec [] _ = error $ "index out of bounds: " ++ show i'
rec (u : us) i
| i < widthOfProjectionUnit u = columnOfProjectionUnit u i
| i < 0 = error $ "index out of bounds: " ++ show i
| otherwise = rec us (i widthOfProjectionUnit u)
columnsOfUntypedProjection :: UntypedProjection
-> [ColumnSQL]
columnsOfUntypedProjection p = map (columnOfUntypedProjection p) . take w $ [0 .. ]
where w = widthOfUntypedProjection p
projectionColumns :: Projection c r
-> [ColumnSQL]
projectionColumns = columnsOfUntypedProjection . untypeProjection
unsafeProjectionStringSql :: Projection c r -> StringSQL
unsafeProjectionStringSql = rowStringSQL . map showsColumnSQL . projectionColumns
unsafeProjectFromColumns :: [ColumnSQL]
-> Projection c r
unsafeProjectFromColumns = typedProjection . untypedProjectionFromColumns
showsQueryProduct :: QueryProduct -> StringSQL
showsQueryProduct = rec where
joinType Just' Just' = INNER
joinType Just' Maybe = LEFT
joinType Maybe Just' = RIGHT
joinType Maybe Maybe = FULL
urec n = case nodeTree n of
p@(Leaf _) -> rec p
p@(Join {}) -> SQL.paren (rec p)
rec (Leaf q) = qualifiedForm q
rec (Join left' right' rs) =
mconcat
[urec left',
joinType (nodeAttr left') (nodeAttr right'), JOIN,
urec right',
ON, foldr1 SQL.and $ ps ++ concat [ showConstantTermsSQL' True | null ps ] ]
where ps = [ unsafeProjectionStringSql p | p <- toList rs ]
showsJoinProduct :: ProductUnitSupport -> JoinProduct -> StringSQL
showsJoinProduct ups = maybe (up ups) from where
from qp = FROM <> showsQueryProduct qp
up PUSupported = mempty
up PUNotSupported = error "relation: Unit product support mode is disabled!"
composeRestrict :: Keyword -> QueryRestriction c -> StringSQL
composeRestrict k = d where
d [] = mempty
d ps@(_:_) = k <> foldr1 SQL.and [ unsafeProjectionStringSql p | p <- ps ]
composeWhere :: QueryRestriction Context.Flat -> StringSQL
composeWhere = composeRestrict WHERE
composeHaving :: QueryRestriction Context.Aggregated -> StringSQL
composeHaving = composeRestrict HAVING