module Database.HaskellDB.PrintQuery
(ppQuery, ppQueryUnOpt
, ppSelect, ppSelectUnOpt, ppSqlSelect, ppPrim
, Database.HaskellDB.PrintQuery.ppSql, Database.HaskellDB.PrintQuery.ppSqlUnOpt)
where
import Database.HaskellDB.PrimQuery
import Database.HaskellDB.Sql
import Database.HaskellDB.Query (Query, runQuery, Rel)
import Database.HaskellDB.Optimize (optimize)
import Database.HaskellDB.Sql.Generate (sqlQuery)
import Database.HaskellDB.Sql.Default (defaultSqlGenerator)
import Database.HaskellDB.Sql.Print as Sql (ppSql)
import Text.PrettyPrint.HughesPJ
ppSql :: Query (Rel r) -> Doc
ppSql qry = Sql.ppSql . sqlQuery defaultSqlGenerator . optimize $ runQuery qry
ppSqlUnOpt :: Query (Rel r) -> Doc
ppSqlUnOpt qry = Sql.ppSql . sqlQuery defaultSqlGenerator $ runQuery qry
ppSelect :: Query (Rel r) -> Doc
ppSelect qry = ppPQ (sqlQuery defaultSqlGenerator) optimize (runQuery $ qry)
ppSelectUnOpt :: Query (Rel r) -> Doc
ppSelectUnOpt qry = ppPQ (sqlQuery defaultSqlGenerator) id (runQuery $ qry)
ppQuery :: Query (Rel r) -> Doc
ppQuery qry = ppPrimF optimize (runQuery $ qry)
ppQueryUnOpt :: Query (Rel r) -> Doc
ppQueryUnOpt qry = ppPrimF id (runQuery $ qry)
ppPrim :: PrimQuery -> Doc
ppPrim = ppPrimF id
ppPrimF :: (PrimQuery -> PrimQuery)
-> PrimQuery
-> Doc
ppPrimF f qry = ppPrimF' (f qry)
where
ppPrimF' (BaseTable tableName scheme) =
hang (text "BaseTable" <> colon <+> text tableName)
nesting
(brackets (fsep $ punctuate comma (map text scheme)))
ppPrimF' (Project assoc primQuery) =
hang (text "Project")
nesting (brackets (ppAssoc assoc) $+$
parens (ppPrimF' primQuery))
ppPrimF' (Restrict primExpr primQuery) =
hang (text "Restrict")
nesting
(ppExpr primExpr $+$ ppPrimF' primQuery)
ppPrimF' (Group assoc primQuery) =
hang (text "Group")
nesting
(brackets (ppAssoc assoc) $+$
parens (ppPrimF' primQuery))
ppPrimF' (Binary relOp primQueryL primQueryR) =
hang (text "Binary:" <+> text (show relOp))
nesting
(parens (ppPrimF' primQueryL) $+$
parens (ppPrimF' primQueryR))
ppPrimF' (Special specialOp primQuery) =
hang (text "Special:" <+> text (show specialOp))
nesting
(parens (ppPrimF' primQuery))
ppPrimF' Empty = text "Empty"
ppAssoc :: Assoc -> Doc
ppAssoc assoc = fsep . punctuate comma . map (\(a, e) -> text a <> colon <+> ppExpr e) $ assoc
ppExpr :: PrimExpr -> Doc
ppExpr = text . show
ppPQ :: (PrimQuery -> SqlSelect)
-> (PrimQuery -> PrimQuery)
-> PrimQuery
-> Doc
ppPQ select trans prim = ppSqlSelect . select . trans $ prim
ppSqlSelect :: SqlSelect -> Doc
ppSqlSelect (SqlBin string sqlSelectL sqlSelectR) =
hang (text "SqlBin:" <+> text string) nesting
(parens (ppSqlSelect sqlSelectL) $+$
parens (ppSqlSelect sqlSelectR))
ppSqlSelect (SqlTable sqlTable) = text "SqlTable:" <+> text sqlTable
ppSqlSelect SqlEmpty = text "SqlEmpty"
ppSqlSelect (SqlSelect options attrs tables criteria groupby orderby extra) =
hang (text "SqlSelect") nesting $
hang (text "attrs:") nesting (brackets . fsep . punctuate comma . map ppAttr $ attrs) $+$
text "criteria:" <+> (brackets . fsep . punctuate comma . map ppSqlExpr $ criteria) $+$
hang (text "tables:") nesting (brackets . fsep . punctuate comma . map ppTable $ tables) $+$
maybe (text "groupby: empty") ppGroupBy groupby $+$
hang (text "orderby:") nesting (brackets . fsep . punctuate comma . map ppOrder $ orderby) $+$
text "extras:" <+> (brackets . fsep. punctuate comma . map text $ extra) $+$
text "options:" <+> (brackets . fsep . punctuate comma . map text $ options)
ppGroupBy All = text "groupby: all"
ppGroupBy (Columns cs) = hang (text "groupby:") nesting (brackets . fsep . punctuate comma . map ppAttr $ cs)
ppTable :: (SqlTable, SqlSelect) -> Doc
ppTable (tbl, select) =
if null tbl
then ppSqlSelect select
else hang (text tbl <> colon) nesting (ppSqlSelect select)
ppAttr :: (SqlColumn, SqlExpr) -> Doc
ppAttr (col, expr) = text col <> colon <+> ppSqlExpr expr
ppOrder :: (SqlExpr, SqlOrder) -> Doc
ppOrder (expr, order) = parens (ppSqlExpr expr) <+> text (show order)
ppSqlExpr :: SqlExpr -> Doc
ppSqlExpr sql = text $ show sql
nesting :: Int
nesting = 2