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,
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
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
}
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"
BStrT a -> SqlType1 "varchar" a
defaultSqlQuery :: SqlGenerator -> PrimQuery -> SqlSelect
defaultSqlQuery gen = foldPrimQuery (sqlEmpty gen,
sqlTable gen,
sqlProject gen,
sqlRestrict gen,
sqlBinary gen,
sqlGroup gen,
sqlSpecial gen)
defaultSqlEmpty :: SqlGenerator -> SqlSelect
defaultSqlEmpty _ = SqlEmpty
defaultSqlTable :: SqlGenerator -> TableName -> Scheme -> SqlSelect
defaultSqlTable _ name schema = SqlTable name
defaultSqlProject :: SqlGenerator -> Assoc -> SqlSelect -> SqlSelect
defaultSqlProject gen assoc q
| hasAggr = select { groupby = toSqlAssoc gen nonAggrs }
| otherwise = select
where
select = sql { attrs = toSqlAssoc gen assoc }
sql = toSqlSelect q
hasAggr = (not . null . filter (isAggregate . snd)) assoc
nonAggrs = filter (not . isAggregate . snd) assoc
defaultSqlGroup :: SqlGenerator -> Assoc -> SqlSelect -> SqlSelect
defaultSqlGroup gen cols select = select { groupby = toSqlAssoc gen cols }
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 q2
| 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 _ 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 op q1 q2) -> newSelect { tables = [("",sql)] }
s | null (attrs s) -> sql
| otherwise -> newSelect { tables = [("",sql)] }
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 -> BinSqlExpr (showBinOp op) (sqlExpr gen e1) (sqlExpr gen e2)
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 FunSqlExpr 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)
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
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]