------------------------------------------------------------- |-- 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.-- -----------------------------------------------------------moduleDatabase.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,-- * UtilitiestoSqlSelect)whereimportData.List(intersect)importDatabase.HaskellDB.PrimQueryimportDatabase.HaskellDB.FieldTypeimportDatabase.HaskellDB.SqlimportDatabase.HaskellDB.Sql.GenerateimportSystem.LocaleimportSystem.TimeimportData.Maybe(catMaybes)importData.List(nubBy)importqualifiedData.MapasMap(fromList,lookup)mkSqlGenerator::SqlGenerator->SqlGeneratormkSqlGeneratorgen=SqlGenerator{sqlQuery=defaultSqlQuerygen,sqlUpdate=defaultSqlUpdategen,sqlDelete=defaultSqlDeletegen,sqlInsert=defaultSqlInsertgen,sqlInsertQuery=defaultSqlInsertQuerygen,sqlCreateDB=defaultSqlCreateDBgen,sqlCreateTable=defaultSqlCreateTablegen,sqlDropDB=defaultSqlDropDBgen,sqlDropTable=defaultSqlDropTablegen,sqlEmpty=defaultSqlEmptygen,sqlTable=defaultSqlTablegen,sqlProject=defaultSqlProjectgen,sqlRestrict=defaultSqlRestrictgen,sqlBinary=defaultSqlBinarygen,sqlGroup=defaultSqlGroupgen,sqlSpecial=defaultSqlSpecialgen,sqlExpr=defaultSqlExprgen,sqlLiteral=defaultSqlLiteralgen,sqlType=defaultSqlTypegen,sqlQuote=defaultSqlQuotegen}defaultSqlGenerator::SqlGeneratordefaultSqlGenerator=mkSqlGeneratordefaultSqlGenerator------------------------------------------------------------- * Types-----------------------------------------------------------defaultSqlType::SqlGenerator->FieldType->SqlTypedefaultSqlType_t=casetofStringT->SqlType"text"IntT->SqlType"int"IntegerT->SqlType"bigint"DoubleT->SqlType"double precision"BoolT->SqlType"bit"CalendarTimeT->SqlType"timestamp with time zone"BStrTa->SqlType1"varchar"a------------------------------------------------------------- * SELECT------------------------------------------------------------- | Creates a 'SqlSelect' based on the 'PrimQuery' supplied.-- Corresponds to the SQL statement SELECT.defaultSqlQuery::SqlGenerator->PrimQuery->SqlSelectdefaultSqlQuerygenquery=foldPrimQuery(sqlEmptygen,sqlTablegen,sqlProjectgen,sqlRestrictgen,sqlBinarygen,sqlGroupgen,sqlSpecialgen)querydefaultSqlEmpty::SqlGenerator->SqlSelectdefaultSqlEmpty_=SqlEmptydefaultSqlTable::SqlGenerator->TableName->Scheme->SqlSelectdefaultSqlTable_nameschema=SqlTablenamedefaultSqlProject::SqlGenerator->Assoc->SqlSelect->SqlSelectdefaultSqlProjectgenassocq-- 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.|allisAttrassoc&&validSelectq=letgroupables=casegroupableSqlColumns.attrs$qof[]->Nothinggs->Just(Columnsgs)-- 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=filtergroupablewhereid2_t=tconst2t__=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(constTrue-- column,(\_leftright->left||right)-- binary,const2False-- PrefixSqlExpr ,const2False-- PostfixSqlExpr,const2True-- FunSqlExpr,const2False-- AggrFunSqlExpr,constFalse-- ConstSqlExpr,(\cse->and(map(uncurry(||))cs)||e)-- CaseSqlExpr,and-- ListSqlExpr,constFalse-- ExistsSqlExpr,const2False-- 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->SqlSelectsubstouterquery@(SqlSelect{attrs=cols,criteria=crits,groupby=gru,orderby=order})=-- map attributes to their aliased columns.letcolToAliases=Map.fromList[(column,alias)|(alias,AttrExprcolumn)<-outer]getAliascolumn=caseMap.lookupcolumncolToAliasesofJustalias->alias_->columnsubstExpr=foldSqlExpr(ColumnSqlExpr.getAlias,BinSqlExpr,PrefixSqlExpr,PostfixSqlExpr,FunSqlExpr,AggrFunSqlExpr,ConstSqlExpr,CaseSqlExpr,ListSqlExpr,ExistsSqlExpr,ParamSqlExpr,PlaceHolderSqlExpr,ParensSqlExpr,CastSqlExpr)substGroup(Just(Columnscols))=Just.Columns.map(\(col,expr)->(getAliascol,expr))$colssubstGroupg=g-- replace attributes with alias from outer query inquery{attrs=map(\(currCol,expr)->(getAliascurrCol,expr))cols,criteria=mapsubstExprcrits,groupby=substGroupgru,orderby=map(\(expr,ord)->(substExprexpr,ord))order}insubstassoc(ifhasGroupMarkq-- A groupMark indicates the select wants to group-- on "all" columns. We replace the mark with the-- list of groupable columns. thenq{groupby=groupables}-- Otherwise, we just re-use the query without-- changing it (modulo substitutions).elseq)|hasAggrassoc||hasGroupMarknewSelect=letg=groupByColumnsassocnewSelectinifnullgthennewSelect{groupby=Nothing}elsenewSelect{groupby=Just(Columnsg)}|otherwise=newSelectwherenewSelect=(toSqlSelectq){attrs=toSqlAssocgenassoc}hasAggr=not.null.filter(isAggregate.snd)isAttr(_,AttrExpr_)=TrueisAttr_=FalsevalidSelectSqlSelect{attrs=(_:_)}=TruevalidSelect_=FalsehasGroupMark(SqlSelect{groupby=JustAll})=TruehasGroupMark_=FalsegroupByColumnsassocsql=toSqlAssocgen(groupableProjectionsassoc)++groupableOrderColssql-- Find projected columns that are not constants or aggregates.groupableProjectionsassoc=filter(not.(\x->isAggregatex||isConstantx).snd)assoc-- Get list of order by columns which do not appear in-- projected non-aggregate columns already, if any.groupableOrderColssql=leteligible=filter(\x->casexof(ColumnSqlExprattr)->True_->False)in[(s,e)|e@(ColumnSqlExprs)<-eligible.mapfst$orderbysql]-- | 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->SqlSelectdefaultSqlGroup__q@(SqlSelect{groupby=Nothing})=q{groupby=JustAll}defaultSqlGroup__q=qdefaultSqlRestrict::SqlGenerator->PrimExpr->SqlSelect->SqlSelectdefaultSqlRestrictgenexprq=sql{criteria=sqlExprgenexpr:criteriasql}wheresql=toSqlSelectqdefaultSqlBinary::SqlGenerator->RelOp->SqlSelect->SqlSelect->SqlSelectdefaultSqlBinary_Timesq1@(SqlSelect{})q2@(SqlSelect{})|null(attrsq1)=addTableq1q2|null(attrsq2)=addTableq2q1|otherwise=newSelect{tables=[("",q1),("",q2)]}whereaddTablesqlq=sql{tables=tablessql++[("",q)]}defaultSqlBinary_Timesq1q2=newSelect{tables=[("",q1),("",q2)]}defaultSqlBinary_opq1q2=SqlBin(toSqlOpop)q1q2defaultSqlSpecial::SqlGenerator->SpecialOp->SqlSelect->SqlSelectdefaultSqlSpecialgen(Ordero)q=sql{orderby=newOrder++oldOrder}wheresql=toSqlSelectqnewOrder=map(toSqlOrdergen)o-- FIXME: what if they conflict?-- The old version tried to fix that, but that-- would only work partlyoldOrder=orderbysqldefaultSqlSpecial_(Topn)q-- FIXME: works for a few databases-- maybe we should use ROW_NUMBER() here=sql{extra=("LIMIT "++shown):extrasql}wheresql=toSqlSelectqtoSqlOrder::SqlGenerator->OrderExpr->(SqlExpr,SqlOrder)toSqlOrdergen(OrderExproe)=(sqlExprgene,o')whereo'=caseoofOpAsc->SqlAscOpDesc->SqlDesc-- | Make sure our SqlSelect statement is really a SqlSelect and not-- another constructor.toSqlSelect::SqlSelect->SqlSelecttoSqlSelectsql=casesqlofSqlEmpty->newSelectSqlTablename->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)=findGroupsqlfindGroup(SqlBinopq1q2)=let(g1,q1')=findGroupq1(g2,q2')=findGroupq2in(g1`or`g2,SqlBinopq1'q2')findGroupq@(SqlSelect{groupby=Just(Columns_)})=(Nothing,q)findGroupq@(SqlSelect{groupby=JustAll})=(JustAll,q{groupby=Nothing})findGroups=(Nothing,s)orlr=mayberJustlinnewSelect{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)]toSqlAssocgen=map(\(attr,expr)->(attr,sqlExprgenexpr))toSqlOp::RelOp->StringtoSqlOpUnion="UNION"toSqlOpIntersect="INTERSECT"toSqlOpDivide="DIVIDE"toSqlOpDifference="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.->SqlUpdatedefaultSqlUpdategennamecriteriaassigns=SqlUpdatename(toSqlAssocgenassigns)(map(sqlExprgen)criteria)------------------------------------------------------------- * INSERT------------------------------------------------------------- | Creates a 'SqlInsert'. defaultSqlInsert::SqlGenerator->TableName-- ^ Name of the table->Assoc-- ^ What to insert.->SqlInsertdefaultSqlInsertgentableassoc=SqlInserttablecseswhere(cs,es)=unzip(toSqlAssocgenassoc)-- | 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->SqlInsertdefaultSqlInsertQuerygentableq=SqlInsertQuerytablecssqlwherecs=attributesqsql=sqlQuerygenq------------------------------------------------------------- * 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.->SqlDeletedefaultSqlDeletegennamecriteria=SqlDeletename(map(sqlExprgen)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.->SqlCreatedefaultSqlCreateDB_name=SqlCreateDBname-- | 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->SqlCreatedefaultSqlCreateTablegennamexs=SqlCreateTablename[(cname,(sqlTypegent,nullable))|(cname,(t,nullable))<-xs]------------------------------------------------------------- * DROP------------------------------------------------------------- | Creates a 'SqlDrop' that delete the database with the -- name given as the first argument.defaultSqlDropDB::SqlGenerator->String->SqlDropdefaultSqlDropDB_name=SqlDropDBname-- | Creates a 'SqlDrop' that delete the database named-- in the first argument.defaultSqlDropTable::SqlGenerator->TableName->SqlDropdefaultSqlDropTable_name=SqlDropTablename-- * ExpressionsdefaultSqlExpr::SqlGenerator->PrimExpr->SqlExprdefaultSqlExprgene=caseeofAttrExpra->ColumnSqlExpraBinExprope1e2->letleftE=sqlExprgene1rightE=sqlExprgene2paren=ParensSqlExpr(expL,expR)=case(op,e1,e2)of(OpAnd,e1@(BinExprOpOr__),e2@(BinExprOpOr__))->(parenleftE,parenrightE)(OpOr,e1@(BinExprOpAnd__),e2@(BinExprOpAnd__))->(parenleftE,parenrightE)(OpAnd,e1@(BinExprOpOr__),e2)->(parenleftE,rightE)(OpAnd,e1,e2@(BinExprOpOr__))->(leftE,parenrightE)(OpOr,e1@(BinExprOpAnd__),e2)->(parenleftE,rightE)(OpOr,e1,e2@(BinExprOpAnd__))->(leftE,parenrightE)_->(leftE,rightE)inBinSqlExpr(showBinOpop)expLexpRUnExprope->let(op',t)=sqlUnOpope'=sqlExprgeneincasetofUnOpFun->FunSqlExprop'[e']UnOpPrefix->PrefixSqlExprop'e'UnOpPostfix->PostfixSqlExprop'e'AggrExprope->letop'=showAggrOpope'=sqlExprgeneinAggrFunSqlExprop'[e']ConstExprl->ConstSqlExpr(sqlLiteralgenl)CaseExprcse->letcs'=[(sqlExprgenc,sqlExprgenx)|(c,x)<-cs]e'=sqlExprgeneinCaseSqlExprcs'e'ListExpres->ListSqlExpr(map(sqlExprgen)es)ParamExprnv->ParamSqlExprnPlaceHolderSqlExprFunExprnexprs->FunSqlExprn(map(sqlExprgen)exprs)CastExprtype1->CastSqlExprtyp(sqlExprgene1)showBinOp::BinOp->StringshowBinOpOpEq="="showBinOpOpLt="<"showBinOpOpLtEq="<="showBinOpOpGt=">"showBinOpOpGtEq=">="showBinOpOpNotEq="<>"showBinOpOpAnd="AND"showBinOpOpOr="OR"showBinOpOpLike="LIKE"showBinOpOpIn="IN"showBinOp(OpOthers)=sshowBinOpOpCat="+"showBinOpOpPlus="+"showBinOpOpMinus="-"showBinOpOpMul="*"showBinOpOpDiv="/"showBinOpOpMod="MOD"showBinOpOpBitNot="~"showBinOpOpBitAnd="&"showBinOpOpBitOr="|"showBinOpOpBitXor="^"showBinOpOpAsg="="dataUnOpType=UnOpFun|UnOpPrefix|UnOpPostfixsqlUnOp::UnOp->(String,UnOpType)sqlUnOpOpNot=("NOT",UnOpPrefix)sqlUnOpOpIsNull=("IS NULL",UnOpPostfix)sqlUnOpOpIsNotNull=("IS NOT NULL",UnOpPostfix)sqlUnOpOpLength=("LENGTH",UnOpFun)sqlUnOp(UnOpOthers)=(s,UnOpFun)showAggrOp::AggrOp->StringshowAggrOpAggrCount="COUNT"showAggrOpAggrSum="SUM"showAggrOpAggrAvg="AVG"showAggrOpAggrMin="MIN"showAggrOpAggrMax="MAX"showAggrOpAggrStdDev="StdDev"showAggrOpAggrStdDevP="StdDevP"showAggrOpAggrVar="Var"showAggrOpAggrVarP="VarP"showAggrOp(AggrOthers)=sdefaultSqlLiteral::SqlGenerator->Literal->StringdefaultSqlLiteralgenl=caselofNullLit->"NULL"DefaultLit->"DEFAULT"BoolLitTrue->"TRUE"BoolLitFalse->"FALSE"StringLits->quotesIntegerLiti->showiDoubleLitd->showdDateLitt->quote(formatCalendarTimedefaultTimeLocalefmtt)wherefmt=iso8601DateFormat(Just"%H:%M:%S")OtherLitl->ldefaultSqlQuote::SqlGenerator->String->StringdefaultSqlQuotegens=quotes-- | Quote a string and escape characters that need escaping-- FIXME: this is backend dependentquote::String->Stringquotes="'"++concatMapescapes++"'"-- | Escape characters that need escapingescape::Char->Stringescape'\NUL'="\\0"escape'\''="''"escape'"'="\\\""escape'\b'="\\b"escape'\n'="\\n"escape'\r'="\\r"escape'\t'="\\t"escape'\\'="\\\\"escapec=[c]