{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Database.Groundhog.Generic.Sql
(
renderCond,
defaultShowPrim,
renderOrders,
renderUpdates,
renderFields,
renderChain,
renderExpr,
renderExprPriority,
renderExprExtended,
renderPersistValue,
mkExprWithConf,
prerenderExpr,
intercalateS,
commasJoin,
flatten,
RenderS (..),
Utf8 (..),
fromUtf8,
RenderConfig (..),
StringLike (..),
fromString,
(<>),
function,
operator,
parens,
mkExpr,
Snippet (..),
SqlDb (..),
FloatingSqlDb (..),
tableName,
mainTableName,
)
where
import Data.Maybe (mapMaybe, maybeToList)
import Data.Semigroup (Semigroup (..))
import Data.String
import qualified Data.Text.Lazy.Builder as B
import Database.Groundhog.Core
import Database.Groundhog.Expression
import Database.Groundhog.Generic (isSimple)
import Database.Groundhog.Instances ()
class (Semigroup a, Monoid a, IsString a) => StringLike a where
fromChar :: Char -> a
data RenderS db r = RenderS
{ RenderS db r -> Utf8
getQuery :: Utf8,
RenderS db r -> [PersistValue] -> [PersistValue]
getValues :: [PersistValue] -> [PersistValue]
}
instance StringLike Utf8 where
fromChar :: Char -> Utf8
fromChar = Builder -> Utf8
Utf8 (Builder -> Utf8) -> (Char -> Builder) -> Char -> Utf8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Builder
B.singleton
newtype Snippet db r = Snippet (RenderConfig -> Int -> [RenderS db r])
newtype RenderConfig = RenderConfig
{ RenderConfig -> Utf8 -> Utf8
esc :: Utf8 -> Utf8
}
class (DbDescriptor db, QueryRaw db ~ Snippet db) => SqlDb db where
append :: (ExpressionOf db r a String, ExpressionOf db r b String) => a -> b -> Expr db r String
signum' :: (ExpressionOf db r x a, Num a) => x -> Expr db r a
quotRem' :: (ExpressionOf db r x a, ExpressionOf db r y a, Integral a) => x -> y -> (Expr db r a, Expr db r a)
equalsOperator :: RenderS db r -> RenderS db r -> RenderS db r
notEqualsOperator :: RenderS db r -> RenderS db r -> RenderS db r
class SqlDb db => FloatingSqlDb db where
log' :: (ExpressionOf db r x a, Floating a) => x -> Expr db r a
logBase' :: (ExpressionOf db r b a, ExpressionOf db r x a, Floating a) => b -> x -> Expr db r a
prerenderExpr :: forall db r a. (SqlDb db, PersistField a) => RenderConfig -> Expr db r a -> Expr db r a
prerenderExpr :: RenderConfig -> Expr db r a -> Expr db r a
prerenderExpr RenderConfig
conf (Expr UntypedExpr db r
e) = UntypedExpr db r -> Expr db r a
forall db r a. UntypedExpr db r -> Expr db r a
Expr (UntypedExpr db r -> Expr db r a)
-> UntypedExpr db r -> Expr db r a
forall a b. (a -> b) -> a -> b
$ DbType -> QueryRaw db r -> UntypedExpr db r
forall db r. DbType -> QueryRaw db r -> UntypedExpr db r
ExprRaw DbType
typ (QueryRaw db r -> UntypedExpr db r)
-> QueryRaw db r -> UntypedExpr db r
forall a b. (a -> b) -> a -> b
$ (RenderConfig -> Int -> [RenderS db r]) -> Snippet db r
forall db r.
(RenderConfig -> Int -> [RenderS db r]) -> Snippet db r
Snippet ((RenderConfig -> Int -> [RenderS db r]) -> Snippet db r)
-> (RenderConfig -> Int -> [RenderS db r]) -> Snippet db r
forall a b. (a -> b) -> a -> b
$ \RenderConfig
_ Int
_ -> [RenderS db r]
prerendered
where
proxy :: Any db
proxy = forall a. HasCallStack => a
forall (proxy :: * -> *). proxy db
undefined :: proxy db
typ :: DbType
typ = Any db -> a -> DbType
forall a db (proxy :: * -> *).
(PersistField a, DbDescriptor db) =>
proxy db -> a -> DbType
dbType Any db
proxy (a
forall a. HasCallStack => a
undefined :: a)
prerendered :: [RenderS db r]
prerendered = RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
forall db r.
SqlDb db =>
RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
renderExprExtended RenderConfig
conf Int
forall a. Bounded a => a
maxBound UntypedExpr db r
e
mkExprWithConf :: (SqlDb db, PersistField a) => (RenderConfig -> Int -> Expr db r a) -> Expr db r a
mkExprWithConf :: (RenderConfig -> Int -> Expr db r a) -> Expr db r a
mkExprWithConf RenderConfig -> Int -> Expr db r a
f = Expr db r a
expr
where
expr :: Expr db r a
expr = Snippet db r -> Expr db r a
forall db r a.
(SqlDb db, PersistField a) =>
Snippet db r -> Expr db r a
mkExpr (Snippet db r -> Expr db r a) -> Snippet db r -> Expr db r a
forall a b. (a -> b) -> a -> b
$ (RenderConfig -> Int -> [RenderS db r]) -> Snippet db r
forall db r.
(RenderConfig -> Int -> [RenderS db r]) -> Snippet db r
Snippet ((RenderConfig -> Int -> [RenderS db r]) -> Snippet db r)
-> (RenderConfig -> Int -> [RenderS db r]) -> Snippet db r
forall a b. (a -> b) -> a -> b
$ \RenderConfig
conf Int
p -> [RenderConfig -> Int -> UntypedExpr db r -> RenderS db r
forall db r.
SqlDb db =>
RenderConfig -> Int -> UntypedExpr db r -> RenderS db r
renderExprPriority RenderConfig
conf Int
p (UntypedExpr db r -> RenderS db r)
-> UntypedExpr db r -> RenderS db r
forall a b. (a -> b) -> a -> b
$ Expr db r a -> UntypedExpr db r
forall db r a. Expression db r a => a -> UntypedExpr db r
toExpr (Expr db r a -> UntypedExpr db r)
-> Expr db r a -> UntypedExpr db r
forall a b. (a -> b) -> a -> b
$ RenderConfig -> Int -> Expr db r a
f RenderConfig
conf Int
p Expr db r a -> Expr db r a -> Expr db r a
forall a. a -> a -> a
`asTypeOf` Expr db r a
expr]
renderExpr :: SqlDb db => RenderConfig -> UntypedExpr db r -> RenderS db r
renderExpr :: RenderConfig -> UntypedExpr db r -> RenderS db r
renderExpr RenderConfig
conf = RenderConfig -> Int -> UntypedExpr db r -> RenderS db r
forall db r.
SqlDb db =>
RenderConfig -> Int -> UntypedExpr db r -> RenderS db r
renderExprPriority RenderConfig
conf Int
0
renderExprPriority :: SqlDb db => RenderConfig -> Int -> UntypedExpr db r -> RenderS db r
renderExprPriority :: RenderConfig -> Int -> UntypedExpr db r -> RenderS db r
renderExprPriority RenderConfig
conf Int
p UntypedExpr db r
expr =
case UntypedExpr db r
expr of
ExprRaw DbType
_ (Snippet f) -> [RenderS db r] -> RenderS db r
forall a. [a] -> a
explicitHead (RenderConfig -> Int -> [RenderS db r]
f RenderConfig
conf Int
p)
ExprField FieldChain
f ->
let fs :: [Utf8]
fs = RenderConfig -> FieldChain -> [Utf8] -> [Utf8]
renderChain RenderConfig
conf FieldChain
f []
in Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
forall db r.
Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
RenderS ([Utf8] -> Utf8
forall a. [a] -> a
explicitHead [Utf8]
fs) [PersistValue] -> [PersistValue]
forall a. a -> a
id
ExprPure a
a ->
let vals :: [PersistValue] -> [PersistValue]
vals = a -> [PersistValue] -> [PersistValue]
forall a.
PurePersistField a =>
a -> [PersistValue] -> [PersistValue]
toPurePersistValues a
a
in PersistValue -> RenderS db r
forall db r. PersistValue -> RenderS db r
renderPersistValue (PersistValue -> RenderS db r) -> PersistValue -> RenderS db r
forall a b. (a -> b) -> a -> b
$ [PersistValue] -> PersistValue
forall a. [a] -> a
explicitHead ([PersistValue] -> [PersistValue]
vals [])
ExprCond Cond db r
a -> case RenderConfig -> Int -> Cond db r -> Maybe (RenderS db r)
forall db r.
SqlDb db =>
RenderConfig -> Int -> Cond db r -> Maybe (RenderS db r)
renderCondPriority RenderConfig
conf Int
p Cond db r
a of
Maybe (RenderS db r)
Nothing -> [Char] -> RenderS db r
forall a. HasCallStack => [Char] -> a
error [Char]
"renderExprPriority: empty condition"
Just RenderS db r
x -> RenderS db r
x
where
explicitHead :: [a] -> a
explicitHead :: [a] -> a
explicitHead [a]
xs = case [a]
xs of
[a
x] -> a
x
[a]
xs' -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"renderExprPriority: expected one column field, found " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs')
renderExprExtended :: SqlDb db => RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
renderExprExtended :: RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
renderExprExtended RenderConfig
conf Int
p UntypedExpr db r
expr =
case UntypedExpr db r
expr of
ExprRaw DbType
_ (Snippet f) -> RenderConfig -> Int -> [RenderS db r]
f RenderConfig
conf Int
p
ExprField FieldChain
f -> (Utf8 -> RenderS db r) -> [Utf8] -> [RenderS db r]
forall a b. (a -> b) -> [a] -> [b]
map (Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
forall db r.
Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
`RenderS` [PersistValue] -> [PersistValue]
forall a. a -> a
id) ([Utf8] -> [RenderS db r]) -> [Utf8] -> [RenderS db r]
forall a b. (a -> b) -> a -> b
$ RenderConfig -> FieldChain -> [Utf8] -> [Utf8]
renderChain RenderConfig
conf FieldChain
f []
ExprPure a
a ->
let vals :: [PersistValue]
vals = a -> [PersistValue] -> [PersistValue]
forall a.
PurePersistField a =>
a -> [PersistValue] -> [PersistValue]
toPurePersistValues a
a []
in (PersistValue -> RenderS db r) -> [PersistValue] -> [RenderS db r]
forall a b. (a -> b) -> [a] -> [b]
map PersistValue -> RenderS db r
forall db r. PersistValue -> RenderS db r
renderPersistValue [PersistValue]
vals
ExprCond Cond db r
a -> Maybe (RenderS db r) -> [RenderS db r]
forall a. Maybe a -> [a]
maybeToList (Maybe (RenderS db r) -> [RenderS db r])
-> Maybe (RenderS db r) -> [RenderS db r]
forall a b. (a -> b) -> a -> b
$ RenderConfig -> Int -> Cond db r -> Maybe (RenderS db r)
forall db r.
SqlDb db =>
RenderConfig -> Int -> Cond db r -> Maybe (RenderS db r)
renderCondPriority RenderConfig
conf Int
p Cond db r
a
renderPersistValue :: PersistValue -> RenderS db r
renderPersistValue :: PersistValue -> RenderS db r
renderPersistValue (PersistCustom Utf8
s [PersistValue]
as) = Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
forall db r.
Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
RenderS Utf8
s ([PersistValue]
as [PersistValue] -> [PersistValue] -> [PersistValue]
forall a. [a] -> [a] -> [a]
++)
renderPersistValue PersistValue
a = Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
forall db r.
Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
RenderS (Char -> Utf8
forall a. StringLike a => Char -> a
fromChar Char
'?') (PersistValue
a PersistValue -> [PersistValue] -> [PersistValue]
forall a. a -> [a] -> [a]
:)
instance Semigroup (RenderS db r) where
(RenderS Utf8
f1 [PersistValue] -> [PersistValue]
g1) <> :: RenderS db r -> RenderS db r -> RenderS db r
<> (RenderS Utf8
f2 [PersistValue] -> [PersistValue]
g2) = Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
forall db r.
Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
RenderS (Utf8
f1 Utf8 -> Utf8 -> Utf8
forall a. Semigroup a => a -> a -> a
<> Utf8
f2) ([PersistValue] -> [PersistValue]
g1 ([PersistValue] -> [PersistValue])
-> ([PersistValue] -> [PersistValue])
-> [PersistValue]
-> [PersistValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PersistValue] -> [PersistValue]
g2)
instance Monoid (RenderS db r) where
mempty :: RenderS db r
mempty = Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
forall db r.
Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
RenderS Utf8
forall a. Monoid a => a
mempty [PersistValue] -> [PersistValue]
forall a. a -> a
id
#if !(MIN_VERSION_base(4,11,0))
mappend = (<>)
#endif
instance IsString (RenderS db r) where
fromString :: [Char] -> RenderS db r
fromString [Char]
s = Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
forall db r.
Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
RenderS ([Char] -> Utf8
forall a. IsString a => [Char] -> a
fromString [Char]
s) [PersistValue] -> [PersistValue]
forall a. a -> a
id
instance StringLike (RenderS db r) where
fromChar :: Char -> RenderS db r
fromChar Char
c = Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
forall db r.
Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
RenderS (Char -> Utf8
forall a. StringLike a => Char -> a
fromChar Char
c) [PersistValue] -> [PersistValue]
forall a. a -> a
id
instance StringLike String where
fromChar :: Char -> [Char]
fromChar Char
c = [Char
c]
{-# INLINEABLE parens #-}
parens :: Int -> Int -> RenderS db r -> RenderS db r
parens :: Int -> Int -> RenderS db r -> RenderS db r
parens Int
p1 Int
p2 RenderS db r
expr = if Int
p1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
p2 then Char -> RenderS db r
forall a. StringLike a => Char -> a
fromChar Char
'(' RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> RenderS db r
expr RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> Char -> RenderS db r
forall a. StringLike a => Char -> a
fromChar Char
')' else RenderS db r
expr
operator :: (SqlDb db, Expression db r a, Expression db r b) => Int -> String -> a -> b -> Snippet db r
operator :: Int -> [Char] -> a -> b -> Snippet db r
operator Int
pr [Char]
op a
a b
b = (RenderConfig -> Int -> [RenderS db r]) -> Snippet db r
forall db r.
(RenderConfig -> Int -> [RenderS db r]) -> Snippet db r
Snippet ((RenderConfig -> Int -> [RenderS db r]) -> Snippet db r)
-> (RenderConfig -> Int -> [RenderS db r]) -> Snippet db r
forall a b. (a -> b) -> a -> b
$ \RenderConfig
conf Int
p ->
[Int -> Int -> RenderS db r -> RenderS db r
forall db r. Int -> Int -> RenderS db r -> RenderS db r
parens Int
pr Int
p (RenderS db r -> RenderS db r) -> RenderS db r -> RenderS db r
forall a b. (a -> b) -> a -> b
$ RenderConfig -> Int -> UntypedExpr db r -> RenderS db r
forall db r.
SqlDb db =>
RenderConfig -> Int -> UntypedExpr db r -> RenderS db r
renderExprPriority RenderConfig
conf Int
pr (a -> UntypedExpr db r
forall db r a. Expression db r a => a -> UntypedExpr db r
toExpr a
a) RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> [Char] -> RenderS db r
forall a. IsString a => [Char] -> a
fromString [Char]
op RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> RenderConfig -> Int -> UntypedExpr db r -> RenderS db r
forall db r.
SqlDb db =>
RenderConfig -> Int -> UntypedExpr db r -> RenderS db r
renderExprPriority RenderConfig
conf Int
pr (b -> UntypedExpr db r
forall db r a. Expression db r a => a -> UntypedExpr db r
toExpr b
b)]
function :: SqlDb db => String -> [UntypedExpr db r] -> Snippet db r
function :: [Char] -> [UntypedExpr db r] -> Snippet db r
function [Char]
func [UntypedExpr db r]
args = (RenderConfig -> Int -> [RenderS db r]) -> Snippet db r
forall db r.
(RenderConfig -> Int -> [RenderS db r]) -> Snippet db r
Snippet ((RenderConfig -> Int -> [RenderS db r]) -> Snippet db r)
-> (RenderConfig -> Int -> [RenderS db r]) -> Snippet db r
forall a b. (a -> b) -> a -> b
$ \RenderConfig
conf Int
_ -> [[Char] -> RenderS db r
forall a. IsString a => [Char] -> a
fromString [Char]
func RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> Char -> RenderS db r
forall a. StringLike a => Char -> a
fromChar Char
'(' RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> [RenderS db r] -> RenderS db r
forall s. StringLike s => [s] -> s
commasJoin ((UntypedExpr db r -> RenderS db r)
-> [UntypedExpr db r] -> [RenderS db r]
forall a b. (a -> b) -> [a] -> [b]
map (RenderConfig -> UntypedExpr db r -> RenderS db r
forall db r.
SqlDb db =>
RenderConfig -> UntypedExpr db r -> RenderS db r
renderExpr RenderConfig
conf) [UntypedExpr db r]
args) RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> Char -> RenderS db r
forall a. StringLike a => Char -> a
fromChar Char
')']
mkExpr :: forall db r a. (SqlDb db, PersistField a) => Snippet db r -> Expr db r a
mkExpr :: Snippet db r -> Expr db r a
mkExpr Snippet db r
snippet = UntypedExpr db r -> Expr db r a
forall db r a. UntypedExpr db r -> Expr db r a
Expr (UntypedExpr db r -> Expr db r a)
-> UntypedExpr db r -> Expr db r a
forall a b. (a -> b) -> a -> b
$ DbType -> QueryRaw db r -> UntypedExpr db r
forall db r. DbType -> QueryRaw db r -> UntypedExpr db r
ExprRaw DbType
typ QueryRaw db r
Snippet db r
snippet
where
proxy :: Any db
proxy = forall a. HasCallStack => a
forall (proxy :: * -> *). proxy db
undefined :: proxy db
typ :: DbType
typ = Any db -> a -> DbType
forall a db (proxy :: * -> *).
(PersistField a, DbDescriptor db) =>
proxy db -> a -> DbType
dbType Any db
proxy (a
forall a. HasCallStack => a
undefined :: a)
{-# INLINEABLE renderCond #-}
renderCond ::
SqlDb db =>
RenderConfig ->
Cond db r ->
Maybe (RenderS db r)
renderCond :: RenderConfig -> Cond db r -> Maybe (RenderS db r)
renderCond RenderConfig
conf = RenderConfig -> Int -> Cond db r -> Maybe (RenderS db r)
forall db r.
SqlDb db =>
RenderConfig -> Int -> Cond db r -> Maybe (RenderS db r)
renderCondPriority RenderConfig
conf Int
0
flattenNullables :: DbType -> [Bool]
flattenNullables :: DbType -> [Bool]
flattenNullables DbType
typ = DbType -> [Bool] -> [Bool]
go DbType
typ []
where
go :: DbType -> [Bool] -> [Bool]
go :: DbType -> [Bool] -> [Bool]
go DbType
t [Bool]
acc = case DbType
t of
DbEmbedded (EmbeddedDef Bool
_ [([Char], DbType)]
ts) Maybe ParentTableReference
_ -> (([Char], DbType) -> [Bool] -> [Bool])
-> [Bool] -> [([Char], DbType)] -> [Bool]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (DbType -> [Bool] -> [Bool]
go (DbType -> [Bool] -> [Bool])
-> (([Char], DbType) -> DbType)
-> ([Char], DbType)
-> [Bool]
-> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], DbType) -> DbType
forall a b. (a, b) -> b
snd) [Bool]
acc [([Char], DbType)]
ts
DbList [Char]
_ DbType
_ -> Bool
False Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool]
acc
DbTypePrimitive DbTypePrimitive
_ Bool
nullable Maybe [Char]
_ Maybe ParentTableReference
_ -> Bool
nullable Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool]
acc
{-# INLINEABLE renderCondPriority #-}
renderCondPriority ::
forall db r.
SqlDb db =>
RenderConfig ->
Int ->
Cond db r ->
Maybe (RenderS db r)
renderCondPriority :: RenderConfig -> Int -> Cond db r -> Maybe (RenderS db r)
renderCondPriority conf :: RenderConfig
conf@RenderConfig {Utf8 -> Utf8
esc :: Utf8 -> Utf8
esc :: RenderConfig -> Utf8 -> Utf8
..} Int
priority Cond db r
cond = Cond db r -> Int -> Maybe (RenderS db r)
go Cond db r
cond Int
priority
where
go :: Cond db r -> Int -> Maybe (RenderS db r)
go (And Cond db r
a Cond db r
b) Int
p = Int
-> Int -> Utf8 -> Cond db r -> Cond db r -> Maybe (RenderS db r)
perhaps Int
andP Int
p Utf8
" AND " Cond db r
a Cond db r
b
go (Or Cond db r
a Cond db r
b) Int
p = Int
-> Int -> Utf8 -> Cond db r -> Cond db r -> Maybe (RenderS db r)
perhaps Int
orP Int
p Utf8
" OR " Cond db r
a Cond db r
b
go (Not Cond db r
CondEmpty) Int
_ = RenderS db r -> Maybe (RenderS db r)
forall a. a -> Maybe a
Just RenderS db r
"(1=0)"
go (Not Cond db r
a) Int
p = (\RenderS db r
a' -> Int -> Int -> RenderS db r -> RenderS db r
forall db r. Int -> Int -> RenderS db r -> RenderS db r
parens Int
notP Int
p (RenderS db r -> RenderS db r) -> RenderS db r -> RenderS db r
forall a b. (a -> b) -> a -> b
$ RenderS db r
"NOT " RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> RenderS db r
a') (RenderS db r -> RenderS db r)
-> Maybe (RenderS db r) -> Maybe (RenderS db r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cond db r -> Int -> Maybe (RenderS db r)
go Cond db r
a Int
notP
go (Compare ExprRelation
compOp UntypedExpr db r
f1 UntypedExpr db r
f2) Int
p =
case ExprRelation
compOp of
ExprRelation
Eq -> Int
-> RenderS db r
-> Int
-> [RenderS db r -> RenderS db r -> RenderS db r]
-> UntypedExpr db r
-> UntypedExpr db r
-> Maybe (RenderS db r)
renderCompOps Int
andP RenderS db r
" AND " Int
37 [RenderS db r -> RenderS db r -> RenderS db r]
ops UntypedExpr db r
f1 UntypedExpr db r
f2
where
ops :: [RenderS db r -> RenderS db r -> RenderS db r]
ops = (Bool -> RenderS db r -> RenderS db r -> RenderS db r)
-> [Bool] -> [RenderS db r -> RenderS db r -> RenderS db r]
forall a b. (a -> b) -> [a] -> [b]
map (\Bool
isNull -> if Bool
isNull then RenderS db r -> RenderS db r -> RenderS db r
forall db r.
SqlDb db =>
RenderS db r -> RenderS db r -> RenderS db r
equalsOperator else (\RenderS db r
a RenderS db r
b -> RenderS db r
a RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> Char -> RenderS db r
forall a. StringLike a => Char -> a
fromChar Char
'=' RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> RenderS db r
b)) [Bool]
eitherNullable
ExprRelation
Ne -> Int
-> RenderS db r
-> Int
-> [RenderS db r -> RenderS db r -> RenderS db r]
-> UntypedExpr db r
-> UntypedExpr db r
-> Maybe (RenderS db r)
renderCompOps Int
andP RenderS db r
" OR " Int
50 [RenderS db r -> RenderS db r -> RenderS db r]
ops UntypedExpr db r
f1 UntypedExpr db r
f2
where
ops :: [RenderS db r -> RenderS db r -> RenderS db r]
ops = (Bool -> RenderS db r -> RenderS db r -> RenderS db r)
-> [Bool] -> [RenderS db r -> RenderS db r -> RenderS db r]
forall a b. (a -> b) -> [a] -> [b]
map (\Bool
isNull -> if Bool
isNull then RenderS db r -> RenderS db r -> RenderS db r
forall db r.
SqlDb db =>
RenderS db r -> RenderS db r -> RenderS db r
notEqualsOperator else (\RenderS db r
a RenderS db r
b -> RenderS db r
a RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> RenderS db r
"<>" RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> RenderS db r
b)) [Bool]
eitherNullable
ExprRelation
Gt -> Int
-> RenderS db r
-> Int
-> (RenderS db r -> RenderS db r -> RenderS db r)
-> UntypedExpr db r
-> UntypedExpr db r
-> Maybe (RenderS db r)
renderComp Int
orP RenderS db r
" OR " Int
38 (\RenderS db r
a RenderS db r
b -> RenderS db r
a RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> Char -> RenderS db r
forall a. StringLike a => Char -> a
fromChar Char
'>' RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> RenderS db r
b) UntypedExpr db r
f1 UntypedExpr db r
f2
ExprRelation
Lt -> Int
-> RenderS db r
-> Int
-> (RenderS db r -> RenderS db r -> RenderS db r)
-> UntypedExpr db r
-> UntypedExpr db r
-> Maybe (RenderS db r)
renderComp Int
orP RenderS db r
" OR " Int
38 (\RenderS db r
a RenderS db r
b -> RenderS db r
a RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> Char -> RenderS db r
forall a. StringLike a => Char -> a
fromChar Char
'<' RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> RenderS db r
b) UntypedExpr db r
f1 UntypedExpr db r
f2
ExprRelation
Ge -> Int
-> RenderS db r
-> Int
-> (RenderS db r -> RenderS db r -> RenderS db r)
-> UntypedExpr db r
-> UntypedExpr db r
-> Maybe (RenderS db r)
renderComp Int
orP RenderS db r
" OR " Int
38 (\RenderS db r
a RenderS db r
b -> RenderS db r
a RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> RenderS db r
">=" RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> RenderS db r
b) UntypedExpr db r
f1 UntypedExpr db r
f2
ExprRelation
Le -> Int
-> RenderS db r
-> Int
-> (RenderS db r -> RenderS db r -> RenderS db r)
-> UntypedExpr db r
-> UntypedExpr db r
-> Maybe (RenderS db r)
renderComp Int
orP RenderS db r
" OR " Int
38 (\RenderS db r
a RenderS db r
b -> RenderS db r
a RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> RenderS db r
"<=" RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> RenderS db r
b) UntypedExpr db r
f1 UntypedExpr db r
f2
where
proxy :: Any db
proxy = forall a. HasCallStack => a
forall (proxy :: * -> *). proxy db
undefined :: proxy db
eitherNullable :: [Bool]
eitherNullable = (Bool -> Bool -> Bool) -> [Bool] -> [Bool] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
(||) (UntypedExpr db r -> [Bool]
nullables UntypedExpr db r
f1) (UntypedExpr db r -> [Bool]
nullables UntypedExpr db r
f2)
nullables :: UntypedExpr db r -> [Bool]
nullables UntypedExpr db r
expr = case UntypedExpr db r
expr of
ExprRaw DbType
t QueryRaw db r
_ -> DbType -> [Bool]
flattenNullables DbType
t
ExprField (([Char]
_, DbType
t), [([Char], EmbeddedDef' [Char] DbType)]
_) -> DbType -> [Bool]
flattenNullables DbType
t
ExprPure a
a -> DbType -> [Bool]
flattenNullables (DbType -> [Bool]) -> DbType -> [Bool]
forall a b. (a -> b) -> a -> b
$ Any db -> a -> DbType
forall a db (proxy :: * -> *).
(PersistField a, DbDescriptor db) =>
proxy db -> a -> DbType
dbType Any db
proxy a
a
ExprCond Cond db r
_ -> [Bool
False]
renderZip :: Int
-> (RenderS db r -> RenderS db r -> RenderS db r)
-> UntypedExpr db r
-> UntypedExpr db r
-> [RenderS db r]
renderZip Int
opP RenderS db r -> RenderS db r -> RenderS db r
op UntypedExpr db r
expr1 UntypedExpr db r
expr2 = (RenderS db r -> RenderS db r -> RenderS db r)
-> [RenderS db r] -> [RenderS db r] -> [RenderS db r]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith RenderS db r -> RenderS db r -> RenderS db r
op [RenderS db r]
expr1' [RenderS db r]
expr2'
where
expr1' :: [RenderS db r]
expr1' = RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
forall db r.
SqlDb db =>
RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
renderExprExtended RenderConfig
conf Int
opP UntypedExpr db r
expr1
expr2' :: [RenderS db r]
expr2' = RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
forall db r.
SqlDb db =>
RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
renderExprExtended RenderConfig
conf Int
opP UntypedExpr db r
expr2
renderZip3 :: Int
-> [RenderS db r -> RenderS db r -> RenderS db r]
-> UntypedExpr db r
-> UntypedExpr db r
-> [RenderS db r]
renderZip3 Int
opP [RenderS db r -> RenderS db r -> RenderS db r]
ops UntypedExpr db r
expr1 UntypedExpr db r
expr2 = ((RenderS db r -> RenderS db r -> RenderS db r)
-> RenderS db r -> RenderS db r -> RenderS db r)
-> [RenderS db r -> RenderS db r -> RenderS db r]
-> [RenderS db r]
-> [RenderS db r]
-> [RenderS db r]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (\RenderS db r -> RenderS db r -> RenderS db r
op RenderS db r
e1 RenderS db r
e2 -> RenderS db r -> RenderS db r -> RenderS db r
op RenderS db r
e1 RenderS db r
e2) [RenderS db r -> RenderS db r -> RenderS db r]
ops [RenderS db r]
expr1' [RenderS db r]
expr2'
where
expr1' :: [RenderS db r]
expr1' = RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
forall db r.
SqlDb db =>
RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
renderExprExtended RenderConfig
conf Int
opP UntypedExpr db r
expr1
expr2' :: [RenderS db r]
expr2' = RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
forall db r.
SqlDb db =>
RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
renderExprExtended RenderConfig
conf Int
opP UntypedExpr db r
expr2
groupComparisons :: Int
-> RenderS db r -> Int -> [RenderS db r] -> Maybe (RenderS db r)
groupComparisons Int
interP RenderS db r
interOp Int
opP [RenderS db r]
comparisons = case [RenderS db r]
comparisons of
[] -> Maybe (RenderS db r)
forall a. Maybe a
Nothing
[RenderS db r
clause] -> RenderS db r -> Maybe (RenderS db r)
forall a. a -> Maybe a
Just (RenderS db r -> Maybe (RenderS db r))
-> RenderS db r -> Maybe (RenderS db r)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> RenderS db r -> RenderS db r
forall db r. Int -> Int -> RenderS db r -> RenderS db r
parens (Int
opP Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
p RenderS db r
clause
[RenderS db r]
clauses -> RenderS db r -> Maybe (RenderS db r)
forall a. a -> Maybe a
Just (RenderS db r -> Maybe (RenderS db r))
-> RenderS db r -> Maybe (RenderS db r)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> RenderS db r -> RenderS db r
forall db r. Int -> Int -> RenderS db r -> RenderS db r
parens Int
interP Int
p (RenderS db r -> RenderS db r) -> RenderS db r -> RenderS db r
forall a b. (a -> b) -> a -> b
$ RenderS db r -> [RenderS db r] -> RenderS db r
forall s. StringLike s => s -> [s] -> s
intercalateS RenderS db r
interOp [RenderS db r]
clauses
renderComp :: Int
-> RenderS db r
-> Int
-> (RenderS db r -> RenderS db r -> RenderS db r)
-> UntypedExpr db r
-> UntypedExpr db r
-> Maybe (RenderS db r)
renderComp Int
interP RenderS db r
interOp Int
opP RenderS db r -> RenderS db r -> RenderS db r
op UntypedExpr db r
expr1 UntypedExpr db r
expr2 = Int
-> RenderS db r -> Int -> [RenderS db r] -> Maybe (RenderS db r)
groupComparisons Int
interP RenderS db r
interOp Int
opP ([RenderS db r] -> Maybe (RenderS db r))
-> [RenderS db r] -> Maybe (RenderS db r)
forall a b. (a -> b) -> a -> b
$ Int
-> (RenderS db r -> RenderS db r -> RenderS db r)
-> UntypedExpr db r
-> UntypedExpr db r
-> [RenderS db r]
renderZip Int
opP RenderS db r -> RenderS db r -> RenderS db r
op UntypedExpr db r
expr1 UntypedExpr db r
expr2
renderCompOps :: Int
-> RenderS db r
-> Int
-> [RenderS db r -> RenderS db r -> RenderS db r]
-> UntypedExpr db r
-> UntypedExpr db r
-> Maybe (RenderS db r)
renderCompOps Int
interP RenderS db r
interOp Int
opP [RenderS db r -> RenderS db r -> RenderS db r]
ops UntypedExpr db r
expr1 UntypedExpr db r
expr2 = Int
-> RenderS db r -> Int -> [RenderS db r] -> Maybe (RenderS db r)
groupComparisons Int
interP RenderS db r
interOp Int
opP ([RenderS db r] -> Maybe (RenderS db r))
-> [RenderS db r] -> Maybe (RenderS db r)
forall a b. (a -> b) -> a -> b
$ Int
-> [RenderS db r -> RenderS db r -> RenderS db r]
-> UntypedExpr db r
-> UntypedExpr db r
-> [RenderS db r]
renderZip3 Int
opP [RenderS db r -> RenderS db r -> RenderS db r]
ops UntypedExpr db r
expr1 UntypedExpr db r
expr2
go (CondRaw (Snippet f)) Int
p = case RenderConfig -> Int -> [RenderS db r]
f RenderConfig
conf Int
p of
[] -> Maybe (RenderS db r)
forall a. Maybe a
Nothing
[RenderS db r
a] -> RenderS db r -> Maybe (RenderS db r)
forall a. a -> Maybe a
Just RenderS db r
a
[RenderS db r]
_ -> [Char] -> Maybe (RenderS db r)
forall a. HasCallStack => [Char] -> a
error [Char]
"renderCond: cannot render CondRaw with many elements"
go Cond db r
CondEmpty Int
_ = Maybe (RenderS db r)
forall a. Maybe a
Nothing
notP :: Int
notP = Int
35
andP :: Int
andP = Int
30
orP :: Int
orP = Int
20
perhaps :: Int
-> Int -> Utf8 -> Cond db r -> Cond db r -> Maybe (RenderS db r)
perhaps Int
p Int
pOuter Utf8
op Cond db r
a Cond db r
b = Maybe (RenderS db r)
result
where
(Int
p', Maybe (RenderS db r)
result) = case (Cond db r -> Int -> Maybe (RenderS db r)
go Cond db r
a Int
p', Cond db r -> Int -> Maybe (RenderS db r)
go Cond db r
b Int
p') of
(Just RenderS db r
a', Just RenderS db r
b') -> (Int
p, RenderS db r -> Maybe (RenderS db r)
forall a. a -> Maybe a
Just (RenderS db r -> Maybe (RenderS db r))
-> RenderS db r -> Maybe (RenderS db r)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> RenderS db r -> RenderS db r
forall db r. Int -> Int -> RenderS db r -> RenderS db r
parens Int
p Int
pOuter (RenderS db r -> RenderS db r) -> RenderS db r -> RenderS db r
forall a b. (a -> b) -> a -> b
$ RenderS db r
a' RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
forall db r.
Utf8 -> ([PersistValue] -> [PersistValue]) -> RenderS db r
RenderS Utf8
op [PersistValue] -> [PersistValue]
forall a. a -> a
id RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> RenderS db r
b')
(Just RenderS db r
a', Maybe (RenderS db r)
Nothing) -> (Int
pOuter, RenderS db r -> Maybe (RenderS db r)
forall a. a -> Maybe a
Just RenderS db r
a')
(Maybe (RenderS db r)
Nothing, Just RenderS db r
b') -> (Int
pOuter, RenderS db r -> Maybe (RenderS db r)
forall a. a -> Maybe a
Just RenderS db r
b')
(Maybe (RenderS db r)
Nothing, Maybe (RenderS db r)
Nothing) -> (Int
pOuter, Maybe (RenderS db r)
forall a. Maybe a
Nothing)
{-# INLINEABLE renderChain #-}
renderChain :: RenderConfig -> FieldChain -> [Utf8] -> [Utf8]
renderChain :: RenderConfig -> FieldChain -> [Utf8] -> [Utf8]
renderChain RenderConfig {Utf8 -> Utf8
esc :: Utf8 -> Utf8
esc :: RenderConfig -> Utf8 -> Utf8
..} (([Char], DbType)
f, [([Char], EmbeddedDef' [Char] DbType)]
prefix) [Utf8]
acc =
case [([Char], EmbeddedDef' [Char] DbType)]
prefix of
(([Char]
name, EmbeddedDef Bool
False [([Char], DbType)]
_) : [([Char], EmbeddedDef' [Char] DbType)]
fs) -> (Utf8 -> Utf8)
-> Maybe Utf8 -> ([Char], DbType) -> [Utf8] -> [Utf8]
forall s.
StringLike s =>
(s -> s) -> Maybe s -> ([Char], DbType) -> [s] -> [s]
flattenP Utf8 -> Utf8
esc (Utf8 -> Maybe Utf8
forall a. a -> Maybe a
Just (Utf8 -> Maybe Utf8) -> Utf8 -> Maybe Utf8
forall a b. (a -> b) -> a -> b
$ Utf8 -> [([Char], EmbeddedDef' [Char] DbType)] -> Utf8
forall p str dbType.
StringLike p =>
p -> [([Char], EmbeddedDef' str dbType)] -> p
goP ([Char] -> Utf8
forall a. IsString a => [Char] -> a
fromString [Char]
name) [([Char], EmbeddedDef' [Char] DbType)]
fs) ([Char], DbType)
f [Utf8]
acc
[([Char], EmbeddedDef' [Char] DbType)]
_ -> (Utf8 -> Utf8) -> ([Char], DbType) -> [Utf8] -> [Utf8]
forall s.
StringLike s =>
(s -> s) -> ([Char], DbType) -> [s] -> [s]
flatten Utf8 -> Utf8
esc ([Char], DbType)
f [Utf8]
acc
where
goP :: p -> [([Char], EmbeddedDef' str dbType)] -> p
goP p
p (([Char]
name, EmbeddedDef Bool
False [(str, dbType)]
_) : [([Char], EmbeddedDef' str dbType)]
fs) = p -> [([Char], EmbeddedDef' str dbType)] -> p
goP ([Char] -> p
forall a. IsString a => [Char] -> a
fromString [Char]
name p -> p -> p
forall a. Semigroup a => a -> a -> a
<> Char -> p
forall a. StringLike a => Char -> a
fromChar Char
delim p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
p) [([Char], EmbeddedDef' str dbType)]
fs
goP p
p [([Char], EmbeddedDef' str dbType)]
_ = p
p
defaultShowPrim :: PersistValue -> String
defaultShowPrim :: PersistValue -> [Char]
defaultShowPrim (PersistString [Char]
x) = [Char]
"'" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"
defaultShowPrim (PersistText Text
x) = [Char]
"'" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"
defaultShowPrim (PersistByteString ByteString
x) = [Char]
"'" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"
defaultShowPrim (PersistInt64 Int64
x) = Int64 -> [Char]
forall a. Show a => a -> [Char]
show Int64
x
defaultShowPrim (PersistDouble Double
x) = Double -> [Char]
forall a. Show a => a -> [Char]
show Double
x
defaultShowPrim (PersistBool Bool
x) = if Bool
x then [Char]
"1" else [Char]
"0"
defaultShowPrim (PersistDay Day
x) = Day -> [Char]
forall a. Show a => a -> [Char]
show Day
x
defaultShowPrim (PersistTimeOfDay TimeOfDay
x) = TimeOfDay -> [Char]
forall a. Show a => a -> [Char]
show TimeOfDay
x
defaultShowPrim (PersistUTCTime UTCTime
x) = UTCTime -> [Char]
forall a. Show a => a -> [Char]
show UTCTime
x
defaultShowPrim (PersistZonedTime ZT
x) = ZT -> [Char]
forall a. Show a => a -> [Char]
show ZT
x
defaultShowPrim PersistValue
PersistNull = [Char]
"NULL"
defaultShowPrim (PersistCustom Utf8
_ [PersistValue]
_) = [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpected PersistCustom"
{-# INLINEABLE renderOrders #-}
renderOrders :: SqlDb db => RenderConfig -> [Order db r] -> RenderS db r
renderOrders :: RenderConfig -> [Order db r] -> RenderS db r
renderOrders RenderConfig
_ [] = RenderS db r
forall a. Monoid a => a
mempty
renderOrders RenderConfig
conf [Order db r]
xs = if [RenderS db r] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenderS db r]
orders then RenderS db r
forall a. Monoid a => a
mempty else RenderS db r
" ORDER BY " RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> [RenderS db r] -> RenderS db r
forall s. StringLike s => [s] -> s
commasJoin [RenderS db r]
orders
where
orders :: [RenderS db r]
orders = (Order db r -> [RenderS db r]) -> [Order db r] -> [RenderS db r]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Order db r -> [RenderS db r]
go [Order db r]
xs
rend :: RenderConfig -> p -> [RenderS db r]
rend RenderConfig
conf' p
a = (UntypedExpr db r -> RenderS db r)
-> [UntypedExpr db r] -> [RenderS db r]
forall a b. (a -> b) -> [a] -> [b]
map ([RenderS db r] -> RenderS db r
forall s. StringLike s => [s] -> s
commasJoin ([RenderS db r] -> RenderS db r)
-> (UntypedExpr db r -> [RenderS db r])
-> UntypedExpr db r
-> RenderS db r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
forall db r.
SqlDb db =>
RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
renderExprExtended RenderConfig
conf' Int
0) ([UntypedExpr db r] -> [RenderS db r])
-> [UntypedExpr db r] -> [RenderS db r]
forall a b. (a -> b) -> a -> b
$ p -> [UntypedExpr db r] -> [UntypedExpr db r]
forall p a db r.
(Projection p a, DbDescriptor db, ProjectionDb p db,
ProjectionRestriction p r) =>
p -> [UntypedExpr db r] -> [UntypedExpr db r]
projectionExprs p
a []
go :: Order db r -> [RenderS db r]
go (Asc f
a) = RenderConfig -> f -> [RenderS db r]
forall p db r a.
(ProjectionDb p db, ProjectionRestriction p r, SqlDb db,
Projection p a) =>
RenderConfig -> p -> [RenderS db r]
rend RenderConfig
conf f
a
go (Desc f
a) = RenderConfig -> f -> [RenderS db r]
forall p db r a.
(ProjectionDb p db, ProjectionRestriction p r, SqlDb db,
Projection p a) =>
RenderConfig -> p -> [RenderS db r]
rend RenderConfig
conf' f
a
where
conf' :: RenderConfig
conf' = RenderConfig
conf {esc :: Utf8 -> Utf8
esc = \Utf8
f -> RenderConfig -> Utf8 -> Utf8
esc RenderConfig
conf Utf8
f Utf8 -> Utf8 -> Utf8
forall a. Semigroup a => a -> a -> a
<> Utf8
" DESC"}
{-# INLINEABLE renderFields #-}
{-# SPECIALIZE renderFields :: (Utf8 -> Utf8) -> [(String, DbType)] -> Utf8 #-}
renderFields :: StringLike s => (s -> s) -> [(String, DbType)] -> s
renderFields :: (s -> s) -> [([Char], DbType)] -> s
renderFields s -> s
escape = [s] -> s
forall s. StringLike s => [s] -> s
commasJoin ([s] -> s)
-> ([([Char], DbType)] -> [s]) -> [([Char], DbType)] -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], DbType) -> [s] -> [s])
-> [s] -> [([Char], DbType)] -> [s]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((s -> s) -> ([Char], DbType) -> [s] -> [s]
forall s.
StringLike s =>
(s -> s) -> ([Char], DbType) -> [s] -> [s]
flatten s -> s
escape) []
{-# SPECIALIZE flatten :: (Utf8 -> Utf8) -> (String, DbType) -> ([Utf8] -> [Utf8]) #-}
flatten :: StringLike s => (s -> s) -> (String, DbType) -> ([s] -> [s])
flatten :: (s -> s) -> ([Char], DbType) -> [s] -> [s]
flatten s -> s
escape = (s -> s) -> Maybe s -> ([Char], DbType) -> [s] -> [s]
forall s.
StringLike s =>
(s -> s) -> Maybe s -> ([Char], DbType) -> [s] -> [s]
flattenP s -> s
escape Maybe s
forall a. Maybe a
Nothing
{-# SPECIALIZE flattenP :: (Utf8 -> Utf8) -> Maybe Utf8 -> (String, DbType) -> ([Utf8] -> [Utf8]) #-}
flattenP :: StringLike s => (s -> s) -> Maybe s -> (String, DbType) -> ([s] -> [s])
flattenP :: (s -> s) -> Maybe s -> ([Char], DbType) -> [s] -> [s]
flattenP s -> s
escape Maybe s
prefix ([Char]
fname, DbType
typ) [s]
acc = DbType -> [s]
go DbType
typ
where
go :: DbType -> [s]
go DbType
typ' = case DbType
typ' of
DbEmbedded EmbeddedDef' [Char] DbType
emb Maybe ParentTableReference
_ -> EmbeddedDef' [Char] DbType -> [s]
handleEmb EmbeddedDef' [Char] DbType
emb
DbType
_ -> s -> s
escape s
fullName s -> [s] -> [s]
forall a. a -> [a] -> [a]
: [s]
acc
fullName :: s
fullName = case Maybe s
prefix of
Maybe s
Nothing -> [Char] -> s
forall a. IsString a => [Char] -> a
fromString [Char]
fname
Just s
prefix' -> s
prefix' s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Char -> s
forall a. StringLike a => Char -> a
fromChar Char
delim s -> s -> s
forall a. Semigroup a => a -> a -> a
<> [Char] -> s
forall a. IsString a => [Char] -> a
fromString [Char]
fname
handleEmb :: EmbeddedDef' [Char] DbType -> [s]
handleEmb (EmbeddedDef Bool
False [([Char], DbType)]
ts) = (([Char], DbType) -> [s] -> [s])
-> [s] -> [([Char], DbType)] -> [s]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((s -> s) -> Maybe s -> ([Char], DbType) -> [s] -> [s]
forall s.
StringLike s =>
(s -> s) -> Maybe s -> ([Char], DbType) -> [s] -> [s]
flattenP s -> s
escape (s -> Maybe s
forall a. a -> Maybe a
Just s
fullName)) [s]
acc [([Char], DbType)]
ts
handleEmb (EmbeddedDef Bool
True [([Char], DbType)]
ts) = (([Char], DbType) -> [s] -> [s])
-> [s] -> [([Char], DbType)] -> [s]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((s -> s) -> Maybe s -> ([Char], DbType) -> [s] -> [s]
forall s.
StringLike s =>
(s -> s) -> Maybe s -> ([Char], DbType) -> [s] -> [s]
flattenP s -> s
escape Maybe s
forall a. Maybe a
Nothing) [s]
acc [([Char], DbType)]
ts
commasJoin :: StringLike s => [s] -> s
commasJoin :: [s] -> s
commasJoin = s -> [s] -> s
forall s. StringLike s => s -> [s] -> s
intercalateS (Char -> s
forall a. StringLike a => Char -> a
fromChar Char
',')
{-# INLINEABLE intercalateS #-}
intercalateS :: StringLike s => s -> [s] -> s
intercalateS :: s -> [s] -> s
intercalateS s
_ [] = s
forall a. Monoid a => a
mempty
intercalateS s
a (s
x : [s]
xs) = s
x s -> s -> s
forall a. Semigroup a => a -> a -> a
<> [s] -> s
go [s]
xs
where
go :: [s] -> s
go [] = s
forall a. Monoid a => a
mempty
go (s
f : [s]
fs) = s
a s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
f s -> s -> s
forall a. Semigroup a => a -> a -> a
<> [s] -> s
go [s]
fs
{-# INLINEABLE renderUpdates #-}
renderUpdates :: SqlDb db => RenderConfig -> [Update db r] -> Maybe (RenderS db r)
renderUpdates :: RenderConfig -> [Update db r] -> Maybe (RenderS db r)
renderUpdates RenderConfig
conf [Update db r]
upds =
case (Update db r -> Maybe (RenderS db r))
-> [Update db r] -> [RenderS db r]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Update db r -> Maybe (RenderS db r)
go [Update db r]
upds of
[] -> Maybe (RenderS db r)
forall a. Maybe a
Nothing
[RenderS db r]
xs -> RenderS db r -> Maybe (RenderS db r)
forall a. a -> Maybe a
Just (RenderS db r -> Maybe (RenderS db r))
-> RenderS db r -> Maybe (RenderS db r)
forall a b. (a -> b) -> a -> b
$ [RenderS db r] -> RenderS db r
forall s. StringLike s => [s] -> s
commasJoin [RenderS db r]
xs
where
go :: Update db r -> Maybe (RenderS db r)
go (Update f
field UntypedExpr db r
expr) = RenderS db r -> Maybe (RenderS db r)
guard (RenderS db r -> Maybe (RenderS db r))
-> RenderS db r -> Maybe (RenderS db r)
forall a b. (a -> b) -> a -> b
$ [RenderS db r] -> RenderS db r
forall s. StringLike s => [s] -> s
commasJoin ([RenderS db r] -> RenderS db r) -> [RenderS db r] -> RenderS db r
forall a b. (a -> b) -> a -> b
$ (RenderS db r -> RenderS db r -> RenderS db r)
-> [RenderS db r] -> [RenderS db r] -> [RenderS db r]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\RenderS db r
f1 RenderS db r
f2 -> RenderS db r
f1 RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> Char -> RenderS db r
forall a. StringLike a => Char -> a
fromChar Char
'=' RenderS db r -> RenderS db r -> RenderS db r
forall a. Semigroup a => a -> a -> a
<> RenderS db r
f2) [RenderS db r]
fs (UntypedExpr db r -> [RenderS db r]
rend UntypedExpr db r
expr)
where
rend :: UntypedExpr db r -> [RenderS db r]
rend = RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
forall db r.
SqlDb db =>
RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
renderExprExtended RenderConfig
conf Int
0
fs :: [RenderS db r]
fs = (UntypedExpr db r -> [RenderS db r])
-> [UntypedExpr db r] -> [RenderS db r]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UntypedExpr db r -> [RenderS db r]
rend (f -> [UntypedExpr db r] -> [UntypedExpr db r]
forall p a db r.
(Projection p a, DbDescriptor db, ProjectionDb p db,
ProjectionRestriction p r) =>
p -> [UntypedExpr db r] -> [UntypedExpr db r]
projectionExprs f
field [])
guard :: RenderS db r -> Maybe (RenderS db r)
guard RenderS db r
a = if [RenderS db r] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenderS db r]
fs then Maybe (RenderS db r)
forall a. Maybe a
Nothing else RenderS db r -> Maybe (RenderS db r)
forall a. a -> Maybe a
Just RenderS db r
a
{-# SPECIALIZE tableName :: (Utf8 -> Utf8) -> EntityDef -> ConstructorDef -> Utf8 #-}
tableName :: StringLike s => (s -> s) -> EntityDef -> ConstructorDef -> s
tableName :: (s -> s) -> EntityDef -> ConstructorDef -> s
tableName s -> s
esc EntityDef
e ConstructorDef
c = (s -> s) -> EntityDef -> s -> s
forall s. StringLike s => (s -> s) -> EntityDef -> s -> s
qualifySchema s -> s
esc EntityDef
e s
tName
where
tName :: s
tName =
s -> s
esc (s -> s) -> s -> s
forall a b. (a -> b) -> a -> b
$
if [ConstructorDef] -> Bool
isSimple (EntityDef -> [ConstructorDef]
forall str dbType.
EntityDef' str dbType -> [ConstructorDef' str dbType]
constructors EntityDef
e)
then [Char] -> s
forall a. IsString a => [Char] -> a
fromString ([Char] -> s) -> [Char] -> s
forall a b. (a -> b) -> a -> b
$ EntityDef -> [Char]
forall str dbType. EntityDef' str dbType -> str
entityName EntityDef
e
else [Char] -> s
forall a. IsString a => [Char] -> a
fromString (EntityDef -> [Char]
forall str dbType. EntityDef' str dbType -> str
entityName EntityDef
e) s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Char -> s
forall a. StringLike a => Char -> a
fromChar Char
delim s -> s -> s
forall a. Semigroup a => a -> a -> a
<> [Char] -> s
forall a. IsString a => [Char] -> a
fromString (ConstructorDef -> [Char]
forall str dbType. ConstructorDef' str dbType -> str
constrName ConstructorDef
c)
{-# SPECIALIZE mainTableName :: (Utf8 -> Utf8) -> EntityDef -> Utf8 #-}
mainTableName :: StringLike s => (s -> s) -> EntityDef -> s
mainTableName :: (s -> s) -> EntityDef -> s
mainTableName s -> s
esc EntityDef
e = (s -> s) -> EntityDef -> s -> s
forall s. StringLike s => (s -> s) -> EntityDef -> s -> s
qualifySchema s -> s
esc EntityDef
e s
tName
where
tName :: s
tName = s -> s
esc (s -> s) -> s -> s
forall a b. (a -> b) -> a -> b
$ [Char] -> s
forall a. IsString a => [Char] -> a
fromString ([Char] -> s) -> [Char] -> s
forall a b. (a -> b) -> a -> b
$ EntityDef -> [Char]
forall str dbType. EntityDef' str dbType -> str
entityName EntityDef
e
{-# SPECIALIZE qualifySchema :: (Utf8 -> Utf8) -> EntityDef -> Utf8 -> Utf8 #-}
qualifySchema :: StringLike s => (s -> s) -> EntityDef -> s -> s
qualifySchema :: (s -> s) -> EntityDef -> s -> s
qualifySchema s -> s
esc EntityDef
e s
name = s -> ([Char] -> s) -> Maybe [Char] -> s
forall b a. b -> (a -> b) -> Maybe a -> b
maybe s
name (\[Char]
sch -> s -> s
esc ([Char] -> s
forall a. IsString a => [Char] -> a
fromString [Char]
sch) s -> s -> s
forall a. Semigroup a => a -> a -> a
<> Char -> s
forall a. StringLike a => Char -> a
fromChar Char
'.' s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
name) (Maybe [Char] -> s) -> Maybe [Char] -> s
forall a b. (a -> b) -> a -> b
$ EntityDef -> Maybe [Char]
forall str dbType. EntityDef' str dbType -> Maybe str
entitySchema EntityDef
e