{-# language DuplicateRecordFields #-}
{-# language FlexibleContexts #-}
{-# language GADTs #-}
{-# language LambdaCase #-}
{-# language NamedFieldPuns #-}
{-# language OverloadedStrings #-}
{-# language RecordWildCards #-}
{-# language StandaloneKindSignatures #-}
{-# language StrictData #-}
{-# language TypeOperators #-}
module Rel8.Statement.OnConflict
( OnConflict(..)
, Upsert(..)
, ppOnConflict
)
where
import Data.Foldable ( toList )
import Data.Kind ( Type )
import Prelude
import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
import qualified Opaleye.Internal.Sql as Opaleye
import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )
import Rel8.Expr ( Expr )
import Rel8.Expr.Opaleye (toPrimExpr)
import Rel8.Schema.Name ( Name, Selects, ppColumn )
import Rel8.Schema.Table ( TableSchema(..) )
import Rel8.Statement.Set ( ppSet )
import Rel8.Statement.Where ( ppWhere )
import Rel8.Table ( Table, toColumns )
import Rel8.Table.Cols ( Cols( Cols ) )
import Rel8.Table.Name ( showNames )
import Rel8.Table.Opaleye (attributes, view)
import Rel8.Table.Projection ( Projecting, Projection, apply )
type OnConflict :: Type -> Type
data OnConflict names
= Abort
| DoNothing
| DoUpdate (Upsert names)
type Upsert :: Type -> Type
data Upsert names where
Upsert :: (Selects names exprs, Projecting names index, excluded ~ exprs) =>
{ ()
index :: Projection names index
, ()
predicate :: Maybe (exprs -> Expr Bool)
, ()
set :: excluded -> exprs -> exprs
, ()
updateWhere :: excluded -> exprs -> Expr Bool
}
-> Upsert names
ppOnConflict :: TableSchema names -> OnConflict names -> Doc
ppOnConflict :: forall names. TableSchema names -> OnConflict names -> Doc
ppOnConflict TableSchema names
schema = \case
OnConflict names
Abort -> Doc
forall a. Monoid a => a
mempty
OnConflict names
DoNothing -> String -> Doc
text String
"ON CONFLICT DO NOTHING"
DoUpdate Upsert names
upsert -> TableSchema names -> Upsert names -> Doc
forall names. TableSchema names -> Upsert names -> Doc
ppUpsert TableSchema names
schema Upsert names
upsert
ppUpsert :: TableSchema names -> Upsert names -> Doc
ppUpsert :: forall names. TableSchema names -> Upsert names -> Doc
ppUpsert schema :: TableSchema names
schema@TableSchema {names
columns :: names
$sel:columns:TableSchema :: forall names. TableSchema names -> names
columns} Upsert {Maybe (exprs -> Expr Bool)
excluded -> exprs -> exprs
excluded -> exprs -> Expr Bool
Projection names index
$sel:index:Upsert :: ()
$sel:predicate:Upsert :: ()
$sel:set:Upsert :: ()
$sel:updateWhere:Upsert :: ()
index :: Projection names index
predicate :: Maybe (exprs -> Expr Bool)
set :: excluded -> exprs -> exprs
updateWhere :: excluded -> exprs -> Expr Bool
..} =
String -> Doc
text String
"ON CONFLICT" Doc -> Doc -> Doc
<+>
names -> Projection names index -> Doc
forall names index.
(Table Name names, Projecting names index) =>
names -> Projection names index -> Doc
ppIndex names
columns Projection names index
index Doc -> Doc -> Doc
<+> ((exprs -> Expr Bool) -> Doc) -> Maybe (exprs -> Expr Bool) -> Doc
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: Context) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (names -> (exprs -> Expr Bool) -> Doc
forall names exprs.
Selects names exprs =>
names -> (exprs -> Expr Bool) -> Doc
ppPredicate names
columns) Maybe (exprs -> Expr Bool)
predicate Doc -> Doc -> Doc
<+>
String -> Doc
text String
"DO UPDATE" Doc -> Doc -> Doc
$$
TableSchema names -> (exprs -> exprs) -> Doc
forall names exprs.
Selects names exprs =>
TableSchema names -> (exprs -> exprs) -> Doc
ppSet TableSchema names
schema (excluded -> exprs -> exprs
set excluded
excluded) Doc -> Doc -> Doc
$$
TableSchema names -> (exprs -> Expr Bool) -> Doc
forall names exprs.
Selects names exprs =>
TableSchema names -> (exprs -> Expr Bool) -> Doc
ppWhere TableSchema names
schema (excluded -> exprs -> Expr Bool
updateWhere excluded
excluded)
where
excluded :: excluded
excluded = TableSchema names -> excluded
forall names exprs.
Selects names exprs =>
TableSchema names -> exprs
attributes TableSchema
{ $sel:name:TableSchema :: QualifiedName
name = QualifiedName
"excluded"
, names
columns :: names
$sel:columns:TableSchema :: names
columns
}
ppIndex :: (Table Name names, Projecting names index)
=> names -> Projection names index -> Doc
ppIndex :: forall names index.
(Table Name names, Projecting names index) =>
names -> Projection names index -> Doc
ppIndex names
columns Projection names index
index =
Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
Opaleye.commaV String -> Doc
ppColumn ([String] -> Doc) -> [String] -> Doc
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
forall (t :: Context) a. Foldable t => t a -> [a]
toList (NonEmpty String -> [String]) -> NonEmpty String -> [String]
forall a b. (a -> b) -> a -> b
$
Cols Name (Columns index) -> NonEmpty String
forall a. Table Name a => a -> NonEmpty String
showNames (Cols Name (Columns index) -> NonEmpty String)
-> Cols Name (Columns index) -> NonEmpty String
forall a b. (a -> b) -> a -> b
$ Columns index Name -> Cols Name (Columns index)
forall (context :: Context) (columns :: HTable).
columns context -> Cols context columns
Cols (Columns index Name -> Cols Name (Columns index))
-> Columns index Name -> Cols Name (Columns index)
forall a b. (a -> b) -> a -> b
$ Projection names index -> Columns names Name -> Columns index Name
forall a b (context :: Context).
Projecting a b =>
Projection a b -> Columns a context -> Columns b context
apply Projection names index
index (Columns names Name -> Columns index Name)
-> Columns names Name -> Columns index Name
forall a b. (a -> b) -> a -> b
$ names -> Columns names Name
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns names
columns
ppPredicate :: Selects names exprs
=> names -> (exprs -> Expr Bool) -> Doc
ppPredicate :: forall names exprs.
Selects names exprs =>
names -> (exprs -> Expr Bool) -> Doc
ppPredicate names
schema exprs -> Expr Bool
where_ = String -> Doc
text String
"WHERE" Doc -> Doc -> Doc
<+> Expr Bool -> Doc
forall {a}. Expr a -> Doc
ppExpr Expr Bool
condition
where
ppExpr :: Expr a -> Doc
ppExpr = SqlExpr -> Doc
Opaleye.ppSqlExpr (SqlExpr -> Doc) -> (Expr a -> SqlExpr) -> Expr a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimExpr -> SqlExpr
Opaleye.sqlExpr (PrimExpr -> SqlExpr) -> (Expr a -> PrimExpr) -> Expr a -> SqlExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr a -> PrimExpr
forall a. Expr a -> PrimExpr
toPrimExpr
condition :: Expr Bool
condition = exprs -> Expr Bool
where_ (names -> exprs
forall names exprs. Selects names exprs => names -> exprs
view names
schema)