Skip to content

Commit 1676e26

Browse files
shane-circuithubshane-circuithub
authored
Allow specifying a conflict_target for ON CONFLICT DO NOTHING (#392)
1 parent 7969088 commit 1676e26

File tree

7 files changed

+179
-110
lines changed

7 files changed

+179
-110
lines changed

‎changelog.d/20251030_125129_shane.obrien_OnConflict.md‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
### Added
2+
3+
- Added new `Conflict` and `Index` types. `Conflict` represents a [`conflict_target`](https://www.postgresql.org/docs/current/sql-insert.html#SQL-ON-CONFLICT) in an `ON CONFLICT`. It can be either a named constraint (`ON CONSTRAINT`) or a an `Index`.
4+
- Added `Index`. `Index` is a description of a unique index which PostgreSQL can use for *unique index inference*. This is an alternative to specifying an explicit named constraint in a `conflict_target`.
5+
6+
### Changed
7+
8+
- The `Upsert` type was changed. Previously it had the columns (`index`, `predicate`) of what is now the `Index` type baked into its record. It now instead has a single `conflict` column (of type `Conflict`, which can be either an `Index` or a named constraint).
9+
- The `DoNothing` constructor of `OnConflict` was changed to also take an optional `Conflict` value. Even though `ON CONFLICT DO NOTHING` does not generally require a `conflict_target`, there are cases where it can be necessary, e.g., if you have table that has both deferrable and non-deferrable constraints.

‎src/Rel8.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -360,6 +360,8 @@ module Rel8
360360
-- ** @INSERT@
361361
, Insert(..)
362362
, OnConflict(..)
363+
, Conflict (..)
364+
, Index (..)
363365
, Upsert(..)
364366
, insert
365367
, unsafeDefault

‎src/Rel8/Statement/Insert.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -50,7 +50,7 @@ data Insert a where
5050
, rows :: Query exprs
5151
-- ^ The rows to insert. This can be an arbitrary query — use
5252
-- 'Rel8.values' insert a static list of rows.
53-
, onConflict :: OnConflict names
53+
, onConflict :: OnConflict exprs
5454
-- ^ What to do if the inserted rows conflict with data already in the
5555
-- table.
5656
, returning :: Returning names a

‎src/Rel8/Statement/OnConflict.hs‎

Lines changed: 76 additions & 42 deletions
Original file line numberDiff line numberDiff line change
@@ -11,13 +11,14 @@
1111

1212
module Rel8.Statement.OnConflict
1313
( OnConflict(..)
14+
, Conflict (..)
15+
, Index (..)
1416
, Upsert(..)
1517
, ppOnConflict
1618
)
1719
where
1820

1921
-- base
20-
import Data.Foldable ( toList )
2122
import Data.Kind ( Type )
2223
import Prelude
2324

@@ -31,28 +32,32 @@ import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )
3132
-- rel8
3233
import Rel8.Expr ( Expr )
3334
import Rel8.Expr.Opaleye (toPrimExpr)
34-
import Rel8.Schema.Name ( Name, Selects, ppColumn )
35+
import Rel8.Schema.Escape (escape)
36+
import Rel8.Schema.Name ( Selects )
37+
import Rel8.Schema.HTable (hfoldMap)
3538
import Rel8.Schema.Table ( TableSchema(..) )
3639
import Rel8.Statement.Set ( ppSet )
3740
import Rel8.Statement.Where ( ppWhere )
3841
import Rel8.Table ( Table, toColumns )
39-
import Rel8.Table.Cols ( Cols( Cols ) )
40-
import Rel8.Table.Name ( showNames )
4142
import Rel8.Table.Opaleye (attributes, view)
42-
import Rel8.Table.Projection ( Projecting, Projection, apply )
4343

4444

4545
-- | 'OnConflict' represents the @ON CONFLICT@ clause of an @INSERT@
4646
-- statement. This specifies what ought to happen when one or more of the
4747
-- rows proposed for insertion conflict with an existing row in the table.
4848
type OnConflict :: Type -> Type
49-
data OnConflict names
49+
data OnConflict exprs
5050
= Abort
5151
-- ^ Abort the transaction if there are conflicting rows (Postgres' default)
52-
| DoNothing
53-
-- ^ @ON CONFLICT DO NOTHING@
54-
| DoUpdate (Upsert names)
55-
-- ^ @ON CONFLICT DO UPDATE@
52+
| DoNothing (Maybe (Conflict exprs))
53+
-- ^ @ON CONFLICT DO NOTHING@, or @ON CONFLICT (...) DO NOTHING@ if an
54+
-- explicit conflict target is supplied. Specifying a conflict target is
55+
-- essential when your table has has deferrable constraints — @ON
56+
-- CONFLICT@ can't work on deferrable constraints, so it's necessary
57+
-- to explicitly name one of its non-deferrable constraints in order to
58+
-- use @ON CONFLICT@.
59+
| DoUpdate (Upsert exprs)
60+
-- ^ @ON CONFLICT (...) DO UPDATE ...@
5661

5762

5863
-- | The @ON CONFLICT (...) DO UPDATE@ clause of an @INSERT@ statement, also
@@ -69,35 +74,75 @@ data OnConflict names
6974
-- are specified by listing the columns that comprise them along with an
7075
-- optional predicate in the case of partial indexes.
7176
type Upsert :: Type -> Type
72-
data Upsert names where
73-
Upsert :: (Selects names exprs, Projecting names index, excluded ~ exprs) =>
74-
{ index :: Projection names index
75-
-- ^ The set of columns comprising the @UNIQUE@ index that forms our
76-
-- conflict target, projected from the set of columns for the whole
77-
-- table
78-
, predicate :: Maybe (exprs -> Expr Bool)
79-
-- ^ An optional predicate used to specify a
80-
-- [partial index](https://www.postgresql.org/docs/current/indexes-partial.html).
77+
data Upsert exprs where
78+
Upsert :: excluded ~ exprs =>
79+
{ conflict :: Conflict exprs
80+
-- ^ The conflict target to supply to @DO UPDATE@.
8181
, set :: excluded -> exprs -> exprs
8282
-- ^ How to update each selected row.
8383
, updateWhere :: excluded -> exprs -> Expr Bool
8484
-- ^ Which rows to select for update.
8585
}
86-
-> Upsert names
86+
-> Upsert exprs
87+
88+
89+
-- | Represents what PostgreSQL calls a
90+
-- [@conflict_target@](https://www.postgresql.org/docs/current/sql-insert.html#SQL-ON-CONFLICT)
91+
-- in an @ON CONFLICT@ clause of an @INSERT@ statement.
92+
type Conflict :: Type -> Type
93+
data Conflict exprs
94+
= OnConstraint String
95+
-- ^ Use a specific named constraint for the conflict target. This
96+
-- corresponds the the syntax @ON CONFLICT constraint@ in PostgreSQL.
97+
| OnIndex (Index exprs)
98+
-- ^ Have PostgreSQL perform what it calls _unique index inference_ by
99+
-- giving it a description of the target index.
100+
101+
102+
-- | A description of the target unique index — its columns (and/or
103+
-- expressions) and, in the case of partial indexes, a predicate.
104+
type Index :: Type -> Type
105+
data Index exprs where
106+
Index :: Table Expr index =>
107+
{ columns :: exprs -> index
108+
-- ^ The set of columns and/or expressions comprising the @UNIQUE@ index
109+
, predicate :: Maybe (exprs -> Expr Bool)
110+
-- ^ An optional predicate used to specify a
111+
-- [partial index](https://www.postgresql.org/docs/current/indexes-partial.html).
112+
}
113+
-> Index exprs
87114

88115

89-
ppOnConflict :: TableSchema names -> OnConflict names -> Doc
90-
ppOnConflict schema = \case
116+
ppOnConflict :: Selects names exprs => TableSchema names -> OnConflict exprs -> Doc
117+
ppOnConflict schema@TableSchema {columns} = \case
91118
Abort -> mempty
92-
DoNothing -> text "ON CONFLICT DO NOTHING"
93-
DoUpdate upsert -> ppUpsert schema upsert
119+
DoNothing conflict -> text "ON CONFLICT" <+> foldMap (ppConflict row) conflict <+> text "DO NOTHING"
120+
DoUpdate upsert -> ppUpsert schema row upsert
121+
where
122+
row = view columns
123+
94124

125+
ppConflict :: exprs -> Conflict exprs -> Doc
126+
ppConflict row = \case
127+
OnConstraint name -> "ON CONSTRAINT" <+> escape name
128+
OnIndex index -> ppIndex row index
95129

96-
ppUpsert :: TableSchema names -> Upsert names -> Doc
97-
ppUpsert schema@TableSchema {columns} Upsert {..} =
98-
text "ON CONFLICT" <+>
99-
ppIndex columns index <+> foldMap (ppPredicate columns) predicate <+>
100-
text "DO UPDATE" $$
130+
131+
ppIndex :: exprs -> Index exprs -> Doc
132+
ppIndex row Index {columns, predicate} =
133+
parens (Opaleye.commaH id exprs) <>
134+
foldMap (ppPredicate . ($ row)) predicate
135+
where
136+
exprs = hfoldMap (pure . parens . ppExpr) $ toColumns $ columns row
137+
138+
139+
ppPredicate :: Expr Bool -> Doc
140+
ppPredicate condition = text "WHERE" <+> ppExpr condition
141+
142+
143+
ppUpsert :: Selects names exprs => TableSchema names -> exprs -> Upsert exprs -> Doc
144+
ppUpsert schema@TableSchema {columns} row Upsert {..} =
145+
text "ON CONFLICT" <+> ppConflict row conflict <+> "DO UPDATE" $$
101146
ppSet schema (set excluded) $$
102147
ppWhere schema (updateWhere excluded)
103148
where
@@ -107,16 +152,5 @@ ppUpsert schema@TableSchema {columns} Upsert {..} =
107152
}
108153

109154

110-
ppIndex :: (Table Name names, Projecting names index)
111-
=> names -> Projection names index -> Doc
112-
ppIndex columns index =
113-
parens $ Opaleye.commaV ppColumn $ toList $
114-
showNames $ Cols $ apply index $ toColumns columns
115-
116-
117-
ppPredicate :: Selects names exprs
118-
=> names -> (exprs -> Expr Bool) -> Doc
119-
ppPredicate schema where_ = text "WHERE" <+> ppExpr condition
120-
where
121-
ppExpr = Opaleye.ppSqlExpr . Opaleye.sqlExpr . toPrimExpr
122-
condition = where_ (view schema)
155+
ppExpr :: Expr a -> Doc
156+
ppExpr = Opaleye.ppSqlExpr . Opaleye.sqlExpr . toPrimExpr

‎src/Rel8/Table/Verify.hs‎

Lines changed: 52 additions & 52 deletions
Original file line numberDiff line numberDiff line change
@@ -1,35 +1,34 @@
1-
21
{-# language BlockArguments #-}
3-
{-# language LambdaCase #-}
4-
{-# language RecordWildCards #-}
5-
{-# language RankNTypes #-}
6-
{-# language DuplicateRecordFields #-}
7-
{-# language DerivingStrategies #-}
8-
{-# language OverloadedRecordDot #-}
9-
{-# language TypeApplications #-}
10-
{-# language NamedFieldPuns #-}
11-
{-# language ScopedTypeVariables #-}
12-
{-# language StandaloneDeriving #-}
132
{-# language DeriveAnyClass #-}
3+
{-# language DeriveGeneric #-}
4+
{-# language DerivingStrategies #-}
5+
{-# language DuplicateRecordFields #-}
146
{-# language FlexibleContexts #-}
157
{-# language FlexibleInstances #-}
16-
{-# language DeriveGeneric #-}
8+
{-# language GADTs #-}
179
{-# language GeneralizedNewtypeDeriving #-}
10+
{-# language LambdaCase #-}
11+
{-# language NamedFieldPuns #-}
12+
{-# language OverloadedRecordDot #-}
1813
{-# language OverloadedStrings #-}
19-
{-# language GADTs #-}
14+
{-# language RankNTypes #-}
15+
{-# language RecordWildCards #-}
16+
{-# language ScopedTypeVariables #-}
17+
{-# language StandaloneDeriving #-}
18+
{-# language TypeApplications #-}
19+
{-# options_ghc -Wno-partial-fields #-}
2020

2121
module Rel8.Table.Verify
22-
( getSchemaErrors
23-
, SomeTableSchema(..)
24-
, showCreateTable
25-
, checkedShowCreateTable
26-
) where
22+
( getSchemaErrors
23+
, SomeTableSchema(..)
24+
, showCreateTable
25+
, checkedShowCreateTable
26+
)
27+
where
2728

2829
-- base
29-
import Control.Monad
3030
import Data.Bits (shiftR, (.&.))
31-
import Data.Either (lefts)
32-
import Data.Function
31+
import Data.Function ((&))
3332
import Data.Functor ((<&>))
3433
import Data.Functor.Const
3534
import Data.Functor.Contravariant ( (>$<) )
@@ -48,32 +47,45 @@ import qualified Prelude as P
4847
import qualified Data.Map as M
4948

5049
-- hasql
51-
import Hasql.Connection
5250
import qualified Hasql.Statement as HS
5351

5452
-- rel8
55-
import Rel8 -- not importing this seems to cause a type error???
5653
import Rel8.Column ( Column )
5754
import Rel8.Column.List ( HList )
5855
import Rel8.Expr ( Expr )
56+
import Rel8.Expr.Eq ((==.))
57+
import Rel8.Expr.Ord ((>.))
58+
import Rel8.Expr.Order (asc)
5959
import Rel8.Generic.Rel8able (GFromExprs, Rel8able)
6060
import Rel8.Query ( Query )
61+
import Rel8.Query.Each (each)
62+
import Rel8.Query.Filter (filter)
63+
import Rel8.Query.List (many)
64+
import Rel8.Query.Order (orderBy)
6165
import Rel8.Schema.HTable
6266
import Rel8.Schema.Name ( Name(Name) )
6367
import Rel8.Schema.Null hiding (nullable)
64-
import qualified Rel8.Schema.Null as Null
65-
import qualified Rel8.Statement.Run as RSR
66-
import Rel8.Schema.Table ( TableSchema(..) )
67-
import Rel8.Schema.Spec
68-
import Rel8.Schema.Result ( Result )
6968
import Rel8.Schema.QualifiedName ( QualifiedName(..) )
70-
import Rel8.Table ( Columns )
69+
import Rel8.Schema.Result ( Result )
70+
import Rel8.Schema.Spec (Spec (Spec))
71+
import qualified Rel8.Schema.Spec
72+
import Rel8.Schema.Table ( TableSchema(..) )
73+
import Rel8.Statement.Run (run1)
74+
import Rel8.Statement.Select (select)
75+
import Rel8.Table (Columns, toColumns)
7176
import Rel8.Table.List ( ListTable )
72-
import Rel8.Table.Serialize ( ToExprs )
77+
import Rel8.Table.Name (namesFromLabelsWith)
78+
import Rel8.Table.Rel8able ()
79+
import Rel8.Table.Serialize (ToExprs, lit)
7380
import Rel8.Type ( DBType(..) )
7481
import Rel8.Type.Eq ( DBEq )
82+
import Rel8.Type.Information (parseTypeInformation)
83+
import qualified Rel8.Type.Information
7584
import Rel8.Type.Name ( TypeName(..) )
7685

86+
-- semialign
87+
import Data.Semialign (align)
88+
7789
-- these
7890
import Data.These
7991

@@ -338,7 +350,7 @@ showCreateTable_helper name typeMap = "CREATE TABLE " <> show name <> " ("
338350
++ "\n);"
339351
where
340352
go :: (String, TypeInfo) -> String
341-
go (name, typeInfo) = "\n " ++ show name ++ " " ++ showTypeInfo typeInfo
353+
go (name', typeInfo) = "\n " ++ show name' ++ " " ++ showTypeInfo typeInfo
342354

343355

344356
-- |@'showCreateTable'@ shows an example CREATE TABLE statement for the table.
@@ -378,17 +390,9 @@ checkTypeEquality env db hs
378390
sameMods = db.typeName.modifiers == hs.typeName.modifiers
379391
sameDims = db.typeName.arrayDepth == hs.typeName.arrayDepth
380392

381-
sameName = equalName db.typeName.name hs.typeName.name
382-
383393
toName :: TypeInfo -> String
384394
toName typeInfo = case typeInfo.typeName.name of
385-
QualifiedName name _ -> L.dropWhile (=='_') name
386-
387-
equalName :: QualifiedName -> QualifiedName -> Bool
388-
equalName (QualifiedName a (Just b)) (QualifiedName a' (Just b'))
389-
= L.dropWhile (=='_') a == L.dropWhile (=='_') a' && b == b'
390-
equalName (QualifiedName a _) (QualifiedName a' _)
391-
= dropWhile (=='_') a == dropWhile (=='_') a'
395+
QualifiedName name _ -> L.dropWhile (== '_') name
392396

393397
-- check types for a single table
394398
compareTypes
@@ -430,7 +434,7 @@ compareTypes env attrMap typeMap = fmap (uncurry go) $ M.assocs (disjointUnion a
430434
(T.unpack attr.typ.typname)
431435
(Just $ T.unpack attr.namespace.nspname)
432436
, modifiers = toModifier
433-
(T.dropWhile (=='_') attr.typ.typname)
437+
(T.dropWhile (== '_') attr.typ.typname)
434438
attr.attribute.atttypmod
435439
, arrayDepth = fromIntegral attr.attribute.attndims
436440
}
@@ -444,14 +448,10 @@ compareTypes env attrMap typeMap = fmap (uncurry go) $ M.assocs (disjointUnion a
444448
toModifier _ _ = []
445449

446450
disjointUnion :: Ord k => M.Map k a -> M.Map k b -> M.Map k (These a b)
447-
disjointUnion a b = M.unionWith go (fmap This a) (fmap That b)
448-
where
449-
go :: These a b -> These a b -> These a b
450-
go (This a) (That b) = These a b
451-
go _ _ = undefined
451+
disjointUnion = align
452452

453453

454-
-- |@pShowTable@ is a helper function which takes a grid of text and prints it
454+
-- |@pShowTable@ i's a helper f'unction which takes a grid of text and prints' it'
455455
-- as a table, with padding so that cells are lined in columns, and a bordered
456456
-- header for the first row
457457
pShowTable :: [[Text]] -> Text
@@ -464,7 +464,7 @@ pShowTable xs
464464
where
465465
addHeaderBorder :: [Text] -> [Text]
466466
addHeaderBorder [] = []
467-
addHeaderBorder (x : xs) = x : T.replicate (T.length x) "-" : xs
467+
addHeaderBorder (a : as) = a : T.replicate (T.length a) "-" : as
468468

469469
xs' :: [[Text]]
470470
xs' = L.transpose xs
@@ -489,8 +489,8 @@ pShowErrors = T.intercalate "\n\n" . fmap go
489489
[ "Table "
490490
, T.pack (show name)
491491
, " has multiple columns with the same name. This is an error with the Haskell code generating an impossible schema, rather than an error in your current setup of the database itself. Using 'namesFromLabels' can ensure each column has unique names, which is the easiest way to prevent this, but may require changing names in your database to match the new generated names."
492-
, pShowTable (["DB name", "Haskell label"] : (M.assocs duplicates <&> \(name, typs) ->
493-
[ T.pack name
492+
, pShowTable (["DB name", "Haskell label"] : (M.assocs duplicates <&> \(name', typs) ->
493+
[ T.pack name'
494494
, T.intercalate " " $ fmap (\typ -> T.intercalate "/" $ fmap T.pack typ.label) $ NonEmpty.toList typs
495495
]))
496496
]
@@ -531,8 +531,8 @@ showTypeInfo typeInfo = concat
531531
]
532532
where
533533
name = case typeInfo.typeName.name of
534-
QualifiedName a Nothing -> show (dropWhile (=='_') a)
535-
QualifiedName a (Just b) -> show b <> "." <> show (dropWhile (=='_') a)
534+
QualifiedName a Nothing -> show (dropWhile (== '_') a)
535+
QualifiedName a (Just b) -> show b <> "." <> show (dropWhile (== '_') a)
536536

537537
modifiers :: [String]
538538
modifiers = typeInfo.typeName.modifiers

0 commit comments

Comments
 (0)