module Database.Relational.SqlSyntax.Fold (
showSQL, toSQL, unitSQL, width,
queryWidth,
column,
tupleFromJoinedSubQuery,
recordRawColumns,
composeWhere, composeHaving
) 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, boolSQL, )
import Database.Relational.SqlSyntax.Query (composeOrderBy, )
import Database.Relational.SqlSyntax.Aggregate (composeGroupBy, )
import Database.Relational.SqlSyntax.Types
(SubQuery (..), Record, Tuple, Predicate,
Column (..), CaseClause(..), WhenClauses (..),
NodeAttr (Just', Maybe), ProductTree (Leaf, Join), JoinProduct,
Duplication (..), SetOp (..), BinOp (..), Qualifier (..), Qualified (..), )
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
qualifiedSQLas :: Qualified StringSQL -> StringSQL
qualifiedSQLas q = Syntax.unQualify q <> showQualifier (Syntax.qualifier q)
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
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) = qualifiedSQLas $ fmap showUnitSQL 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 $ boolSQL 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