{-# LANGUAGE
DataKinds
, DeriveDataTypeable
, DeriveGeneric
, FlexibleContexts
, GADTs
, GeneralizedNewtypeDeriving
, KindSignatures
, LambdaCase
, OverloadedStrings
, RankNTypes
, StandaloneDeriving
, 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 Data.ByteString as ByteString
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 :: TablesType)
(params :: [NullityType])
(columns :: RelationType)
= UnsafeManipulation { renderManipulation :: ByteString }
deriving (GHC.Generic,Show,Eq,Ord,NFData)
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
, columns ~ TableToColumns table )
=> Alias tab
-> NP (Aliased (ColumnValue '[] params)) columns
-> [NP (Aliased (ColumnValue '[] params)) columns]
-> ConflictClause columns params
-> ReturningClause columns params results
-> Manipulation schema params results
insertRows tab row rows conflict returning = UnsafeManipulation $
"INSERT" <+> "INTO" <+> renderAlias tab
<+> parenthesized (renderCommaSeparated renderAliasPart row)
<+> "VALUES"
<+> commaSeparated
( parenthesized
. renderCommaSeparated renderColumnValuePart <$> row:rows )
<> renderConflictClause conflict
<> renderReturningClause returning
where
renderAliasPart, renderColumnValuePart
:: Aliased (ColumnValue '[] 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
, columns ~ TableToColumns table )
=> Alias tab
-> NP (Aliased (ColumnValue '[] params)) columns
-> ConflictClause columns params
-> ReturningClause columns params results
-> Manipulation schema params results
insertRow tab row = insertRows tab row []
insertRows_
:: ( SOP.SListI columns
, Has tab schema table
, columns ~ TableToColumns table )
=> Alias tab
-> NP (Aliased (ColumnValue '[] params)) columns
-> [NP (Aliased (ColumnValue '[] params)) columns]
-> Manipulation schema params '[]
insertRows_ tab row rows =
insertRows tab row rows OnConflictDoRaise (Returning Nil)
insertRow_
:: ( SOP.SListI columns
, Has tab schema table
, columns ~ TableToColumns table )
=> Alias tab
-> NP (Aliased (ColumnValue '[] params)) columns
-> Manipulation schema params '[]
insertRow_ tab row = insertRow tab row OnConflictDoRaise (Returning Nil)
insertQuery
:: ( SOP.SListI columns
, SOP.SListI results
, Has tab schema table
, columns ~ TableToColumns table )
=> Alias tab
-> Query schema params (ColumnsToRelation columns)
-> ConflictClause columns params
-> ReturningClause 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
, columns ~ TableToColumns table )
=> Alias tab
-> Query schema params (ColumnsToRelation columns)
-> Manipulation schema params '[]
insertQuery_ tab query =
insertQuery tab query OnConflictDoRaise (Returning Nil)
data ColumnValue
(columns :: RelationType)
(params :: [NullityType])
(ty :: ColumnType)
where
Same :: ColumnValue (column ': columns) params ty
Default :: ColumnValue columns params ('Def :=> ty)
Set
:: (forall table. Expression '[table ::: columns] 'Ungrouped params ty)
-> ColumnValue columns params (constraint :=> ty)
data ReturningClause
(columns :: ColumnsType)
(params :: [NullityType])
(results :: RelationType)
where
ReturningStar
:: results ~ ColumnsToRelation columns
=> ReturningClause columns params results
Returning
:: rel ~ ColumnsToRelation columns
=> NP (Aliased (Expression '[table ::: rel] 'Ungrouped params)) results
-> ReturningClause columns params results
renderReturningClause
:: SOP.SListI results
=> ReturningClause params columns results
-> ByteString
renderReturningClause = \case
ReturningStar -> " RETURNING *;"
Returning Nil -> ";"
Returning results -> " RETURNING"
<+> renderCommaSeparated (renderAliasedAs renderExpression) results <> ";"
data ConflictClause (columns :: ColumnsType) params where
OnConflictDoRaise :: ConflictClause columns params
OnConflictDoNothing :: ConflictClause columns params
OnConflictDoUpdate
:: NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns
-> [Condition '[table ::: ColumnsToRelation columns] 'Ungrouped params]
-> ConflictClause columns params
renderConflictClause
:: SOP.SListI columns
=> ConflictClause 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 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
, columns ~ TableToColumns table )
=> Alias tab
-> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns
-> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params
-> ReturningClause 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 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
, columns ~ TableToColumns table )
=> Alias tab
-> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns
-> Condition '[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
, columns ~ TableToColumns table )
=> Alias tab
-> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params
-> ReturningClause 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
, columns ~ TableToColumns table )
=> Alias tab
-> Condition '[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)) commons
-> Manipulation (Join (RelationsToTables 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" <+>
let
str = renderManipulation common
len = ByteString.length str
str' = ByteString.take (len - 1) str
in
parenthesized str'