----------------------------------------------------------- -- | -- 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, defaultSqlQuote, -- * 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 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 ----------------------------------------------------------- -- * 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 with time zone" LocalTimeT -> SqlType "timestamp without time zone" 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 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 -- This mess ensures we do not create another layer of SELECT when -- dealing with GROUP BY phrases. If the select being built is a -- real select (not a table or binary operation) and all columns to -- be projected are just attributes (i.e., they copy column names -- but do no computation), then we do not need to create another -- layer of SELECT. We will re-use the existing select. | all isAttr assoc && validSelect q = let groupables = case groupableSqlColumns . attrs $ q of [] -> Nothing gs -> Just (Columns gs) -- Looks at SqlSelect columns and determines if they need to -- be grouped. Not the sames as groupableProjects because this -- operates on values from a SqlSelect, not PrimQuery. groupableSqlColumns :: [(SqlColumn,SqlExpr)] -> [(SqlColumn,SqlExpr)] groupableSqlColumns = filter groupable where id2 _ t = t const2 t _ _ = t -- determine if a sql expression should be -- placed in a group by clause. Only columns, non-aggregate -- functions and expressions involving either are -- groupable. Constants are not groupable. If an expression -- contains any groupable values, then whole expression is groupable. groupable (col, expr) = foldSqlExpr (const True -- column , (\ _ left right -> left || right) -- binary , const2 False -- PrefixSqlExpr , const2 False -- PostfixSqlExpr , const2 True -- FunSqlExpr , const2 False -- AggrFunSqlExpr , const False -- ConstSqlExpr , (\cs e -> and (map (uncurry (||)) cs) || e) -- CaseSqlExpr , and -- ListSqlExpr , const False -- ExistsSqlExpr , const2 False -- ParamSqlExpr , False -- PlaceHolderSqlExpr , id -- ParensSqlExpr , id2 {- CastSqlExpr -}) expr -- Rename projected columns in -- a select. Since we did not create another -- layer of SELECT, we have to propogate the association list -- provided into the current query, or it will not create columns -- with the right names. We only go one level - no need to recursively -- descend into all queries luckily. subst :: Assoc -> SqlSelect -> SqlSelect subst outer query@(SqlSelect { attrs = cols , criteria = crits , groupby = gru , orderby = order }) = -- map attributes to their aliased columns. 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 -- replace attributes with alias from outer query 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 -- A groupMark indicates the select wants to group -- on "all" columns. We replace the mark with the -- list of groupable columns. then q { groupby = groupables } -- Otherwise, we just re-use the query without -- changing it (modulo substitutions). 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 -- Find projected columns that are not constants or aggregates. groupableProjections assoc = filter (not . (\x -> isAggregate x || isConstant x) . snd) assoc -- Get list of order by columns which do not appear in -- projected non-aggregate columns already, if any. groupableOrderCols sql = let eligible = filter (\x -> case x of (ColumnSqlExpr attr) -> True _ -> False) in [(s, e) | e@(ColumnSqlExpr s) <- eligible . map fst $ orderby sql] -- | Ensures the groupby value on the SqlSelect either preserves existing -- grouping or that it will group on all columns (i.e, Mark == All). 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 -- 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 -- | Make sure our SqlSelect statement is really a SqlSelect and not -- another constructor. toSqlSelect :: SqlSelect -> SqlSelect toSqlSelect sql = case sql of SqlEmpty -> newSelect SqlTable name -> newSelect { tables = [("",sql)] } -- Below we make sure to bring groupby marks that have not -- been processed up the tree. The mark moves up the tree -- for efficiency. A "Columns" mark does not move -- it indicates -- a select that will use a group by. An All mark does move, as it -- needs to find its containing projection. Marks that move are -- replaced by Nothing. 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 -- Here we have a mark that should not move. SqlSelect { groupby = Just (Columns _)} -> newSelect { tables = [("", sql)] } -- Any mark here should be moved. Notice we set the -- previous mark with Nothing (though it may already be -- Nothing). 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" ----------------------------------------------------------- -- * 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 -> 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 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]