-- Copyright   :  Daan Leijen (c) 1999, daan@cs.uu.nl
--                HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
-- License     :  BSD-style

module Opaleye.SQLite.Internal.HaskellDB.Sql.Print (
                                     deliteral,
                                     ppUpdate,
                                     ppDelete,
                                     ppInsert,
                                     ppSqlExpr,
                                     ppWhere,
                                     ppGroupBy,
                                     ppOrderBy,
                                     ppTable,
                                     ppAs,
                                     commaV,
                                     commaH
                                    ) where

import Prelude hiding ((<>))
import Opaleye.SQLite.Internal.HaskellDB.Sql (SqlColumn(..), SqlDelete(..),
                               SqlExpr(..), SqlOrder(..), SqlInsert(..),
                               SqlUpdate(..), SqlTable(..))
import qualified Opaleye.SQLite.Internal.HaskellDB.Sql as Sql

import Data.List (intersperse)
import qualified Data.List.NonEmpty as NEL
import Text.PrettyPrint.HughesPJ (Doc, (<+>), ($$), (<>), comma, doubleQuotes,
                                  empty, equals, hcat, hsep, parens, punctuate,
                                  text, vcat)

-- Silliness to avoid "ORDER BY 1" etc. meaning order by the first column
-- Any identity function will do
deliteral :: SqlExpr -> SqlExpr
deliteral :: SqlExpr -> SqlExpr
deliteral c :: SqlExpr
c@(ColumnSqlExpr (SqlColumn String
_)) = SqlExpr
c
deliteral SqlExpr
expr = String -> [SqlExpr] -> SqlExpr
FunSqlExpr String
"COALESCE" [SqlExpr
expr, SqlExpr
expr]

ppWhere :: [SqlExpr] -> Doc
ppWhere :: [SqlExpr] -> Doc
ppWhere [] = Doc
empty
ppWhere [SqlExpr]
es = String -> Doc
text String
"WHERE"
             Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text String
"AND")
                       ((SqlExpr -> Doc) -> [SqlExpr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
parens (Doc -> Doc) -> (SqlExpr -> Doc) -> SqlExpr -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlExpr -> Doc
ppSqlExpr) [SqlExpr]
es))

ppGroupBy :: [SqlExpr] -> Doc
ppGroupBy :: [SqlExpr] -> Doc
ppGroupBy [SqlExpr]
es = String -> Doc
text String
"GROUP BY" Doc -> Doc -> Doc
<+> [SqlExpr] -> Doc
ppGroupAttrs [SqlExpr]
es
  where
    ppGroupAttrs :: [SqlExpr] -> Doc
    ppGroupAttrs :: [SqlExpr] -> Doc
ppGroupAttrs [SqlExpr]
cs = (SqlExpr -> Doc) -> [SqlExpr] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaV (SqlExpr -> Doc
ppSqlExpr (SqlExpr -> Doc) -> (SqlExpr -> SqlExpr) -> SqlExpr -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlExpr -> SqlExpr
deliteral) [SqlExpr]
cs

ppOrderBy :: [(SqlExpr,SqlOrder)] -> Doc
ppOrderBy :: [(SqlExpr, SqlOrder)] -> Doc
ppOrderBy [] = Doc
empty
ppOrderBy [(SqlExpr, SqlOrder)]
ord = String -> Doc
text String
"ORDER BY" Doc -> Doc -> Doc
<+> ((SqlExpr, SqlOrder) -> Doc) -> [(SqlExpr, SqlOrder)] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaV (SqlExpr, SqlOrder) -> Doc
ppOrd [(SqlExpr, SqlOrder)]
ord
    where
    -- Silliness to avoid "ORDER BY 1" etc. meaning order by the first column
    -- Any identity function will do
    --   ppOrd (e,o) = ppSqlExpr e <+> ppSqlDirection o <+> ppSqlNulls o
      ppOrd :: (SqlExpr, SqlOrder) -> Doc
ppOrd (SqlExpr
e,SqlOrder
o) = SqlExpr -> Doc
ppSqlExpr (SqlExpr -> SqlExpr
deliteral SqlExpr
e)
                      Doc -> Doc -> Doc
<+> SqlOrder -> Doc
ppSqlDirection SqlOrder
o
                      Doc -> Doc -> Doc
<+> SqlOrder -> Doc
ppSqlNulls SqlOrder
o

ppSqlDirection :: Sql.SqlOrder -> Doc
ppSqlDirection :: SqlOrder -> Doc
ppSqlDirection SqlOrder
x = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ case SqlOrder -> SqlOrderDirection
Sql.sqlOrderDirection SqlOrder
x of
  SqlOrderDirection
Sql.SqlAsc  -> String
"ASC"
  SqlOrderDirection
Sql.SqlDesc -> String
"DESC"

-- FIXME: We haven't implemented NULL ordering properly
ppSqlNulls :: Sql.SqlOrder -> Doc
ppSqlNulls :: SqlOrder -> Doc
ppSqlNulls SqlOrder
_ = Doc
empty
--ppSqlNulls x = text $ case Sql.sqlOrderNulls x of
--        Sql.SqlNullsFirst -> "NULLS FIRST"
--        Sql.SqlNullsLast  -> "NULLS LAST"

ppAs :: String -> Doc -> Doc
ppAs :: String -> Doc -> Doc
ppAs String
alias Doc
expr    | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
alias    = Doc
expr
                   | Bool
otherwise     = Doc
expr Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep [String -> Doc
text String
"as", Doc -> Doc
doubleQuotes (String -> Doc
text String
alias)]


ppUpdate :: SqlUpdate -> Doc
ppUpdate :: SqlUpdate -> Doc
ppUpdate (SqlUpdate SqlTable
table [(SqlColumn, SqlExpr)]
assigns [SqlExpr]
criteria)
        = String -> Doc
text String
"UPDATE" Doc -> Doc -> Doc
<+> SqlTable -> Doc
ppTable SqlTable
table
        Doc -> Doc -> Doc
$$ String -> Doc
text String
"SET" Doc -> Doc -> Doc
<+> ((SqlColumn, SqlExpr) -> Doc) -> [(SqlColumn, SqlExpr)] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaV (SqlColumn, SqlExpr) -> Doc
ppAssign [(SqlColumn, SqlExpr)]
assigns
        Doc -> Doc -> Doc
$$ [SqlExpr] -> Doc
ppWhere [SqlExpr]
criteria
    where
      ppAssign :: (SqlColumn, SqlExpr) -> Doc
ppAssign (SqlColumn
c,SqlExpr
e) = SqlColumn -> Doc
ppColumn SqlColumn
c Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> SqlExpr -> Doc
ppSqlExpr SqlExpr
e


ppDelete :: SqlDelete -> Doc
ppDelete :: SqlDelete -> Doc
ppDelete (SqlDelete SqlTable
table [SqlExpr]
criteria) =
    String -> Doc
text String
"DELETE FROM" Doc -> Doc -> Doc
<+> SqlTable -> Doc
ppTable SqlTable
table Doc -> Doc -> Doc
$$ [SqlExpr] -> Doc
ppWhere [SqlExpr]
criteria


ppInsert :: SqlInsert -> Doc
ppInsert :: SqlInsert -> Doc
ppInsert (SqlInsert SqlTable
table [SqlColumn]
names NonEmpty [SqlExpr]
values)
    = String -> Doc
text String
"INSERT INTO" Doc -> Doc -> Doc
<+> SqlTable -> Doc
ppTable SqlTable
table
      Doc -> Doc -> Doc
<+> Doc -> Doc
parens ((SqlColumn -> Doc) -> [SqlColumn] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaV SqlColumn -> Doc
ppColumn [SqlColumn]
names)
      Doc -> Doc -> Doc
$$ String -> Doc
text String
"VALUES" Doc -> Doc -> Doc
<+> ([SqlExpr] -> Doc) -> [[SqlExpr]] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaV (\[SqlExpr]
v -> Doc -> Doc
parens ((SqlExpr -> Doc) -> [SqlExpr] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaV SqlExpr -> Doc
ppSqlExpr [SqlExpr]
v))
                                  (NonEmpty [SqlExpr] -> [[SqlExpr]]
forall a. NonEmpty a -> [a]
NEL.toList NonEmpty [SqlExpr]
values)

-- If we wanted to make the SQL slightly more readable this would be
-- one easy place to do it.  Currently we wrap all column references
-- in double quotes in case they are keywords.  However, we should be
-- sure that any column names we generate ourselves are not keywords,
-- so we only need to double quote base table column names.
ppColumn :: SqlColumn -> Doc
ppColumn :: SqlColumn -> Doc
ppColumn (SqlColumn String
s) = Doc -> Doc
doubleQuotes (String -> Doc
text String
s)

-- Postgres treats upper case letters in table names as lower case,
-- unless the name is quoted!
ppTable :: SqlTable -> Doc
ppTable :: SqlTable -> Doc
ppTable (SqlTable String
s) = Doc -> Doc
doubleQuotes (String -> Doc
text String
s)

ppSqlExpr :: SqlExpr -> Doc
ppSqlExpr :: SqlExpr -> Doc
ppSqlExpr SqlExpr
expr =
    case SqlExpr
expr of
      ColumnSqlExpr SqlColumn
c     -> SqlColumn -> Doc
ppColumn SqlColumn
c
      ParensSqlExpr SqlExpr
e -> Doc -> Doc
parens (SqlExpr -> Doc
ppSqlExpr SqlExpr
e)
      BinSqlExpr String
op SqlExpr
e1 SqlExpr
e2 -> SqlExpr -> Doc
ppSqlExpr SqlExpr
e1 Doc -> Doc -> Doc
<+> String -> Doc
text String
op Doc -> Doc -> Doc
<+> SqlExpr -> Doc
ppSqlExpr SqlExpr
e2
      PrefixSqlExpr String
op SqlExpr
e  -> String -> Doc
text String
op Doc -> Doc -> Doc
<+> SqlExpr -> Doc
ppSqlExpr SqlExpr
e
      PostfixSqlExpr String
op SqlExpr
e -> SqlExpr -> Doc
ppSqlExpr SqlExpr
e Doc -> Doc -> Doc
<+> String -> Doc
text String
op
      FunSqlExpr String
f [SqlExpr]
es     -> String -> Doc
text String
f Doc -> Doc -> Doc
<> Doc -> Doc
parens ((SqlExpr -> Doc) -> [SqlExpr] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaH SqlExpr -> Doc
ppSqlExpr [SqlExpr]
es)
      AggrFunSqlExpr String
f [SqlExpr]
es     -> String -> Doc
text String
f Doc -> Doc -> Doc
<> Doc -> Doc
parens ((SqlExpr -> Doc) -> [SqlExpr] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaH SqlExpr -> Doc
ppSqlExpr [SqlExpr]
es)
      ConstSqlExpr String
c      -> String -> Doc
text String
c
      CaseSqlExpr [(SqlExpr, SqlExpr)]
cs SqlExpr
el   -> String -> Doc
text String
"CASE" Doc -> Doc -> Doc
<+> [Doc] -> Doc
vcat (((SqlExpr, SqlExpr) -> Doc) -> [(SqlExpr, SqlExpr)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (SqlExpr, SqlExpr) -> Doc
ppWhen [(SqlExpr, SqlExpr)]
cs)
                             Doc -> Doc -> Doc
<+> String -> Doc
text String
"ELSE" Doc -> Doc -> Doc
<+> SqlExpr -> Doc
ppSqlExpr SqlExpr
el Doc -> Doc -> Doc
<+> String -> Doc
text String
"END"
          where ppWhen :: (SqlExpr, SqlExpr) -> Doc
ppWhen (SqlExpr
w,SqlExpr
t) = String -> Doc
text String
"WHEN" Doc -> Doc -> Doc
<+> SqlExpr -> Doc
ppSqlExpr SqlExpr
w
                               Doc -> Doc -> Doc
<+> String -> Doc
text String
"THEN" Doc -> Doc -> Doc
<+> SqlExpr -> Doc
ppSqlExpr SqlExpr
t
      ListSqlExpr [SqlExpr]
es      -> Doc -> Doc
parens ((SqlExpr -> Doc) -> [SqlExpr] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaH SqlExpr -> Doc
ppSqlExpr [SqlExpr]
es)
      ParamSqlExpr Maybe String
_ SqlExpr
v -> SqlExpr -> Doc
ppSqlExpr SqlExpr
v
      SqlExpr
PlaceHolderSqlExpr -> String -> Doc
text String
"?"
      CastSqlExpr String
typ SqlExpr
e -> String -> Doc
text String
"CAST" Doc -> Doc -> Doc
<> Doc -> Doc
parens (SqlExpr -> Doc
ppSqlExpr SqlExpr
e Doc -> Doc -> Doc
<+> String -> Doc
text String
"AS" Doc -> Doc -> Doc
<+> String -> Doc
text String
typ)
      SqlExpr
DefaultSqlExpr    -> String -> Doc
text String
"DEFAULT"

commaH :: (a -> Doc) -> [a] -> Doc
commaH :: (a -> Doc) -> [a] -> Doc
commaH a -> Doc
f = [Doc] -> Doc
hcat ([Doc] -> Doc) -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([a] -> [Doc]) -> [a] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
f

commaV :: (a -> Doc) -> [a] -> Doc
commaV :: (a -> Doc) -> [a] -> Doc
commaV a -> Doc
f = [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([a] -> [Doc]) -> [a] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
f