module Database.Relational.Query.Sub (
SubQuery, fromTable, flatSubQuery, aggregatedSubQuery,
union, except, intersect,
showSQL, toSQL, unitSQL, width,
Qualifier (Qualifier),
Qualified,
queryWidth,
column,
Projection, ProjectionUnit, UntypedProjection,
untypedProjectionFromJoinedSubQuery,
projectionColumns, unsafeProjectionStringSql,
JoinProduct, NodeAttr (..),
ProductBuilder,
QueryRestriction,
composeWhere, composeHaving
) where
import Control.Applicative ((<$>))
import Data.Monoid (mempty, (<>), mconcat)
import Data.Traversable (traverse)
import Language.SQL.Keyword (Keyword(..), (|*|))
import qualified Language.SQL.Keyword as SQL
import Database.Relational.Query.Internal.Config
(Config (productUnitSupport), ProductUnitSupport (PUSupported, PUNotSupported))
import qualified Database.Relational.Query.Context as Context
import Database.Relational.Query.Internal.SQL
(StringSQL, stringSQL, rowStringSQL, showStringSQL, )
import Database.Relational.Query.Internal.BaseSQL
(Duplication (..), showsDuplication, OrderingTerm, composeOrderBy, )
import Database.Relational.Query.Internal.GroupingSQL
(AggregateElem, composeGroupBy, )
import Database.Relational.Query.Internal.Sub
(SubQuery (..), Projection,
CaseClause(..), WhenClauses (..),
UntypedProjection, ProjectionUnit (..),
JoinProduct, QueryProductTree, ProductBuilder,
NodeAttr (Just', Maybe), ProductTree (Leaf, Join),
SetOp (..), BinOp (..), Qualifier (..), Qualified (..),
QueryRestriction)
import qualified Database.Relational.Query.Internal.Sub as Internal
import Database.Relational.Query.Internal.UntypedTable ((!))
import qualified Database.Relational.Query.Internal.UntypedTable as UntypedTable
import Database.Relational.Query.Table (Table)
import qualified Database.Relational.Query.Table as Table
import Database.Relational.Query.Pure (showConstantTermsSQL')
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
-> [OrderingTerm]
-> SubQuery
flatSubQuery = Flat
aggregatedSubQuery :: Config
-> UntypedProjection
-> Duplication
-> JoinProduct
-> QueryRestriction Context.Flat
-> [AggregateElem]
-> QueryRestriction Context.Aggregated
-> [OrderingTerm]
-> 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) = UntypedTable.width' u
d (Bin _ l _) = width l
d (Flat _ up _ _ _ _) = Internal.untypedProjectionWidth up
d (Aggregated _ up _ _ _ _ _ _) = Internal.untypedProjectionWidth up
fromTableToSQL :: UntypedTable.Untyped -> StringSQL
fromTableToSQL t =
SELECT <> SQL.fold (|*|) (UntypedTable.columns' t) <>
FROM <> stringSQL (UntypedTable.name' t)
fromTableToNormalizedSQL :: UntypedTable.Untyped -> StringSQL
fromTableToNormalizedSQL t = SELECT <> SQL.fold (|*|) columns' <>
FROM <> stringSQL (UntypedTable.name' t) where
columns' = zipWith asColumnN
(UntypedTable.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
(map columnOfProjectionUnit up)
[(0 :: Int)..]
toSQLs :: SubQuery
-> (StringSQL, StringSQL)
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
unitSQL :: SubQuery -> String
unitSQL = showStringSQL . showUnitSQL
showSQL :: SubQuery -> StringSQL
showSQL = snd . toSQLs
toSQL :: SubQuery -> String
toSQL = showStringSQL . showSQL
columnN :: Int -> StringSQL
columnN i = stringSQL $ 'f' : show i
asColumnN :: StringSQL -> Int -> StringSQL
c `asColumnN` n =c `SQL.as` columnN n
showQualifier :: Qualifier -> StringSQL
showQualifier (Qualifier i) = stringSQL $ 'T' : show i
(<.>) :: Qualifier -> StringSQL -> StringSQL
i <.> n = showQualifier i SQL.<.> n
columnFromId :: Qualifier -> Int -> StringSQL
columnFromId qi i = qi <.> columnN i
qualifiedSQLas :: Qualified StringSQL -> StringSQL
qualifiedSQLas q = Internal.unQualify q <> showQualifier (Internal.qualifier q)
queryWidth :: Qualified SubQuery -> Int
queryWidth = width . Internal.unQualify
column :: Qualified SubQuery -> Int -> StringSQL
column qs = d (Internal.unQualify qs) where
q = Internal.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
untypedProjectionFromJoinedSubQuery :: Qualified SubQuery -> UntypedProjection
untypedProjectionFromJoinedSubQuery qs = d $ Internal.unQualify qs where
normalized = SubQueryRef <$> traverse (\q -> [0 .. width q 1]) qs
d (Table _) = map RawColumn . map (column qs)
$ take (queryWidth qs) [0..]
d (Bin {}) = normalized
d (Flat {}) = normalized
d (Aggregated {}) = normalized
indexWhensClause :: WhenClauses -> Int -> StringSQL
indexWhensClause (WhenClauses ps e) i =
mconcat [ when' p r | (p, r) <- ps] <> else' <> SQL.END
where
when' p r = SQL.WHEN <> rowStringSQL (map columnOfProjectionUnit p) <>
SQL.THEN <> columnOfUntypedProjection r i
else' = SQL.ELSE <> columnOfUntypedProjection e i
caseClause :: CaseClause -> Int -> StringSQL
caseClause c i = d c where
d (CaseSearch wcl) = SQL.CASE <> indexWhensClause wcl i
d (CaseSimple m wcl) = SQL.CASE <> rowStringSQL (map columnOfProjectionUnit m) <> indexWhensClause wcl i
columnOfProjectionUnit :: ProjectionUnit -> StringSQL
columnOfProjectionUnit = d where
d (RawColumn e) = e
d (SubQueryRef qi) = Internal.qualifier qi `columnFromId` Internal.unQualify qi
d (Scalar sub) = showUnitSQL sub
d (Case c i) = caseClause c i
columnOfUntypedProjection :: UntypedProjection
-> Int
-> StringSQL
columnOfUntypedProjection up i
| 0 <= i && i < Internal.untypedProjectionWidth up =
columnOfProjectionUnit $ up !! i
| otherwise =
error $ "columnOfUntypedProjection: index out of bounds: " ++ show i
projectionColumns :: Projection c r
-> [StringSQL]
projectionColumns = map columnOfProjectionUnit . Internal.untypeProjection
unsafeProjectionStringSql :: Projection c r -> StringSQL
unsafeProjectionStringSql = rowStringSQL . projectionColumns
showsQueryProduct :: QueryProductTree -> StringSQL
showsQueryProduct = rec where
joinType Just' Just' = INNER
joinType Just' Maybe = LEFT
joinType Maybe Just' = RIGHT
joinType Maybe Maybe = FULL
urec n = case Internal.nodeTree n of
p@(Leaf _) -> rec p
p@(Join {}) -> SQL.paren (rec p)
rec (Leaf q) = qualifiedSQLas $ fmap showUnitSQL q
rec (Join left' right' rs) =
mconcat
[urec left',
joinType (Internal.nodeAttr left') (Internal.nodeAttr right'), JOIN,
urec right',
ON, foldr1 SQL.and $ ps ++ concat [ showConstantTermsSQL' True | null ps ] ]
where ps = [ unsafeProjectionStringSql p | p <- 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