{-# LANGUAGE
DeriveGeneric
, FlexibleContexts
, GADTs
, GeneralizedNewtypeDeriving
, LambdaCase
, OverloadedStrings
, RankNTypes
, TypeInType
, TypeOperators
#-}
module Squeal.PostgreSQL.Manipulation
(
Manipulation (UnsafeManipulation, renderManipulation)
, queryStatement
, ColumnValue (..)
, ReturningClause (ReturningStar, Returning)
, ConflictClause (OnConflictDoRaise, OnConflictDoNothing, OnConflictDoUpdate)
, insertRows
, insertRow
, insertRows_
, insertRow_
, insertQuery
, insertQuery_
, renderReturningClause
, renderConflictClause
, update
, update_
, deleteFrom
, deleteFrom_
, with
) where
import Control.DeepSeq
import Data.ByteString hiding (foldr)
import Data.Monoid
import qualified Generics.SOP as SOP
import qualified GHC.Generics as GHC
import Squeal.PostgreSQL.Expression
import Squeal.PostgreSQL.Render
import Squeal.PostgreSQL.Query
import Squeal.PostgreSQL.Schema
newtype Manipulation
(schema :: SchemaType)
(params :: [NullityType])
(columns :: RelationType)
= UnsafeManipulation { renderManipulation :: ByteString }
deriving (GHC.Generic,Show,Eq,Ord,NFData)
instance RenderSQL (Manipulation schema params columns) where
renderSQL = renderManipulation
queryStatement
:: Query schema params columns
-> Manipulation schema params columns
queryStatement q = UnsafeManipulation $ renderQuery q
insertRows
:: ( SOP.SListI columns
, SOP.SListI results
, Has tab schema ('Table table)
, columns ~ TableToColumns table )
=> Alias tab
-> NP (Aliased (ColumnValue schema '[] params)) columns
-> [NP (Aliased (ColumnValue schema '[] params)) columns]
-> ConflictClause schema columns params
-> ReturningClause schema columns params results
-> Manipulation schema params results
insertRows tab rw rws conflict returning = UnsafeManipulation $
"INSERT" <+> "INTO" <+> renderAlias tab
<+> parenthesized (renderCommaSeparated renderAliasPart rw)
<+> "VALUES"
<+> commaSeparated
( parenthesized
. renderCommaSeparated renderColumnValuePart <$> rw:rws )
<> renderConflictClause conflict
<> renderReturningClause returning
where
renderAliasPart, renderColumnValuePart
:: Aliased (ColumnValue schema '[] params) ty -> ByteString
renderAliasPart (_ `As` name) = renderAlias name
renderColumnValuePart (value `As` _) = case value of
Default -> "DEFAULT"
Set expression -> renderExpression expression
insertRow
:: ( SOP.SListI columns
, SOP.SListI results
, Has tab schema ('Table table)
, columns ~ TableToColumns table )
=> Alias tab
-> NP (Aliased (ColumnValue schema '[] params)) columns
-> ConflictClause schema columns params
-> ReturningClause schema columns params results
-> Manipulation schema params results
insertRow tab rw = insertRows tab rw []
insertRows_
:: ( SOP.SListI columns
, Has tab schema ('Table table)
, columns ~ TableToColumns table )
=> Alias tab
-> NP (Aliased (ColumnValue schema '[] params)) columns
-> [NP (Aliased (ColumnValue schema '[] params)) columns]
-> Manipulation schema params '[]
insertRows_ tab rw rws =
insertRows tab rw rws OnConflictDoRaise (Returning Nil)
insertRow_
:: ( SOP.SListI columns
, Has tab schema ('Table table)
, columns ~ TableToColumns table )
=> Alias tab
-> NP (Aliased (ColumnValue schema '[] params)) columns
-> Manipulation schema params '[]
insertRow_ tab rw = insertRow tab rw OnConflictDoRaise (Returning Nil)
insertQuery
:: ( SOP.SListI columns
, SOP.SListI results
, Has tab schema ('Table table)
, columns ~ TableToColumns table )
=> Alias tab
-> Query schema params (ColumnsToRelation columns)
-> ConflictClause schema columns params
-> ReturningClause schema columns params results
-> Manipulation schema params results
insertQuery tab query conflict returning = UnsafeManipulation $
"INSERT" <+> "INTO" <+> renderAlias tab
<+> renderQuery query
<> renderConflictClause conflict
<> renderReturningClause returning
insertQuery_
:: ( SOP.SListI columns
, Has tab schema ('Table table)
, columns ~ TableToColumns table )
=> Alias tab
-> Query schema params (ColumnsToRelation columns)
-> Manipulation schema params '[]
insertQuery_ tab query =
insertQuery tab query OnConflictDoRaise (Returning Nil)
data ColumnValue
(schema :: SchemaType)
(columns :: RelationType)
(params :: [NullityType])
(ty :: ColumnType)
where
Same :: ColumnValue schema (column ': columns) params ty
Default :: ColumnValue schema columns params ('Def :=> ty)
Set
:: (forall table. Expression schema '[table ::: columns] 'Ungrouped params ty)
-> ColumnValue schema columns params (constraint :=> ty)
data ReturningClause
(schema :: SchemaType)
(columns :: ColumnsType)
(params :: [NullityType])
(results :: RelationType)
where
ReturningStar
:: results ~ ColumnsToRelation columns
=> ReturningClause schema columns params results
Returning
:: rel ~ ColumnsToRelation columns
=> NP (Aliased (Expression schema '[table ::: rel] 'Ungrouped params)) results
-> ReturningClause schema columns params results
renderReturningClause
:: SOP.SListI results
=> ReturningClause schema params columns results
-> ByteString
renderReturningClause = \case
ReturningStar -> " RETURNING *"
Returning Nil -> ""
Returning results -> " RETURNING"
<+> renderCommaSeparated (renderAliasedAs renderExpression) results
data ConflictClause (schema :: SchemaType) (columns :: ColumnsType) params where
OnConflictDoRaise :: ConflictClause schema columns params
OnConflictDoNothing :: ConflictClause schema columns params
OnConflictDoUpdate
:: NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns
-> [Condition schema '[table ::: ColumnsToRelation columns] 'Ungrouped params]
-> ConflictClause schema columns params
renderConflictClause
:: SOP.SListI columns
=> ConflictClause schema columns params
-> ByteString
renderConflictClause = \case
OnConflictDoRaise -> ""
OnConflictDoNothing -> " ON CONFLICT DO NOTHING"
OnConflictDoUpdate updates whs'
-> " ON CONFLICT DO UPDATE SET"
<+> renderCommaSeparatedMaybe renderUpdate updates
<> case whs' of
[] -> ""
wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)
where
renderUpdate
:: Aliased (ColumnValue schema columns params) column
-> Maybe ByteString
renderUpdate = \case
Same `As` _ -> Nothing
Default `As` column -> Just $
renderAlias column <+> "=" <+> "DEFAULT"
Set expression `As` column -> Just $
renderAlias column <+> "=" <+> renderExpression expression
update
:: ( SOP.SListI columns
, SOP.SListI results
, Has tab schema ('Table table)
, columns ~ TableToColumns table )
=> Alias tab
-> NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns
-> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params
-> ReturningClause schema columns params results
-> Manipulation schema params results
update tab columns wh returning = UnsafeManipulation $
"UPDATE"
<+> renderAlias tab
<+> "SET"
<+> renderCommaSeparatedMaybe renderUpdate columns
<+> "WHERE" <+> renderExpression wh
<> renderReturningClause returning
where
renderUpdate
:: Aliased (ColumnValue schema columns params) column
-> Maybe ByteString
renderUpdate = \case
Same `As` _ -> Nothing
Default `As` column -> Just $
renderAlias column <+> "=" <+> "DEFAULT"
Set expression `As` column -> Just $
renderAlias column <+> "=" <+> renderExpression expression
update_
:: ( SOP.SListI columns
, Has tab schema ('Table table)
, columns ~ TableToColumns table )
=> Alias tab
-> NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns
-> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params
-> Manipulation schema params '[]
update_ tab columns wh = update tab columns wh (Returning Nil)
deleteFrom
:: ( SOP.SListI results
, Has tab schema ('Table table)
, columns ~ TableToColumns table )
=> Alias tab
-> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params
-> ReturningClause schema columns params results
-> Manipulation schema params results
deleteFrom tab wh returning = UnsafeManipulation $
"DELETE FROM" <+> renderAlias tab
<+> "WHERE" <+> renderExpression wh
<> renderReturningClause returning
deleteFrom_
:: ( Has tab schema ('Table table)
, columns ~ TableToColumns table )
=> Alias tab
-> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params
-> Manipulation schema params '[]
deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil)
with
:: SOP.SListI commons
=> NP (Aliased (Manipulation schema params)) (common ': commons)
-> Manipulation (With (common ': commons) schema) params results
-> Manipulation schema params results
with commons manipulation = UnsafeManipulation $
"WITH" <+> renderCommaSeparated renderCommon commons
<+> renderManipulation manipulation
where
renderCommon
:: Aliased (Manipulation schema params) common
-> ByteString
renderCommon (common `As` alias) =
renderAlias alias <+> "AS" <+>
parenthesized (renderManipulation common)