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

{-# LANGUAGE LambdaCase #-}

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

import Prelude hiding ((<>))
import Opaleye.Internal.HaskellDB.Sql (SqlColumn(..), SqlDelete(..),
                               SqlExpr(..), SqlOrder(..), SqlInsert(..),
                               SqlUpdate(..), SqlTable(..), SqlRangeBound(..),
                               OnConflict(..))
import qualified Opaleye.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, brackets)
import Data.Foldable (toList)

-- Silliness to avoid "ORDER BY 1" etc. meaning order by the first
-- column.  We need an identity function, but due to
-- https://github.com/tomjaguarpaw/haskell-opaleye/issues/100 we need
-- to be careful not to be over enthusiastic.  Just apply COALESCE to
-- literals.
deliteral :: SqlExpr -> SqlExpr
deliteral :: SqlExpr -> SqlExpr
deliteral expr :: SqlExpr
expr@(ConstSqlExpr String
_) = String -> [SqlExpr] -> SqlExpr
FunSqlExpr String
"COALESCE" [SqlExpr
expr]
deliteral 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 -> 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)

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"

ppSqlNulls :: Sql.SqlOrder -> Doc
ppSqlNulls :: SqlOrder -> Doc
ppSqlNulls SqlOrder
x = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ case SqlOrder -> SqlOrderNulls
Sql.sqlOrderNulls SqlOrder
x of
        SqlOrderNulls
Sql.SqlNullsFirst -> String
"NULLS FIRST"
        SqlOrderNulls
Sql.SqlNullsLast  -> String
"NULLS LAST"

ppSqlDistinct :: Sql.SqlDistinct -> Doc
ppSqlDistinct :: SqlDistinct -> Doc
ppSqlDistinct SqlDistinct
Sql.SqlDistinct = String -> Doc
text String
"DISTINCT"
ppSqlDistinct SqlDistinct
Sql.SqlNotDistinct = Doc
empty

ppAs :: Doc -> Maybe String -> Doc
ppAs :: Doc -> Maybe String -> Doc
ppAs Doc
expr Maybe String
Nothing      = Doc
expr
ppAs Doc
expr (Just String
alias) = 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


ppConflictStatement :: Maybe OnConflict -> Doc
ppConflictStatement :: Maybe OnConflict -> Doc
ppConflictStatement Maybe OnConflict
Nothing = String -> Doc
text String
""
ppConflictStatement (Just OnConflict
DoNothing) = String -> Doc
text String
"ON CONFLICT DO NOTHING"

ppInsert :: SqlInsert -> Doc
ppInsert :: SqlInsert -> Doc
ppInsert (SqlInsert SqlTable
table [SqlColumn]
names NonEmpty [SqlExpr]
values Maybe OnConflict
onConflict)
    = 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
$$ [[SqlExpr]] -> Doc
ppValues_ (NonEmpty [SqlExpr] -> [[SqlExpr]]
forall a. NonEmpty a -> [a]
NEL.toList NonEmpty [SqlExpr]
values)
      Doc -> Doc -> Doc
<+> Maybe OnConflict -> Doc
ppConflictStatement Maybe OnConflict
onConflict

ppValues_ :: [[SqlExpr]] -> Doc
ppValues_ :: [[SqlExpr]] -> Doc
ppValues_ [[SqlExpr]]
v = String -> Doc
text String
"VALUES" Doc -> Doc -> Doc
$$ ([SqlExpr] -> Doc) -> [[SqlExpr]] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaV (Doc -> Doc
parens (Doc -> Doc) -> ([SqlExpr] -> Doc) -> [SqlExpr] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SqlExpr -> Doc) -> [SqlExpr] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaH SqlExpr -> Doc
ppSqlExpr) [[SqlExpr]]
v

-- 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 schema and table names as lower case unless quoted.
ppTable :: SqlTable -> Doc
ppTable :: SqlTable -> Doc
ppTable SqlTable
st = case SqlTable -> Maybe String
sqlTableSchemaName SqlTable
st of
    Just String
sn -> Doc -> Doc
doubleQuotes (String -> Doc
text String
sn) Doc -> Doc -> Doc
<> String -> Doc
text String
"." Doc -> Doc -> Doc
<> Doc
tname
    Maybe String
Nothing -> Doc
tname
  where
    tname :: Doc
tname = Doc -> Doc
doubleQuotes (String -> Doc
text (SqlTable -> String
sqlTableName SqlTable
st))

data InclusiveExclusive = Inclusive' | Exclusive'

ppRange :: String -> SqlRangeBound -> SqlRangeBound -> Doc
ppRange :: String -> SqlRangeBound -> SqlRangeBound -> Doc
ppRange String
t SqlRangeBound
start SqlRangeBound
end =
  SqlExpr -> Doc
ppSqlExpr (String -> [SqlExpr] -> SqlExpr
FunSqlExpr String
t [ SqlExpr
startValue
                          , SqlExpr
endValue
                          , String -> SqlExpr
ConstSqlExpr String
boundTypeSymbol
                          ])

  where value_boundTypeT :: SqlRangeBound -> (InclusiveExclusive, SqlExpr)
value_boundTypeT = \case
          Inclusive SqlExpr
a -> (InclusiveExclusive
Inclusive', SqlExpr
a)
          Exclusive SqlExpr
a -> (InclusiveExclusive
Exclusive', SqlExpr
a)
          SqlRangeBound
PosInfinity -> (InclusiveExclusive
Exclusive', String -> SqlExpr
ConstSqlExpr String
"NULL")
          SqlRangeBound
NegInfinity -> (InclusiveExclusive
Exclusive', String -> SqlExpr
ConstSqlExpr String
"NULL")

        (InclusiveExclusive
startType, SqlExpr
startValue) = SqlRangeBound -> (InclusiveExclusive, SqlExpr)
value_boundTypeT SqlRangeBound
start
        (InclusiveExclusive
endType,   SqlExpr
endValue)   = SqlRangeBound -> (InclusiveExclusive, SqlExpr)
value_boundTypeT SqlRangeBound
end

        startTypeSymbol :: String
startTypeSymbol = case InclusiveExclusive
startType of
          InclusiveExclusive
Inclusive' -> String
"["
          InclusiveExclusive
Exclusive' -> String
"("

        endTypeSymbol :: String
endTypeSymbol = case InclusiveExclusive
endType of
          InclusiveExclusive
Inclusive' -> String
"]"
          InclusiveExclusive
Exclusive' -> String
")"

        boundTypeSymbol :: String
boundTypeSymbol = String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
startTypeSymbol String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
endTypeSymbol String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"

ppSqlExpr :: SqlExpr -> Doc
ppSqlExpr :: SqlExpr -> Doc
ppSqlExpr SqlExpr
expr =
    case SqlExpr
expr of
      ColumnSqlExpr SqlColumn
c        -> SqlColumn -> Doc
ppColumn SqlColumn
c
      CompositeSqlExpr SqlExpr
s String
x   -> Doc -> Doc
parens (SqlExpr -> Doc
ppSqlExpr SqlExpr
s) Doc -> Doc -> Doc
<> String -> Doc
text String
"." Doc -> Doc -> Doc
<> String -> Doc
text String
x
      ParensSqlExpr SqlExpr
e        -> Doc -> Doc
parens (SqlExpr -> Doc
ppSqlExpr SqlExpr
e)
      SubscriptSqlExpr SqlExpr
e1 SqlExpr
e2 -> SqlExpr -> Doc
ppSqlExpr SqlExpr
e1 Doc -> Doc -> Doc
<> Doc -> Doc
brackets (SqlExpr -> Doc
ppSqlExpr SqlExpr
e2)
      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)
      ConstSqlExpr String
c         -> String -> Doc
text String
c
      ListSqlExpr NonEmpty SqlExpr
es         -> Doc -> Doc
parens ((SqlExpr -> Doc) -> [SqlExpr] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaH SqlExpr -> Doc
ppSqlExpr (NonEmpty SqlExpr -> [SqlExpr]
forall a. NonEmpty a -> [a]
NEL.toList NonEmpty 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"
      ArraySqlExpr [SqlExpr]
es        -> String -> Doc
text String
"ARRAY" Doc -> Doc -> Doc
<> Doc -> Doc
brackets ((SqlExpr -> Doc) -> [SqlExpr] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaH SqlExpr -> Doc
ppSqlExpr [SqlExpr]
es)
      RangeSqlExpr String
t SqlRangeBound
s SqlRangeBound
e     -> String -> SqlRangeBound -> SqlRangeBound -> Doc
ppRange String
t SqlRangeBound
s SqlRangeBound
e
      AggrFunSqlExpr String
f [SqlExpr]
es [(SqlExpr, SqlOrder)]
ord SqlDistinct
distinct -> String -> Doc
text String
f Doc -> Doc -> Doc
<> Doc -> Doc
parens (SqlDistinct -> Doc
ppSqlDistinct SqlDistinct
distinct Doc -> Doc -> Doc
<+> (SqlExpr -> Doc) -> [SqlExpr] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaH SqlExpr -> Doc
ppSqlExpr [SqlExpr]
es Doc -> Doc -> Doc
<+> [(SqlExpr, SqlOrder)] -> Doc
ppOrderBy [(SqlExpr, SqlOrder)]
ord)
      CaseSqlExpr NonEmpty (SqlExpr, SqlExpr)
cs SqlExpr
el   -> String -> Doc
text String
"CASE" Doc -> Doc -> Doc
<+> [Doc] -> Doc
vcat (NonEmpty Doc -> [Doc]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (((SqlExpr, SqlExpr) -> Doc)
-> NonEmpty (SqlExpr, SqlExpr) -> NonEmpty Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SqlExpr, SqlExpr) -> Doc
ppWhen NonEmpty (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

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