module Database.HaskellDB.Sql.Print (
ppSql,
ppUpdate,
ppDelete,
ppInsert,
ppCreate,
ppDrop,
ppSqlExpr
) where
import Database.HaskellDB.Sql
import Data.List (intersperse)
import Text.PrettyPrint.HughesPJ
ppSql :: SqlSelect -> Doc
ppSql (SqlSelect options attrs tables criteria groupby orderby extra)
= text "SELECT"
<+> hsep (map text options)
<+> ppAttrs attrs
$$ ppTables tables
$$ ppWhere criteria
$$ maybe empty ppGroupBy groupby
$$ ppOrderBy orderby
$$ hsep (map text extra)
ppSql (SqlBin op q1 q2) = parens (ppSql q1) $$ text op $$ parens (ppSql q2)
ppSql (SqlTable name) = text name
ppSql (SqlEmpty) = text ""
ppAttrs :: [(SqlColumn,SqlExpr)] -> Doc
ppAttrs [] = text "*"
ppAttrs xs = commaV nameAs xs
where
nameAs :: (SqlColumn,SqlExpr) -> Doc
nameAs (name, ColumnSqlExpr c) | name == c = text name
nameAs (name,expr) = ppAs name (ppSqlExpr expr)
ppTables :: [(SqlTable,SqlSelect)] -> Doc
ppTables [] = empty
ppTables ts = text "FROM" <+> commaV ppTable (zipWith tableAlias [1..] ts)
where
tableAlias :: Int -> (SqlTable,SqlSelect) -> (SqlTable,SqlSelect)
tableAlias i (_,sql) = ("T" ++ show i,sql)
ppTable :: (SqlTable,SqlSelect) -> Doc
ppTable (alias,(SqlTable name)) = ppAs alias (text name)
ppTable (alias,sql) = ppAs alias (parens (ppSql sql))
ppWhere :: [SqlExpr] -> Doc
ppWhere [] = empty
ppWhere es = text "WHERE"
<+> hsep (intersperse (text "AND") (map ppSqlExpr es))
ppGroupBy :: Mark -> Doc
ppGroupBy All = error "Should not ever print GroupBy all."
ppGroupBy (Columns es) = text "GROUP BY" <+> ppGroupAttrs es
where
ppGroupAttrs :: [(SqlColumn, SqlExpr)] -> Doc
ppGroupAttrs cs = commaV nameOrExpr cs
nameOrExpr :: (SqlColumn, SqlExpr) -> Doc
nameOrExpr (_, ColumnSqlExpr col) = text col
nameOrExpr (_, expr) = parens (ppSqlExpr expr)
ppOrderBy :: [(SqlExpr,SqlOrder)] -> Doc
ppOrderBy [] = empty
ppOrderBy ord = text "ORDER BY" <+> commaV ppOrd ord
where
ppOrd (e,o) = ppSqlExpr e <+> ppSqlOrder o
ppSqlOrder :: SqlOrder -> Doc
ppSqlOrder SqlAsc = text "ASC"
ppSqlOrder SqlDesc = text "DESC"
ppAs :: String -> Doc -> Doc
ppAs alias expr | null alias = expr
| otherwise = expr <+> (hsep . map text) ["as",alias]
ppUpdate :: SqlUpdate -> Doc
ppUpdate (SqlUpdate name assigns criteria)
= text "UPDATE" <+> text name
$$ text "SET" <+> commaV ppAssign assigns
$$ ppWhere criteria
where
ppAssign (c,e) = text c <+> equals <+> ppSqlExpr e
ppDelete :: SqlDelete -> Doc
ppDelete (SqlDelete name criteria) =
text "DELETE FROM" <+> text name $$ ppWhere criteria
ppInsert :: SqlInsert -> Doc
ppInsert (SqlInsert table names values)
= text "INSERT INTO" <+> text table
<+> parens (commaV text names)
$$ text "VALUES" <+> parens (commaV ppSqlExpr values)
ppInsert (SqlInsertQuery table names select)
= text "INSERT INTO" <+> text table
<+> parens (commaV text names)
$$ ppSql select
ppCreate :: SqlCreate -> Doc
ppCreate (SqlCreateDB name) = text "CREATE DATABASE" <+> text name
ppCreate (SqlCreateTable name xs)
= text "CREATE TABLE" <+> text name
<+> parens (commaV ppF xs)
where
ppF (fname,t) = text fname <+> ppSqlTypeNull t
ppSqlTypeNull :: (SqlType,Bool) -> Doc
ppSqlTypeNull (t,nullable) = ppSqlType t <+> text (if nullable then " null" else " not null")
ppSqlType :: SqlType -> Doc
ppSqlType (SqlType t) = text t
ppSqlType (SqlType1 t x) = text t <> parens (int x)
ppSqlType (SqlType2 t x y) = text t <> parens (commaH int [x,y])
ppDrop :: SqlDrop -> Doc
ppDrop (SqlDropDB name) = text "DROP DATABASE" <+> text name
ppDrop (SqlDropTable name) = text "DROP TABLE" <+> text name
ppSqlExpr :: SqlExpr -> Doc
ppSqlExpr e =
case e of
ColumnSqlExpr c -> text c
ParensSqlExpr e -> parens (ppSqlExpr e)
BinSqlExpr op e1 e2 -> ppSqlExpr e1 <+> text op <+> ppSqlExpr e2
PrefixSqlExpr op e -> text op <+> ppSqlExpr e
PostfixSqlExpr op e -> ppSqlExpr e <+> text op
FunSqlExpr f es -> text f <> parens (commaH ppSqlExpr es)
AggrFunSqlExpr f es -> text f <> parens (commaH ppSqlExpr es)
ConstSqlExpr c -> text c
CaseSqlExpr cs el -> text "CASE" <+> vcat (map ppWhen cs)
<+> text "ELSE" <+> ppSqlExpr el <+> text "END"
where ppWhen (w,t) = text "WHEN" <+> ppSqlExpr w
<+> text "THEN" <+> ppSqlExpr t
ListSqlExpr es -> parens (commaH ppSqlExpr es)
ExistsSqlExpr s -> text "EXISTS" <+> parens (ppSql s)
ParamSqlExpr n v -> ppSqlExpr v
PlaceHolderSqlExpr -> text "?"
CastSqlExpr typ expr -> text "CAST" <> parens (ppSqlExpr expr <+> text "AS" <+> text typ)
commaH :: (a -> Doc) -> [a] -> Doc
commaH f = hcat . punctuate comma . map f
commaV :: (a -> Doc) -> [a] -> Doc
commaV f = vcat . punctuate comma . map f