-- 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.Default  where

import Opaleye.SQLite.Internal.HaskellDB.PrimQuery
import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as PQ
import Opaleye.SQLite.Internal.HaskellDB.Sql
import Opaleye.SQLite.Internal.HaskellDB.Sql.Generate
import qualified Opaleye.SQLite.Internal.HaskellDB.Sql as Sql
import Opaleye.SQLite.Internal.Tag (tagWith)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Base16 as Base16
import qualified Data.List.NonEmpty as NEL

mkSqlGenerator :: SqlGenerator -> SqlGenerator
mkSqlGenerator :: SqlGenerator -> SqlGenerator
mkSqlGenerator SqlGenerator
gen = SqlGenerator :: (TableName -> [PrimExpr] -> Assoc -> SqlUpdate)
-> (TableName -> [PrimExpr] -> SqlDelete)
-> (TableName -> [TableName] -> NonEmpty [PrimExpr] -> SqlInsert)
-> (PrimExpr -> SqlExpr)
-> (Literal -> TableName)
-> (TableName -> TableName)
-> SqlGenerator
SqlGenerator
    {
     sqlUpdate :: TableName -> [PrimExpr] -> Assoc -> SqlUpdate
sqlUpdate      = SqlGenerator -> TableName -> [PrimExpr] -> Assoc -> SqlUpdate
defaultSqlUpdate      SqlGenerator
gen,
     sqlDelete :: TableName -> [PrimExpr] -> SqlDelete
sqlDelete      = SqlGenerator -> TableName -> [PrimExpr] -> SqlDelete
defaultSqlDelete      SqlGenerator
gen,
     sqlInsert :: TableName -> [TableName] -> NonEmpty [PrimExpr] -> SqlInsert
sqlInsert      = SqlGenerator
-> TableName -> [TableName] -> NonEmpty [PrimExpr] -> SqlInsert
defaultSqlInsert      SqlGenerator
gen,
     sqlExpr :: PrimExpr -> SqlExpr
sqlExpr        = SqlGenerator -> PrimExpr -> SqlExpr
defaultSqlExpr        SqlGenerator
gen,
     sqlLiteral :: Literal -> TableName
sqlLiteral     = SqlGenerator -> Literal -> TableName
defaultSqlLiteral     SqlGenerator
gen,
     sqlQuote :: TableName -> TableName
sqlQuote       = SqlGenerator -> TableName -> TableName
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 :: TableName -> SqlColumn
toSqlColumn TableName
attr = TableName -> SqlColumn
SqlColumn TableName
attr

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


defaultSqlUpdate :: SqlGenerator
                 -> TableName  -- ^ Name of the 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 -> TableName -> [PrimExpr] -> Assoc -> SqlUpdate
defaultSqlUpdate SqlGenerator
gen TableName
name [PrimExpr]
criteria Assoc
assigns
        = SqlTable -> [(SqlColumn, SqlExpr)] -> [SqlExpr] -> SqlUpdate
SqlUpdate (TableName -> SqlTable
SqlTable TableName
name) (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
                 -> TableName
                 -> [Attribute]
                 -> NEL.NonEmpty [PrimExpr]
                 -> SqlInsert
defaultSqlInsert :: SqlGenerator
-> TableName -> [TableName] -> NonEmpty [PrimExpr] -> SqlInsert
defaultSqlInsert SqlGenerator
gen TableName
name [TableName]
attrs NonEmpty [PrimExpr]
exprs =
  SqlTable -> [SqlColumn] -> NonEmpty [SqlExpr] -> SqlInsert
SqlInsert (TableName -> SqlTable
SqlTable TableName
name) ((TableName -> SqlColumn) -> [TableName] -> [SqlColumn]
forall a b. (a -> b) -> [a] -> [b]
map TableName -> SqlColumn
toSqlColumn [TableName]
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
                 -> TableName -- ^ Name of the table
                 -> [PrimExpr] -- ^ Criteria which must all be true for a row
                               --   to be deleted.
                 -> SqlDelete
defaultSqlDelete :: SqlGenerator -> TableName -> [PrimExpr] -> SqlDelete
defaultSqlDelete SqlGenerator
gen TableName
name [PrimExpr]
criteria = SqlTable -> [SqlExpr] -> SqlDelete
SqlDelete (TableName -> SqlTable
SqlTable TableName
name) ((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 TableName
a Tag
t) -> SqlColumn -> SqlExpr
ColumnSqlExpr (TableName -> SqlColumn
SqlColumn (Tag -> TableName -> TableName
tagWith Tag
t TableName
a))
      BaseTableAttrExpr TableName
a -> SqlColumn -> SqlExpr
ColumnSqlExpr (TableName -> SqlColumn
SqlColumn TableName
a)
      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
_, 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 TableName -> SqlExpr -> SqlExpr -> SqlExpr
BinSqlExpr (BinOp -> TableName
showBinOp BinOp
op) SqlExpr
expL SqlExpr
expR
      UnExpr UnOp
op PrimExpr
e      -> let (TableName
op',UnOpType
t) = UnOp -> (TableName, UnOpType)
sqlUnOp UnOp
op
                              e' :: SqlExpr
e' = SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
e
                           in case UnOpType
t of
                                UnOpType
UnOpFun     -> TableName -> [SqlExpr] -> SqlExpr
FunSqlExpr TableName
op' [SqlExpr
e']
                                UnOpType
UnOpPrefix  -> TableName -> SqlExpr -> SqlExpr
PrefixSqlExpr TableName
op' (SqlExpr -> SqlExpr
ParensSqlExpr SqlExpr
e')
                                UnOpType
UnOpPostfix -> TableName -> SqlExpr -> SqlExpr
PostfixSqlExpr TableName
op' 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 AggrOp
op PrimExpr
e    -> let op' :: TableName
op' = AggrOp -> TableName
showAggrOp AggrOp
op
                              e' :: SqlExpr
e' = SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
e
                              moreAggrFunParams :: [SqlExpr]
moreAggrFunParams = case AggrOp
op of
                                AggrStringAggr PrimExpr
primE -> [SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
primE]
                                AggrOp
_ -> []
                           in TableName -> [SqlExpr] -> SqlExpr
AggrFunSqlExpr TableName
op' (SqlExpr
e' SqlExpr -> [SqlExpr] -> [SqlExpr]
forall a. a -> [a] -> [a]
: [SqlExpr]
moreAggrFunParams)
      ConstExpr Literal
l      -> TableName -> SqlExpr
ConstSqlExpr (SqlGenerator -> Literal -> TableName
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 [(SqlExpr, SqlExpr)] -> SqlExpr -> SqlExpr
CaseSqlExpr [(SqlExpr, SqlExpr)]
cs' SqlExpr
e'
      ListExpr [PrimExpr]
es      -> [SqlExpr] -> SqlExpr
ListSqlExpr ((PrimExpr -> SqlExpr) -> [PrimExpr] -> [SqlExpr]
forall a b. (a -> b) -> [a] -> [b]
map (SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen) [PrimExpr]
es)
      ParamExpr Maybe TableName
n PrimExpr
_    -> Maybe TableName -> SqlExpr -> SqlExpr
ParamSqlExpr Maybe TableName
n SqlExpr
PlaceHolderSqlExpr
      FunExpr TableName
n [PrimExpr]
exprs  -> TableName -> [SqlExpr] -> SqlExpr
FunSqlExpr TableName
n ((PrimExpr -> SqlExpr) -> [PrimExpr] -> [SqlExpr]
forall a b. (a -> b) -> [a] -> [b]
map (SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen) [PrimExpr]
exprs)
      CastExpr TableName
typ PrimExpr
e1 -> TableName -> SqlExpr -> SqlExpr
CastSqlExpr TableName
typ (SqlGenerator -> PrimExpr -> SqlExpr
sqlExpr SqlGenerator
gen PrimExpr
e1)
      PrimExpr
DefaultInsertExpr -> SqlExpr
DefaultSqlExpr

showBinOp :: BinOp -> String
showBinOp :: BinOp -> TableName
showBinOp  BinOp
OpEq         = TableName
"="
showBinOp  BinOp
OpLt         = TableName
"<"
showBinOp  BinOp
OpLtEq       = TableName
"<="
showBinOp  BinOp
OpGt         = TableName
">"
showBinOp  BinOp
OpGtEq       = TableName
">="
showBinOp  BinOp
OpNotEq      = TableName
"<>"
showBinOp  BinOp
OpAnd        = TableName
"AND"
showBinOp  BinOp
OpOr         = TableName
"OR"
showBinOp  BinOp
OpLike       = TableName
"LIKE"
showBinOp  BinOp
OpIn         = TableName
"IN"
showBinOp  (OpOther TableName
s)  = TableName
s
showBinOp  BinOp
OpCat        = TableName
"||"
showBinOp  BinOp
OpPlus       = TableName
"+"
showBinOp  BinOp
OpMinus      = TableName
"-"
showBinOp  BinOp
OpMul        = TableName
"*"
showBinOp  BinOp
OpDiv        = TableName
"/"
showBinOp  BinOp
OpMod        = TableName
"MOD"
showBinOp  BinOp
OpBitNot     = TableName
"~"
showBinOp  BinOp
OpBitAnd     = TableName
"&"
showBinOp  BinOp
OpBitOr      = TableName
"|"
showBinOp  BinOp
OpBitXor     = TableName
"^"
showBinOp  BinOp
OpAsg        = TableName
"="


data UnOpType = UnOpFun | UnOpPrefix | UnOpPostfix

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


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


defaultSqlLiteral :: SqlGenerator -> Literal -> String
defaultSqlLiteral :: SqlGenerator -> Literal -> TableName
defaultSqlLiteral SqlGenerator
_ Literal
l =
    case Literal
l of
      Literal
NullLit       -> TableName
"NULL"
      Literal
DefaultLit    -> TableName
"DEFAULT"
      BoolLit Bool
True  -> TableName
"1"
      BoolLit Bool
False -> TableName
"0"
      ByteStringLit ByteString
s
                    -> ByteString -> TableName
binQuote ByteString
s
      StringLit TableName
s   -> TableName -> TableName
quote TableName
s
      IntegerLit Integer
i  -> Integer -> TableName
forall a. Show a => a -> TableName
show Integer
i
      DoubleLit Double
d   -> Double -> TableName
forall a. Show a => a -> TableName
show Double
d
      OtherLit TableName
o    -> TableName
o


defaultSqlQuote :: SqlGenerator -> String -> String
defaultSqlQuote :: SqlGenerator -> TableName -> TableName
defaultSqlQuote SqlGenerator
_ TableName
s = TableName -> TableName
quote TableName
s

quote :: String -> String
quote :: TableName -> TableName
quote TableName
s = TableName
"'" TableName -> TableName -> TableName
forall a. [a] -> [a] -> [a]
++ (Char -> TableName) -> TableName -> TableName
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> TableName
escape TableName
s TableName -> TableName -> TableName
forall a. [a] -> [a] -> [a]
++ TableName
"'"

-- | Escape characters that need escaping
-- FIXME: Escaping control characters probably doesn't work in SQLite
-- Need more tests
escape :: Char -> String
escape :: Char -> TableName
escape Char
'\NUL' = TableName
"\\0"
escape Char
'\'' = TableName
"''"
escape Char
'"' = TableName
"\\\""
escape Char
'\b' = TableName
"\\b"
escape Char
'\n' = TableName
"\\n"
escape Char
'\r' = TableName
"\\r"
escape Char
'\t' = TableName
"\\t"
escape Char
'\\' = TableName
"\\\\"
escape Char
c = [Char
c]


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