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

module Opaleye.Internal.HaskellDB.Sql.Default  where

import Control.Applicative ((<$>))

import Opaleye.Internal.HaskellDB.PrimQuery
import qualified Opaleye.Internal.HaskellDB.PrimQuery as PQ
import Opaleye.Internal.HaskellDB.Sql
import Opaleye.Internal.HaskellDB.Sql.Generate
import qualified Opaleye.Internal.HaskellDB.Sql as Sql
import Opaleye.Internal.Tag (tagWith)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Base16 as Base16
import qualified Data.Char
import qualified Data.List.NonEmpty as NEL
import qualified Data.Text.Lazy.Builder.Scientific as Sci
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as LT
import qualified Text.Printf


mkSqlGenerator :: SqlGenerator -> SqlGenerator
mkSqlGenerator :: SqlGenerator -> SqlGenerator
mkSqlGenerator SqlGenerator
gen = SqlGenerator :: (SqlTable -> [PrimExpr] -> Assoc -> SqlUpdate)
-> (SqlTable -> [PrimExpr] -> SqlDelete)
-> (SqlTable
    -> [Attribute]
    -> NonEmpty [PrimExpr]
    -> Maybe OnConflict
    -> SqlInsert)
-> (PrimExpr -> SqlExpr)
-> (Literal -> Attribute)
-> (Attribute -> Attribute)
-> SqlGenerator
SqlGenerator
    {
     sqlUpdate :: SqlTable -> [PrimExpr] -> Assoc -> SqlUpdate
sqlUpdate      = SqlGenerator -> SqlTable -> [PrimExpr] -> Assoc -> SqlUpdate
defaultSqlUpdate      SqlGenerator
gen,
     sqlDelete :: SqlTable -> [PrimExpr] -> SqlDelete
sqlDelete      = SqlGenerator -> SqlTable -> [PrimExpr] -> SqlDelete
defaultSqlDelete      SqlGenerator
gen,
     sqlInsert :: SqlTable
-> [Attribute]
-> NonEmpty [PrimExpr]
-> Maybe OnConflict
-> SqlInsert
sqlInsert      = SqlGenerator
-> SqlTable
-> [Attribute]
-> NonEmpty [PrimExpr]
-> Maybe OnConflict
-> SqlInsert
defaultSqlInsert      SqlGenerator
gen,
     sqlExpr :: PrimExpr -> SqlExpr
sqlExpr        = SqlGenerator -> PrimExpr -> SqlExpr
defaultSqlExpr        SqlGenerator
gen,
     sqlLiteral :: Literal -> Attribute
sqlLiteral     = SqlGenerator -> Literal -> Attribute
defaultSqlLiteral     SqlGenerator
gen,
     sqlQuote :: Attribute -> Attribute
sqlQuote       = SqlGenerator -> Attribute -> Attribute
defaultSqlQuote       SqlGenerator
gen
    }

defaultSqlGenerator :: SqlGenerator
defaultSqlGenerator :: SqlGenerator
defaultSqlGenerator = SqlGenerator -> SqlGenerator
mkSqlGenerator SqlGenerator
defaultSqlGenerator


toSqlOrder :: SqlGenerator -> OrderExpr -> (SqlExpr,SqlOrder)
toSqlOrder :: SqlGenerator -> OrderExpr -> (SqlExpr, SqlOrder)
toSqlOrder SqlGenerator
gen (OrderExpr OrderOp
o PrimExpr
e) =
  (SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
e, SqlOrder :: SqlOrderDirection -> SqlOrderNulls -> SqlOrder
Sql.SqlOrder { sqlOrderDirection :: SqlOrderDirection
sqlOrderDirection = SqlOrderDirection
o'
                               , sqlOrderNulls :: SqlOrderNulls
sqlOrderNulls     = SqlOrderNulls
orderNulls' })
    where o' :: SqlOrderDirection
o' = case OrderOp -> OrderDirection
PQ.orderDirection OrderOp
o of
            OrderDirection
PQ.OpAsc  -> SqlOrderDirection
Sql.SqlAsc
            OrderDirection
PQ.OpDesc -> SqlOrderDirection
Sql.SqlDesc
          orderNulls' :: SqlOrderNulls
orderNulls' = case OrderOp -> OrderNulls
PQ.orderNulls OrderOp
o of
            OrderNulls
PQ.NullsFirst -> SqlOrderNulls
Sql.SqlNullsFirst
            OrderNulls
PQ.NullsLast  -> SqlOrderNulls
Sql.SqlNullsLast


toSqlColumn :: Attribute -> SqlColumn
toSqlColumn :: Attribute -> SqlColumn
toSqlColumn = Attribute -> SqlColumn
SqlColumn

toSqlAssoc :: SqlGenerator -> Assoc -> [(SqlColumn,SqlExpr)]
toSqlAssoc :: SqlGenerator -> Assoc -> [(SqlColumn, SqlExpr)]
toSqlAssoc SqlGenerator
gen = ((Attribute, PrimExpr) -> (SqlColumn, SqlExpr))
-> Assoc -> [(SqlColumn, SqlExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Attribute
attr,PrimExpr
expr) -> (Attribute -> SqlColumn
toSqlColumn Attribute
attr, SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
expr))


defaultSqlUpdate :: SqlGenerator
                 -> SqlTable   -- ^ Table to update
                 -> [PrimExpr] -- ^ Conditions which must all be true for a row
                               --   to be updated.
                 -> Assoc -- ^ Update the data with this.
                 -> SqlUpdate
defaultSqlUpdate :: SqlGenerator -> SqlTable -> [PrimExpr] -> Assoc -> SqlUpdate
defaultSqlUpdate SqlGenerator
gen SqlTable
tbl [PrimExpr]
criteria Assoc
assigns
        = SqlTable -> [(SqlColumn, SqlExpr)] -> [SqlExpr] -> SqlUpdate
SqlUpdate SqlTable
tbl (SqlGenerator -> Assoc -> [(SqlColumn, SqlExpr)]
toSqlAssoc SqlGenerator
gen Assoc
assigns) ((PrimExpr -> SqlExpr) -> [PrimExpr] -> [SqlExpr]
forall a b. (a -> b) -> [a] -> [b]
map (SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen) [PrimExpr]
criteria)


defaultSqlInsert :: SqlGenerator
                 -> SqlTable
                 -> [Attribute]
                 -> NEL.NonEmpty [PrimExpr]
                 -> Maybe OnConflict
                 -> SqlInsert
defaultSqlInsert :: SqlGenerator
-> SqlTable
-> [Attribute]
-> NonEmpty [PrimExpr]
-> Maybe OnConflict
-> SqlInsert
defaultSqlInsert SqlGenerator
gen SqlTable
tbl [Attribute]
attrs NonEmpty [PrimExpr]
exprs =
  SqlTable
-> [SqlColumn]
-> NonEmpty [SqlExpr]
-> Maybe OnConflict
-> SqlInsert
SqlInsert SqlTable
tbl ((Attribute -> SqlColumn) -> [Attribute] -> [SqlColumn]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> SqlColumn
toSqlColumn [Attribute]
attrs) ((([PrimExpr] -> [SqlExpr])
-> NonEmpty [PrimExpr] -> NonEmpty [SqlExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([PrimExpr] -> [SqlExpr])
 -> NonEmpty [PrimExpr] -> NonEmpty [SqlExpr])
-> ((PrimExpr -> SqlExpr) -> [PrimExpr] -> [SqlExpr])
-> (PrimExpr -> SqlExpr)
-> NonEmpty [PrimExpr]
-> NonEmpty [SqlExpr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrimExpr -> SqlExpr) -> [PrimExpr] -> [SqlExpr]
forall a b. (a -> b) -> [a] -> [b]
map) (SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen) NonEmpty [PrimExpr]
exprs)

defaultSqlDelete :: SqlGenerator
                 -> SqlTable
                 -> [PrimExpr] -- ^ Criteria which must all be true for a row
                               --   to be deleted.
                 -> SqlDelete
defaultSqlDelete :: SqlGenerator -> SqlTable -> [PrimExpr] -> SqlDelete
defaultSqlDelete SqlGenerator
gen SqlTable
tbl [PrimExpr]
criteria = SqlTable -> [SqlExpr] -> SqlDelete
SqlDelete SqlTable
tbl ((PrimExpr -> SqlExpr) -> [PrimExpr] -> [SqlExpr]
forall a b. (a -> b) -> [a] -> [b]
map (SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen) [PrimExpr]
criteria)


defaultSqlExpr :: SqlGenerator -> PrimExpr -> SqlExpr
defaultSqlExpr :: SqlGenerator -> PrimExpr -> SqlExpr
defaultSqlExpr SqlGenerator
gen PrimExpr
expr =
    case PrimExpr
expr of
      AttrExpr (Symbol Attribute
a Tag
t) -> SqlColumn -> SqlExpr
ColumnSqlExpr (Attribute -> SqlColumn
SqlColumn (Tag -> Attribute -> Attribute
tagWith Tag
t Attribute
a))
      BaseTableAttrExpr Attribute
a -> SqlColumn -> SqlExpr
ColumnSqlExpr (Attribute -> SqlColumn
SqlColumn Attribute
a)
      CompositeExpr PrimExpr
e Attribute
x -> SqlExpr -> Attribute -> SqlExpr
CompositeSqlExpr (SqlGenerator -> PrimExpr -> SqlExpr
defaultSqlExpr SqlGenerator
gen PrimExpr
e) Attribute
x
      BinExpr BinOp
op PrimExpr
e1 PrimExpr
e2 ->
        let leftE :: SqlExpr
leftE = SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
e1
            rightE :: SqlExpr
rightE = SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
e2
            paren :: SqlExpr -> SqlExpr
paren = SqlExpr -> SqlExpr
ParensSqlExpr
            (SqlExpr
expL, SqlExpr
expR) = case (BinOp
op, PrimExpr
e1, PrimExpr
e2) of
              (BinOp
OpAnd, BinExpr BinOp
OpOr PrimExpr
_ PrimExpr
_, BinExpr BinOp
OpOr PrimExpr
_ PrimExpr
_) ->
                (SqlExpr -> SqlExpr
paren SqlExpr
leftE, SqlExpr -> SqlExpr
paren SqlExpr
rightE)
              (BinOp
OpOr, BinExpr BinOp
OpAnd PrimExpr
_ PrimExpr
_, BinExpr BinOp
OpAnd PrimExpr
_ PrimExpr
_) ->
                (SqlExpr -> SqlExpr
paren SqlExpr
leftE, SqlExpr -> SqlExpr
paren SqlExpr
rightE)
              (BinOp
OpAnd, BinExpr BinOp
OpOr PrimExpr
_ PrimExpr
_, PrimExpr
_) ->
                (SqlExpr -> SqlExpr
paren SqlExpr
leftE, SqlExpr
rightE)
              (BinOp
OpAnd, PrimExpr
_, BinExpr BinOp
OpOr PrimExpr
_ PrimExpr
_) ->
                (SqlExpr
leftE, SqlExpr -> SqlExpr
paren SqlExpr
rightE)
              (BinOp
OpOr, BinExpr BinOp
OpAnd PrimExpr
_ PrimExpr
_, PrimExpr
_) ->
                (SqlExpr -> SqlExpr
paren SqlExpr
leftE, SqlExpr
rightE)
              (BinOp
OpOr, PrimExpr
_, BinExpr BinOp
OpAnd PrimExpr
_ PrimExpr
_) ->
                (SqlExpr
leftE, SqlExpr -> SqlExpr
paren SqlExpr
rightE)
              (BinOp
OpIn, PrimExpr
_, ListExpr NonEmpty PrimExpr
_) ->
                (SqlExpr
leftE, SqlExpr
rightE)
              (BinOp
_, ConstExpr Literal
_, ConstExpr Literal
_) ->
                (SqlExpr
leftE, SqlExpr
rightE)
              (BinOp
_, PrimExpr
_, ConstExpr Literal
_) ->
                (SqlExpr -> SqlExpr
paren SqlExpr
leftE, SqlExpr
rightE)
              (BinOp
_, ConstExpr Literal
_, PrimExpr
_) ->
                (SqlExpr
leftE, SqlExpr -> SqlExpr
paren SqlExpr
rightE)
              (BinOp, PrimExpr, PrimExpr)
_ -> (SqlExpr -> SqlExpr
paren SqlExpr
leftE, SqlExpr -> SqlExpr
paren SqlExpr
rightE)
        in Attribute -> SqlExpr -> SqlExpr -> SqlExpr
BinSqlExpr (BinOp -> Attribute
showBinOp BinOp
op) SqlExpr
expL SqlExpr
expR
      UnExpr UnOp
op PrimExpr
e      -> let (Attribute
op',UnOpType
t) = UnOp -> (Attribute, UnOpType)
sqlUnOp UnOp
op
                              e' :: SqlExpr
e' = SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
e
                           in case UnOpType
t of
                                UnOpType
UnOpFun     -> Attribute -> [SqlExpr] -> SqlExpr
FunSqlExpr Attribute
op' [SqlExpr
e']
                                UnOpType
UnOpPrefix  -> Attribute -> SqlExpr -> SqlExpr
PrefixSqlExpr Attribute
op' (SqlExpr -> SqlExpr
ParensSqlExpr SqlExpr
e')
                                UnOpType
UnOpPostfix -> Attribute -> SqlExpr -> SqlExpr
PostfixSqlExpr Attribute
op' (SqlExpr -> SqlExpr
ParensSqlExpr SqlExpr
e')
      -- TODO: The current arrangement whereby the delimeter parameter
      -- of string_agg is in the AggrStringAggr constructor, but the
      -- parameter being aggregated is not, seems unsatisfactory
      -- because it leads to a non-uniformity of treatment, as seen
      -- below.  Perhaps we should have just `AggrExpr AggrOp` and
      -- always put the `PrimExpr` in the `AggrOp`.
      AggrExpr AggrDistinct
distinct AggrOp
op PrimExpr
e [OrderExpr]
ord -> let op' :: Attribute
op' = AggrOp -> Attribute
showAggrOp AggrOp
op
                                        e' :: SqlExpr
e' = SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
e
                                        ord' :: [(SqlExpr, SqlOrder)]
ord' = SqlGenerator -> OrderExpr -> (SqlExpr, SqlOrder)
toSqlOrder SqlGenerator
gen (OrderExpr -> (SqlExpr, SqlOrder))
-> [OrderExpr] -> [(SqlExpr, SqlOrder)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OrderExpr]
ord
                                        distinct' :: SqlDistinct
distinct' = case AggrDistinct
distinct of
                                                      AggrDistinct
AggrDistinct -> SqlDistinct
SqlDistinct
                                                      AggrDistinct
AggrAll      -> SqlDistinct
SqlNotDistinct
                                        moreAggrFunParams :: [SqlExpr]
moreAggrFunParams = case AggrOp
op of
                                          AggrStringAggr PrimExpr
primE -> [SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
primE]
                                          AggrOp
_ -> []
                                     in Attribute
-> [SqlExpr] -> [(SqlExpr, SqlOrder)] -> SqlDistinct -> SqlExpr
AggrFunSqlExpr Attribute
op' (SqlExpr
e' SqlExpr -> [SqlExpr] -> [SqlExpr]
forall a. a -> [a] -> [a]
: [SqlExpr]
moreAggrFunParams) [(SqlExpr, SqlOrder)]
ord' SqlDistinct
distinct'
      ConstExpr Literal
l      -> Attribute -> SqlExpr
ConstSqlExpr (SqlGenerator -> Literal -> Attribute
sqlLiteral SqlGenerator
gen Literal
l)
      CaseExpr [(PrimExpr, PrimExpr)]
cs PrimExpr
e    -> let cs' :: [(SqlExpr, SqlExpr)]
cs' = [(SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
c, SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
x)| (PrimExpr
c,PrimExpr
x) <- [(PrimExpr, PrimExpr)]
cs]
                              e' :: SqlExpr
e'  = SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
e
                          in case [(SqlExpr, SqlExpr)] -> Maybe (NonEmpty (SqlExpr, SqlExpr))
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [(SqlExpr, SqlExpr)]
cs' of
                            Just NonEmpty (SqlExpr, SqlExpr)
nel -> NonEmpty (SqlExpr, SqlExpr) -> SqlExpr -> SqlExpr
CaseSqlExpr NonEmpty (SqlExpr, SqlExpr)
nel SqlExpr
e'
                            Maybe (NonEmpty (SqlExpr, SqlExpr))
Nothing  -> SqlExpr
e'
      ListExpr NonEmpty PrimExpr
es      -> NonEmpty SqlExpr -> SqlExpr
ListSqlExpr ((PrimExpr -> SqlExpr) -> NonEmpty PrimExpr -> NonEmpty SqlExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen) NonEmpty PrimExpr
es)
      ParamExpr Maybe Attribute
n PrimExpr
_    -> Maybe Attribute -> SqlExpr -> SqlExpr
ParamSqlExpr Maybe Attribute
n SqlExpr
PlaceHolderSqlExpr
      FunExpr Attribute
n [PrimExpr]
exprs  -> Attribute -> [SqlExpr] -> SqlExpr
FunSqlExpr Attribute
n ((PrimExpr -> SqlExpr) -> [PrimExpr] -> [SqlExpr]
forall a b. (a -> b) -> [a] -> [b]
map (SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen) [PrimExpr]
exprs)
      CastExpr Attribute
typ PrimExpr
e1 -> Attribute -> SqlExpr -> SqlExpr
CastSqlExpr Attribute
typ (SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
e1)
      PrimExpr
DefaultInsertExpr -> SqlExpr
DefaultSqlExpr
      ArrayExpr [PrimExpr]
es -> [SqlExpr] -> SqlExpr
ArraySqlExpr ((PrimExpr -> SqlExpr) -> [PrimExpr] -> [SqlExpr]
forall a b. (a -> b) -> [a] -> [b]
map (SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen) [PrimExpr]
es)
      RangeExpr Attribute
t BoundExpr
l BoundExpr
r -> let bound :: PQ.BoundExpr -> Sql.SqlRangeBound
                             bound :: BoundExpr -> SqlRangeBound
bound (PQ.Inclusive PrimExpr
a) = SqlExpr -> SqlRangeBound
Sql.Inclusive (SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
a)
                             bound (PQ.Exclusive PrimExpr
a) = SqlExpr -> SqlRangeBound
Sql.Exclusive (SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
a)
                             bound BoundExpr
PQ.PosInfinity   = SqlRangeBound
Sql.PosInfinity
                             bound BoundExpr
PQ.NegInfinity   = SqlRangeBound
Sql.NegInfinity
                        in Attribute -> SqlRangeBound -> SqlRangeBound -> SqlExpr
RangeSqlExpr Attribute
t (BoundExpr -> SqlRangeBound
bound BoundExpr
l) (BoundExpr -> SqlRangeBound
bound BoundExpr
r)
      ArrayIndex PrimExpr
e1 PrimExpr
e2 -> SqlExpr -> SqlExpr -> SqlExpr
SubscriptSqlExpr (SqlExpr -> SqlExpr
ParensSqlExpr (SqlExpr -> SqlExpr) -> SqlExpr -> SqlExpr
forall a b. (a -> b) -> a -> b
$ SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
e1) (SqlExpr -> SqlExpr
ParensSqlExpr (SqlExpr -> SqlExpr) -> SqlExpr -> SqlExpr
forall a b. (a -> b) -> a -> b
$ SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
e2)

showBinOp :: BinOp -> String
showBinOp :: BinOp -> Attribute
showBinOp  BinOp
(:==)        = Attribute
"="
showBinOp  BinOp
(:<)         = Attribute
"<"
showBinOp  BinOp
(:<=)        = Attribute
"<="
showBinOp  BinOp
(:>)         = Attribute
">"
showBinOp  BinOp
(:>=)        = Attribute
">="
showBinOp  BinOp
(:<>)        = Attribute
"<>"
showBinOp  BinOp
OpAnd        = Attribute
"AND"
showBinOp  BinOp
OpOr         = Attribute
"OR"
showBinOp  BinOp
OpLike       = Attribute
"LIKE"
showBinOp  BinOp
OpILike      = Attribute
"ILIKE"
showBinOp  BinOp
OpIn         = Attribute
"IN"
showBinOp  (OpOther Attribute
s)  = Attribute
s
showBinOp  BinOp
(:||)        = Attribute
"||"
showBinOp  BinOp
(:+)         = Attribute
"+"
showBinOp  BinOp
(:-)         = Attribute
"-"
showBinOp  BinOp
(:*)         = Attribute
"*"
showBinOp  BinOp
(:/)         = Attribute
"/"
showBinOp  BinOp
OpMod        = Attribute
"MOD"
showBinOp  BinOp
(:~)         = Attribute
"~"
showBinOp  BinOp
(:&)         = Attribute
"&"
showBinOp  BinOp
(:|)         = Attribute
"|"
showBinOp  BinOp
(:^)         = Attribute
"^"
showBinOp  BinOp
(:=)         = Attribute
"="
showBinOp  BinOp
OpAtTimeZone = Attribute
"AT TIME ZONE"
showBinOp  BinOp
(:->)        = Attribute
"->"
showBinOp  BinOp
(:->>)       = Attribute
"->>"
showBinOp  BinOp
(:#>)        = Attribute
"#>"
showBinOp  BinOp
(:#>>)       = Attribute
"#>>"
showBinOp  BinOp
(:@>)        = Attribute
"@>"
showBinOp  BinOp
(:<@)        = Attribute
"<@"
showBinOp  BinOp
(:?)         = Attribute
"?"
showBinOp  BinOp
(:?|)        = Attribute
"?|"
showBinOp  BinOp
(:?&)        = Attribute
"?&"
showBinOp  BinOp
(:&&)        = Attribute
"&&"
showBinOp  BinOp
(:<<)        = Attribute
"<<"
showBinOp  BinOp
(:>>)        = Attribute
">>"
showBinOp  BinOp
(:&<)        = Attribute
"&<"
showBinOp  BinOp
(:&>)        = Attribute
"&>"
showBinOp  BinOp
(:-|-)       = Attribute
"-|-"

data UnOpType = UnOpFun | UnOpPrefix | UnOpPostfix

sqlUnOp :: UnOp -> (String,UnOpType)
sqlUnOp :: UnOp -> (Attribute, UnOpType)
sqlUnOp  UnOp
OpNot         = (Attribute
"NOT", UnOpType
UnOpPrefix)
sqlUnOp  UnOp
OpIsNull      = (Attribute
"IS NULL", UnOpType
UnOpPostfix)
sqlUnOp  UnOp
OpIsNotNull   = (Attribute
"IS NOT NULL", UnOpType
UnOpPostfix)
sqlUnOp  UnOp
OpLength      = (Attribute
"LENGTH", UnOpType
UnOpFun)
sqlUnOp  UnOp
OpAbs         = (Attribute
"@", UnOpType
UnOpFun)
sqlUnOp  UnOp
OpNegate      = (Attribute
"-", UnOpType
UnOpFun)
sqlUnOp  UnOp
OpLower       = (Attribute
"LOWER", UnOpType
UnOpFun)
sqlUnOp  UnOp
OpUpper       = (Attribute
"UPPER", UnOpType
UnOpFun)
sqlUnOp  (UnOpOther Attribute
s) = (Attribute
s, UnOpType
UnOpFun)


showAggrOp :: AggrOp -> String
showAggrOp :: AggrOp -> Attribute
showAggrOp AggrOp
AggrCount          = Attribute
"COUNT"
showAggrOp AggrOp
AggrSum            = Attribute
"SUM"
showAggrOp AggrOp
AggrAvg            = Attribute
"AVG"
showAggrOp AggrOp
AggrMin            = Attribute
"MIN"
showAggrOp AggrOp
AggrMax            = Attribute
"MAX"
showAggrOp AggrOp
AggrStdDev         = Attribute
"StdDev"
showAggrOp AggrOp
AggrStdDevP        = Attribute
"StdDevP"
showAggrOp AggrOp
AggrVar            = Attribute
"Var"
showAggrOp AggrOp
AggrVarP           = Attribute
"VarP"
showAggrOp AggrOp
AggrBoolAnd        = Attribute
"BOOL_AND"
showAggrOp AggrOp
AggrBoolOr         = Attribute
"BOOL_OR"
showAggrOp AggrOp
AggrArr            = Attribute
"ARRAY_AGG"
showAggrOp AggrOp
JsonArr            = Attribute
"JSON_AGG"
showAggrOp (AggrStringAggr PrimExpr
_) = Attribute
"STRING_AGG"
showAggrOp (AggrOther Attribute
s)      = Attribute
s


defaultSqlLiteral :: SqlGenerator -> Literal -> String
defaultSqlLiteral :: SqlGenerator -> Literal -> Attribute
defaultSqlLiteral SqlGenerator
_ Literal
l =
    case Literal
l of
      Literal
NullLit       -> Attribute
"NULL"
      Literal
DefaultLit    -> Attribute
"DEFAULT"
      BoolLit Bool
True  -> Attribute
"TRUE"
      BoolLit Bool
False -> Attribute
"FALSE"
      ByteStringLit ByteString
s
                    -> ByteString -> Attribute
binQuote ByteString
s
      StringLit Attribute
s   -> Attribute -> Attribute
quote Attribute
s
      IntegerLit Integer
i  -> Integer -> Attribute
forall a. Show a => a -> Attribute
show Integer
i
      DoubleLit Double
d   -> if Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
d then Attribute
"'NaN'"
                       else if Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
d Bool -> Bool -> Bool
&& Double
d Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 then Attribute
"'-Infinity'"
                       else if Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
d Bool -> Bool -> Bool
&& Double
d Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 then Attribute
"'Infinity'"
                       else Double -> Attribute
forall a. Show a => a -> Attribute
show Double
d
      NumericLit Scientific
n  -> Text -> Attribute
LT.unpack (Text -> Attribute)
-> (Scientific -> Text) -> Scientific -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
LT.toLazyText (Builder -> Text) -> (Scientific -> Builder) -> Scientific -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Builder
Sci.scientificBuilder (Scientific -> Attribute) -> Scientific -> Attribute
forall a b. (a -> b) -> a -> b
$ Scientific
n
      OtherLit Attribute
o    -> Attribute
o


defaultSqlQuote :: SqlGenerator -> String -> String
defaultSqlQuote :: SqlGenerator -> Attribute -> Attribute
defaultSqlQuote SqlGenerator
_ = Attribute -> Attribute
quote

-- | Quote a string and escape characters that need escaping
--   We use Postgres "escape strings", i.e. strings prefixed
--   with E, to ensure that escaping with backslash is valid.
quote :: String -> String
quote :: Attribute -> Attribute
quote Attribute
s = Attribute
"E'" Attribute -> Attribute -> Attribute
forall a. [a] -> [a] -> [a]
++ (Char -> Attribute) -> Attribute -> Attribute
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> Attribute
escape Attribute
s Attribute -> Attribute -> Attribute
forall a. [a] -> [a] -> [a]
++ Attribute
"'"

-- | Escape characters that need escaping
escape :: Char -> String
escape :: Char -> Attribute
escape Char
'\NUL' = Attribute
"\\0"
escape Char
'\'' = Attribute
"''"
escape Char
'"' = Attribute
"\\\""
escape Char
'\b' = Attribute
"\\b"
escape Char
'\n' = Attribute
"\\n"
escape Char
'\r' = Attribute
"\\r"
escape Char
'\t' = Attribute
"\\t"
escape Char
'\\' = Attribute
"\\\\"
escape Char
c = if Char -> Bool
Data.Char.isPrint Char
c
           then [Char
c]
           else Attribute -> Int -> Attribute
forall r. PrintfType r => Attribute -> r
Text.Printf.printf Attribute
"\\U%0.8x" (Char -> Int
Data.Char.ord Char
c)


-- | Quote binary literals using Postgresql's hex format.
binQuote :: ByteString -> String
binQuote :: ByteString -> Attribute
binQuote ByteString
s = Attribute
"E'\\\\x" Attribute -> Attribute -> Attribute
forall a. [a] -> [a] -> [a]
++ ByteString -> Attribute
BS8.unpack (ByteString -> ByteString
Base16.encode ByteString
s) Attribute -> Attribute -> Attribute
forall a. [a] -> [a] -> [a]
++ Attribute
"'"