{-# LANGUAGE OverloadedStrings #-}
module Database.Relational.SqlSyntax.Fold (
showSQL, toSQL, unitSQL, width,
queryWidth, corrSubQueryTerm,
column,
tupleFromJoinedSubQuery,
recordRawColumns,
composeWhere, composeHaving,
composeGroupBy, composePartitionBy,
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
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
showQualifier :: Qualifier -> StringSQL
showQualifier (Qualifier i) = stringSQL $ 'T' : show i
(<.>) :: 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
columnFromId :: Qualifier -> Int -> StringSQL
columnFromId qi i = qi <.> columnN i
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
queryWidth :: Qualified SubQuery -> Int
queryWidth = width . Syntax.unQualify
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)..]
selectPrefixSQL :: Tuple -> Duplication -> StringSQL
selectPrefixSQL up da = SELECT <> showsDuplication da <>
SQL.fold (|*|) columns' where
columns' = zipWith asColumnN
(map showColumn up)
[(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
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
corrSubQueryTerm :: Bool
-> Qualified SubQuery
-> StringSQL
corrSubQueryTerm addAS qq =
showUnitSQL (Syntax.unQualify qq) `asOP` showQualifier (Syntax.qualifier qq)
where
asOP = if addAS then SQL.as else (<>)
column :: Qualified SubQuery -> Int -> StringSQL
column qs = d (Syntax.unQualify qs) where
q = Syntax.qualifier qs
d (Table u) i = q <.> (u ! i)
d (Bin {}) i = q `columnFromId` i
d (Flat _ up _ _ _ _) i = showTupleIndex up i
d (Aggregated _ up _ _ _ _ _ _) i = showTupleIndex up i
tupleFromJoinedSubQuery :: Qualified SubQuery -> Tuple
tupleFromJoinedSubQuery qs = d $ Syntax.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 showColumn p) <>
SQL.THEN <> showTupleIndex r i
else' = SQL.ELSE <> showTupleIndex 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 showColumn m) <> indexWhensClause wcl i
showColumn :: Column -> StringSQL
showColumn = d where
d (RawColumn e) = e
d (SubQueryRef qi) = Syntax.qualifier qi `columnFromId` Syntax.unQualify qi
d (Scalar sub) = showUnitSQL sub
d (Case c i) = caseClause c i
showTupleIndex :: Tuple
-> Int
-> StringSQL
showTupleIndex up i
| 0 <= i && i < Syntax.tupleWidth up =
showColumn $ up !! i
| otherwise =
error $ "showTupleIndex: index out of bounds: " ++ show i
recordRawColumns :: Record c r
-> [StringSQL]
recordRawColumns = map showColumn . Syntax.untypeRecord
showsQueryProduct :: ProductTree [Predicate Flat] -> StringSQL
showsQueryProduct = rec where
joinType Just' Just' = INNER
joinType Just' Maybe = LEFT
joinType Maybe Just' = RIGHT
joinType Maybe Maybe = FULL
urec n = case Syntax.nodeTree n of
p@(Leaf _) -> rec p
p@(Join {}) -> SQL.paren (rec p)
rec (Leaf q) = uncurry corrSubQueryTerm q
rec (Join left' right' rs) =
mconcat
[urec left',
joinType (Syntax.nodeAttr left') (Syntax.nodeAttr right'), JOIN,
urec right',
ON, foldr1 SQL.and $ ps ++ concat [ pure $ Lit.bool True | null ps ] ]
where ps = [ rowStringSQL $ recordRawColumns 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 -> [Predicate c] -> StringSQL
composeRestrict k = d where
d [] = mempty
d ps@(_:_) = k <> foldr1 SQL.and [ rowStringSQL $ recordRawColumns p | p <- ps ]
composeWhere :: [Predicate Flat] -> StringSQL
composeWhere = composeRestrict WHERE
composeHaving :: [Predicate Aggregated] -> StringSQL
composeHaving = composeRestrict HAVING
commaed :: [StringSQL] -> StringSQL
commaed = SQL.fold (|*|)
pComma :: (a -> StringSQL) -> [a] -> StringSQL
pComma qshow = SQL.paren . commaed . map qshow
showsAggregateBitKey :: AggregateBitKey -> StringSQL
showsAggregateBitKey (AggregateBitKey ts) = pComma id $ map showColumn ts
composeGroupBy :: [AggregateElem] -> StringSQL
composeGroupBy = d where
d [] = mempty
d es@(_:_) = GROUP <> BY <> rec es
keyList op ss = op <> pComma showsAggregateBitKey ss
rec = commaed . map showsE
showsGs (AggregateSet s) = SQL.paren $ rec s
showsE (ColumnRef t) = showColumn t
showsE (Rollup ss) = keyList ROLLUP ss
showsE (Cube ss) = keyList CUBE ss
showsE (GroupingSets ss) = GROUPING <> SETS <> pComma showsGs ss
composePartitionBy :: [AggregateColumnRef] -> StringSQL
composePartitionBy = d where
d [] = mempty
d ts@(_:_) = PARTITION <> BY <> commaed (map showColumn ts)
composeOrderBy :: [OrderingTerm] -> StringSQL
composeOrderBy = d where
d [] = mempty
d ts@(_:_) = ORDER <> BY <> SQL.fold (|*|) (map showsOt ts)
showsOt ((o, mn), e) = showColumn e <> order o <> maybe mempty ((NULLS <>) . nulls) mn
order Asc = ASC
order Desc = DESC
nulls NullsFirst = FIRST
nulls NullsLast = LAST