module Database.HaskellDB.Sql.Default (
mkSqlGenerator,
defaultSqlGenerator,
defaultSqlQuery,
defaultSqlUpdate,
defaultSqlDelete,
defaultSqlInsert,
defaultSqlInsertQuery,
defaultSqlCreateDB,
defaultSqlCreateTable,
defaultSqlDropDB,
defaultSqlDropTable,
defaultSqlEmpty,
defaultSqlTable,
defaultSqlProject,
defaultSqlRestrict,
defaultSqlBinary,
defaultSqlGroup,
defaultSqlSpecial,
defaultSqlExpr,
defaultSqlLiteral,
defaultSqlType,
defaultSqlQuote,
toSqlSelect
) where
import Data.List (intersect)
import Database.HaskellDB.PrimQuery
import Database.HaskellDB.FieldType
import Database.HaskellDB.Sql
import Database.HaskellDB.Sql.Generate
import System.Locale
import System.Time
import Data.Maybe (catMaybes)
import Data.List (nubBy)
import qualified Data.Map as Map (fromList, lookup)
mkSqlGenerator :: SqlGenerator -> SqlGenerator
mkSqlGenerator gen = SqlGenerator
{
sqlQuery = defaultSqlQuery gen,
sqlUpdate = defaultSqlUpdate gen,
sqlDelete = defaultSqlDelete gen,
sqlInsert = defaultSqlInsert gen,
sqlInsertQuery = defaultSqlInsertQuery gen,
sqlCreateDB = defaultSqlCreateDB gen,
sqlCreateTable = defaultSqlCreateTable gen,
sqlDropDB = defaultSqlDropDB gen,
sqlDropTable = defaultSqlDropTable gen,
sqlEmpty = defaultSqlEmpty gen,
sqlTable = defaultSqlTable gen,
sqlProject = defaultSqlProject gen,
sqlRestrict = defaultSqlRestrict gen,
sqlBinary = defaultSqlBinary gen,
sqlGroup = defaultSqlGroup gen,
sqlSpecial = defaultSqlSpecial gen,
sqlExpr = defaultSqlExpr gen,
sqlLiteral = defaultSqlLiteral gen,
sqlType = defaultSqlType gen,
sqlQuote = defaultSqlQuote gen
}
defaultSqlGenerator :: SqlGenerator
defaultSqlGenerator = mkSqlGenerator defaultSqlGenerator
defaultSqlType :: SqlGenerator -> FieldType -> SqlType
defaultSqlType _ t =
case t of
StringT -> SqlType "text"
IntT -> SqlType "int"
IntegerT -> SqlType "bigint"
DoubleT -> SqlType "double precision"
BoolT -> SqlType "bit"
CalendarTimeT -> SqlType "timestamp with time zone"
BStrT a -> SqlType1 "varchar" a
defaultSqlQuery :: SqlGenerator -> PrimQuery -> SqlSelect
defaultSqlQuery gen query = foldPrimQuery (sqlEmpty gen,
sqlTable gen,
sqlProject gen,
sqlRestrict gen,
sqlBinary gen,
sqlGroup gen,
sqlSpecial gen) query
defaultSqlEmpty :: SqlGenerator -> SqlSelect
defaultSqlEmpty _ = SqlEmpty
defaultSqlTable :: SqlGenerator -> TableName -> Scheme -> SqlSelect
defaultSqlTable _ name schema = SqlTable name
defaultSqlProject :: SqlGenerator -> Assoc -> SqlSelect -> SqlSelect
defaultSqlProject gen assoc q
| all isAttr assoc && validSelect q =
let groupables = case groupableSqlColumns . attrs $ q of
[] -> Nothing
gs -> Just (Columns gs)
groupableSqlColumns :: [(SqlColumn,SqlExpr)] -> [(SqlColumn,SqlExpr)]
groupableSqlColumns = filter groupable
where
id2 _ t = t
const2 t _ _ = t
groupable (col, expr) = foldSqlExpr (const True
, (\ _ left right -> left || right)
, const2 False
, const2 False
, const2 True
, const2 False
, const False
, (\cs e -> and (map (uncurry (||)) cs) || e)
, and
, const False
, const2 False
, False
, id
, id2 ) expr
subst :: Assoc -> SqlSelect -> SqlSelect
subst outer query@(SqlSelect { attrs = cols
, criteria = crits
, groupby = gru
, orderby = order }) =
let colToAliases = Map.fromList [(column, alias) | (alias, AttrExpr column) <- outer]
getAlias column = case Map.lookup column colToAliases of
Just alias -> alias
_ -> column
substExpr = foldSqlExpr (ColumnSqlExpr . getAlias, BinSqlExpr, PrefixSqlExpr, PostfixSqlExpr
, FunSqlExpr, AggrFunSqlExpr, ConstSqlExpr, CaseSqlExpr
, ListSqlExpr, ExistsSqlExpr, ParamSqlExpr, PlaceHolderSqlExpr
, ParensSqlExpr,CastSqlExpr)
substGroup (Just (Columns cols)) = Just . Columns . map (\(col, expr) -> (getAlias col, expr)) $ cols
substGroup g = g
in query { attrs = map (\(currCol, expr) -> (getAlias currCol, expr)) cols
, criteria = map substExpr crits
, groupby = substGroup gru
, orderby = map (\(expr, ord) -> (substExpr expr, ord)) order }
in subst assoc (if hasGroupMark q
then q { groupby = groupables }
else q)
| hasAggr assoc || hasGroupMark newSelect =
let g = groupByColumns assoc newSelect
in if null g
then newSelect { groupby = Nothing }
else newSelect { groupby = Just (Columns g) }
| otherwise = newSelect
where
newSelect = (toSqlSelect q) { attrs = toSqlAssoc gen assoc }
hasAggr = not . null . filter (isAggregate . snd)
isAttr (_, AttrExpr _) = True
isAttr _ = False
validSelect SqlSelect { attrs = (_:_) } = True
validSelect _ = False
hasGroupMark (SqlSelect { groupby = Just All }) = True
hasGroupMark _ = False
groupByColumns assoc sql = toSqlAssoc gen (groupableProjections assoc) ++ groupableOrderCols sql
groupableProjections assoc = filter (not . (\x -> isAggregate x || isConstant x) . snd) assoc
groupableOrderCols sql =
let eligible = filter (\x -> case x of
(ColumnSqlExpr attr) -> True
_ -> False)
in [(s, e) | e@(ColumnSqlExpr s) <- eligible . map fst $ orderby sql]
defaultSqlGroup :: SqlGenerator -> Assoc -> SqlSelect -> SqlSelect
defaultSqlGroup _ _ q@(SqlSelect { groupby = Nothing }) = q { groupby = Just All }
defaultSqlGroup _ _ q = q
defaultSqlRestrict :: SqlGenerator -> PrimExpr -> SqlSelect -> SqlSelect
defaultSqlRestrict gen expr q
= sql { criteria = sqlExpr gen expr : criteria sql }
where
sql = toSqlSelect q
defaultSqlBinary :: SqlGenerator -> RelOp -> SqlSelect -> SqlSelect -> SqlSelect
defaultSqlBinary _ Times q1@(SqlSelect { }) q2@(SqlSelect { })
| null (attrs q1) = addTable q1 q2
| null (attrs q2) = addTable q2 q1
| otherwise = newSelect { tables = [("",q1),("",q2)] }
where
addTable sql q = sql{ tables = tables sql ++ [("",q)] }
defaultSqlBinary _ Times q1 q2 = newSelect { tables = [("", q1), ("", q2)] }
defaultSqlBinary _ op q1 q2
= SqlBin (toSqlOp op) q1 q2
defaultSqlSpecial :: SqlGenerator -> SpecialOp -> SqlSelect -> SqlSelect
defaultSqlSpecial gen (Order o) q
= sql { orderby = newOrder ++ oldOrder }
where
sql = toSqlSelect q
newOrder = map (toSqlOrder gen) o
oldOrder = orderby sql
defaultSqlSpecial _ (Top n) q
= sql { extra = ("LIMIT " ++ show n) : extra sql }
where sql = toSqlSelect q
toSqlOrder :: SqlGenerator -> OrderExpr -> (SqlExpr,SqlOrder)
toSqlOrder gen (OrderExpr o e) = (sqlExpr gen e, o')
where o' = case o of
OpAsc -> SqlAsc
OpDesc -> SqlDesc
toSqlSelect :: SqlSelect -> SqlSelect
toSqlSelect sql = case sql of
SqlEmpty -> newSelect
SqlTable name -> newSelect { tables = [("",sql)] }
SqlBin _ _ _ ->
let (prevGroup, newSql) = findGroup sql
findGroup (SqlBin op q1 q2) =
let (g1, q1') = findGroup q1
(g2, q2') = findGroup q2
in (g1 `or` g2, SqlBin op q1' q2')
findGroup q@(SqlSelect { groupby = Just (Columns _) }) = (Nothing, q)
findGroup q@(SqlSelect { groupby = Just All }) = (Just All, q { groupby = Nothing })
findGroup s = (Nothing, s)
or l r = maybe r Just l
in newSelect { tables = [("", newSql)]
, groupby = prevGroup }
SqlSelect { attrs = [] } -> sql
SqlSelect { groupby = Just (Columns _)} ->
newSelect { tables = [("", sql)] }
SqlSelect { groupby = group } ->
newSelect { tables = [("", sql { groupby = Nothing})]
, groupby = group }
toSqlAssoc :: SqlGenerator -> Assoc -> [(SqlColumn,SqlExpr)]
toSqlAssoc gen = map (\(attr,expr) -> (attr, sqlExpr gen expr))
toSqlOp :: RelOp -> String
toSqlOp Union = "UNION"
toSqlOp Intersect = "INTERSECT"
toSqlOp Divide = "DIVIDE"
toSqlOp Difference = "EXCEPT"
defaultSqlUpdate :: SqlGenerator
-> TableName
-> [PrimExpr]
-> Assoc
-> SqlUpdate
defaultSqlUpdate gen name criteria assigns
= SqlUpdate name (toSqlAssoc gen assigns) (map (sqlExpr gen) criteria)
defaultSqlInsert :: SqlGenerator
-> TableName
-> Assoc
-> SqlInsert
defaultSqlInsert gen table assoc = SqlInsert table cs es
where (cs,es) = unzip (toSqlAssoc gen assoc)
defaultSqlInsertQuery :: SqlGenerator
-> TableName
-> PrimQuery
-> SqlInsert
defaultSqlInsertQuery gen table q = SqlInsertQuery table cs sql
where cs = attributes q
sql = sqlQuery gen q
defaultSqlDelete :: SqlGenerator
-> TableName
-> [PrimExpr]
-> SqlDelete
defaultSqlDelete gen name criteria = SqlDelete name (map (sqlExpr gen) criteria)
defaultSqlCreateDB :: SqlGenerator
-> String
-> SqlCreate
defaultSqlCreateDB _ name = SqlCreateDB name
defaultSqlCreateTable :: SqlGenerator
-> TableName
-> [(Attribute,FieldDesc)]
-> SqlCreate
defaultSqlCreateTable gen name xs =
SqlCreateTable name [(cname, (sqlType gen t,nullable))
| (cname, (t,nullable)) <- xs]
defaultSqlDropDB :: SqlGenerator -> String -> SqlDrop
defaultSqlDropDB _ name = SqlDropDB name
defaultSqlDropTable :: SqlGenerator -> TableName -> SqlDrop
defaultSqlDropTable _ name = SqlDropTable name
defaultSqlExpr :: SqlGenerator -> PrimExpr -> SqlExpr
defaultSqlExpr gen e =
case e of
AttrExpr a -> ColumnSqlExpr a
BinExpr op e1 e2 ->
let leftE = sqlExpr gen e1
rightE = sqlExpr gen e2
paren = ParensSqlExpr
(expL, expR) = case (op, e1, e2) of
(OpAnd, e1@(BinExpr OpOr _ _), e2@(BinExpr OpOr _ _)) ->
(paren leftE, paren rightE)
(OpOr, e1@(BinExpr OpAnd _ _), e2@(BinExpr OpAnd _ _)) ->
(paren leftE, paren rightE)
(OpAnd, e1@(BinExpr OpOr _ _), e2) ->
(paren leftE, rightE)
(OpAnd, e1, e2@(BinExpr OpOr _ _)) ->
(leftE, paren rightE)
(OpOr, e1@(BinExpr OpAnd _ _), e2) ->
(paren leftE, rightE)
(OpOr, e1, e2@(BinExpr OpAnd _ _)) ->
(leftE, paren rightE)
_ -> (leftE, rightE)
in BinSqlExpr (showBinOp op) expL expR
UnExpr op e -> let (op',t) = sqlUnOp op
e' = sqlExpr gen e
in case t of
UnOpFun -> FunSqlExpr op' [e']
UnOpPrefix -> PrefixSqlExpr op' e'
UnOpPostfix -> PostfixSqlExpr op' e'
AggrExpr op e -> let op' = showAggrOp op
e' = sqlExpr gen e
in AggrFunSqlExpr op' [e']
ConstExpr l -> ConstSqlExpr (sqlLiteral gen l)
CaseExpr cs e -> let cs' = [(sqlExpr gen c, sqlExpr gen x)| (c,x) <- cs]
e' = sqlExpr gen e
in CaseSqlExpr cs' e'
ListExpr es -> ListSqlExpr (map (sqlExpr gen) es)
ParamExpr n v -> ParamSqlExpr n PlaceHolderSqlExpr
FunExpr n exprs -> FunSqlExpr n (map (sqlExpr gen) exprs)
CastExpr typ e1 -> CastSqlExpr typ (sqlExpr gen e1)
showBinOp :: BinOp -> String
showBinOp OpEq = "="
showBinOp OpLt = "<"
showBinOp OpLtEq = "<="
showBinOp OpGt = ">"
showBinOp OpGtEq = ">="
showBinOp OpNotEq = "<>"
showBinOp OpAnd = "AND"
showBinOp OpOr = "OR"
showBinOp OpLike = "LIKE"
showBinOp OpIn = "IN"
showBinOp (OpOther s) = s
showBinOp OpCat = "+"
showBinOp OpPlus = "+"
showBinOp OpMinus = "-"
showBinOp OpMul = "*"
showBinOp OpDiv = "/"
showBinOp OpMod = "MOD"
showBinOp OpBitNot = "~"
showBinOp OpBitAnd = "&"
showBinOp OpBitOr = "|"
showBinOp OpBitXor = "^"
showBinOp OpAsg = "="
data UnOpType = UnOpFun | UnOpPrefix | UnOpPostfix
sqlUnOp :: UnOp -> (String,UnOpType)
sqlUnOp OpNot = ("NOT", UnOpPrefix)
sqlUnOp OpIsNull = ("IS NULL", UnOpPostfix)
sqlUnOp OpIsNotNull = ("IS NOT NULL", UnOpPostfix)
sqlUnOp OpLength = ("LENGTH", UnOpFun)
sqlUnOp (UnOpOther s) = (s, UnOpFun)
showAggrOp :: AggrOp -> String
showAggrOp AggrCount = "COUNT"
showAggrOp AggrSum = "SUM"
showAggrOp AggrAvg = "AVG"
showAggrOp AggrMin = "MIN"
showAggrOp AggrMax = "MAX"
showAggrOp AggrStdDev = "StdDev"
showAggrOp AggrStdDevP = "StdDevP"
showAggrOp AggrVar = "Var"
showAggrOp AggrVarP = "VarP"
showAggrOp (AggrOther s) = s
defaultSqlLiteral :: SqlGenerator -> Literal -> String
defaultSqlLiteral gen l =
case l of
NullLit -> "NULL"
DefaultLit -> "DEFAULT"
BoolLit True -> "TRUE"
BoolLit False -> "FALSE"
StringLit s -> quote s
IntegerLit i -> show i
DoubleLit d -> show d
DateLit t -> quote (formatCalendarTime defaultTimeLocale fmt t)
where fmt = iso8601DateFormat (Just "%H:%M:%S")
OtherLit l -> l
defaultSqlQuote :: SqlGenerator -> String -> String
defaultSqlQuote gen s = quote s
quote :: String -> String
quote s = "'" ++ concatMap escape s ++ "'"
escape :: Char -> String
escape '\NUL' = "\\0"
escape '\'' = "''"
escape '"' = "\\\""
escape '\b' = "\\b"
escape '\n' = "\\n"
escape '\r' = "\\r"
escape '\t' = "\\t"
escape '\\' = "\\\\"
escape c = [c]