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,
QueryProduct, QueryProductNode, JoinProduct,
) where
import Data.Maybe (fromMaybe)
import Data.Array (Array, listArray)
import qualified Data.Array as Array
import Data.Monoid (mempty, (<>), mconcat)
import qualified Database.Relational.Query.Context as Context
import Database.Relational.Query.Expr (valueExpr)
import Database.Relational.Query.Expr.Unsafe (unsafeStringSql)
import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL)
import Database.Relational.Query.Internal.Product
(NodeAttr(Just', Maybe), ProductTree (Leaf, Join),
Node, nodeAttr, nodeTree)
import Database.Relational.Query.Component
(ColumnSQL, columnSQL', showsColumnSQL,
Config (productUnitSupport), ProductUnitSupport (PUSupported, PUNotSupported),
Duplication (..), showsDuplication, QueryRestriction, composeWhere, composeHaving,
AggregateElem, composeGroupBy, OrderingTerms, composeOrderBy)
import Database.Relational.Query.Table (Table, (!))
import qualified Database.Relational.Query.Table as Table
import Language.SQL.Keyword (Keyword(..), (|*|))
import qualified Language.SQL.Keyword as SQL
data SetOp = Union | Except | Intersect deriving Show
newtype BinOp = BinOp (SetOp, Duplication) deriving Show
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
data SubQuery = Table Table.Untyped
| Flat Config
UntypedProjection Duplication JoinProduct (QueryRestriction Context.Flat)
OrderingTerms
| Aggregated Config
UntypedProjection Duplication JoinProduct (QueryRestriction Context.Flat)
[AggregateElem] (QueryRestriction Context.Aggregated) OrderingTerms
| Bin BinOp SubQuery SubQuery
deriving Show
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
newtype Qualifier = Qualifier Int deriving Show
data Qualified a = Qualified a Qualifier deriving Show
instance Functor Qualified where
fmap f (Qualified a i) = Qualified (f a) i
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
data ProjectionUnit = Columns (Array Int ColumnSQL)
| Normalized (Qualified Int)
| Scalar SubQuery
deriving Show
projectionUnitFromColumns :: [ColumnSQL] -> ProjectionUnit
projectionUnitFromColumns cs = Columns $ listArray (0, length cs 1) cs
projectionUnitFromScalarSubQuery :: SubQuery -> ProjectionUnit
projectionUnitFromScalarSubQuery = Scalar
type UntypedProjection = [ProjectionUnit]
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
type QueryProduct = ProductTree (Qualified SubQuery)
type QueryProductNode = Node (Qualified SubQuery)
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,
unsafeStringSql . fromMaybe (valueExpr True) $ rs]
type JoinProduct = Maybe QueryProduct
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!"