haskelldb-0.12: src/Database/HaskellDB/Sql/Default.hs
-----------------------------------------------------------
-- |
-- Module : Database.HaskellDB.Sql.Default
-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl
-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
-- License : BSD-style
--
-- Maintainer : haskelldb-users@lists.sourceforge.net
-- Stability : experimental
-- Portability : non-portable
--
-- Default SQL generation.
--
-----------------------------------------------------------
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,
-- * Utilities
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
-----------------------------------------------------------
-- * Types
-----------------------------------------------------------
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
-----------------------------------------------------------
-- * SELECT
-----------------------------------------------------------
-- | Creates a 'SqlSelect' based on the 'PrimQuery' supplied.
-- Corresponds to the SQL statement SELECT.
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
-- | Takes all non-aggregate expressions in the select and adds them to
-- the 'group by' clause.
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
-- FIXME: what if they conflict?
-- The old version tried to fix that, but that
-- would only work partly
oldOrder = orderby sql
defaultSqlSpecial _ (Top n) q
-- FIXME: works for a few databases
-- maybe we should use ROW_NUMBER() here
= 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"
-----------------------------------------------------------
-- * UPDATE
-----------------------------------------------------------
-- | Creates a 'SqlUpdate'. Corresponds to the SQL statement
-- UPDATE which updates data in a table.
defaultSqlUpdate :: SqlGenerator
-> TableName -- ^ Name of the table to update.
-> [PrimExpr] -- ^ Conditions which must all be true for a row
-- to be updated.
-> Assoc -- ^ Update the data with this.
-> SqlUpdate
defaultSqlUpdate gen name criteria assigns
= SqlUpdate name (toSqlAssoc gen assigns) (map (sqlExpr gen) criteria)
-----------------------------------------------------------
-- * INSERT
-----------------------------------------------------------
-- | Creates a 'SqlInsert'.
defaultSqlInsert :: SqlGenerator
-> TableName -- ^ Name of the table
-> Assoc -- ^ What to insert.
-> SqlInsert
defaultSqlInsert gen table assoc = SqlInsert table cs es
where (cs,es) = unzip (toSqlAssoc gen assoc)
-- | Creates a 'SqlInsert'. Corresponds to the SQL statement
-- INSERT INTO which is used to insert new rows in a table.
defaultSqlInsertQuery :: SqlGenerator
-> TableName -- ^ Name of the table
-> PrimQuery -- ^ What to insert
-> SqlInsert
defaultSqlInsertQuery gen table q = SqlInsertQuery table cs sql
where cs = attributes q
sql = sqlQuery gen q
-----------------------------------------------------------
-- * DELETE
-----------------------------------------------------------
-- | Creates a 'SqlDelete'. Corresponds to the SQL statement
-- DELETE which deletes rows in a table.
defaultSqlDelete :: SqlGenerator
-> TableName -- ^ Name of the table
-> [PrimExpr] -- ^ Criteria which must all be true for a row
-- to be deleted.
-> SqlDelete
defaultSqlDelete gen name criteria = SqlDelete name (map (sqlExpr gen) criteria)
-----------------------------------------------------------
-- * CREATE
-----------------------------------------------------------
-- | Use this to create a 'SqlCreate' data type corresponding to
-- the SQL statement CREATE DATABASE which creates a new database.
defaultSqlCreateDB :: SqlGenerator
-> String -- ^ name of the database.
-> SqlCreate
defaultSqlCreateDB _ name = SqlCreateDB name
-- | Use this to create a 'SqlCreate' data type corresponding to
-- the SQL statement CREATE which creates a new table.
defaultSqlCreateTable :: SqlGenerator
-> TableName -- ^ name of the table to be created.
-> [(Attribute,FieldDesc)] -- ^ Column descriptions
-> SqlCreate
defaultSqlCreateTable gen name xs =
SqlCreateTable name [(cname, (sqlType gen t,nullable))
| (cname, (t,nullable)) <- xs]
-----------------------------------------------------------
-- * DROP
-----------------------------------------------------------
-- | Creates a 'SqlDrop' that delete the database with the
-- name given as the first argument.
defaultSqlDropDB :: SqlGenerator -> String -> SqlDrop
defaultSqlDropDB _ name = SqlDropDB name
-- | Creates a 'SqlDrop' that delete the database named
-- in the first argument.
defaultSqlDropTable :: SqlGenerator -> TableName -> SqlDrop
defaultSqlDropTable _ name = SqlDropTable name
-- * Expressions
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 a string and escape characters that need escaping
-- FIXME: this is backend dependent
quote :: String -> String
quote s = "'" ++ concatMap escape s ++ "'"
-- | Escape characters that need escaping
escape :: Char -> String
escape '\NUL' = "\\0"
escape '\'' = "''"
escape '"' = "\\\""
escape '\b' = "\\b"
escape '\n' = "\\n"
escape '\r' = "\\r"
escape '\t' = "\\t"
escape '\\' = "\\\\"
escape c = [c]