Allow specifying a conflict_target for ON CONFLICT DO NOTHING

changelog.d/20251030_125129_shane.obrien_OnConflict.md

@@ -0,0 +1,9 @@
+### Added
+
+- 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`.
+- 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`.
+
+### Changed
+
+- 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).
+- 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

@@ -360,6 +360,8 @@ module Rel8
     -- ** @INSERT@
   , Insert(..)
   , OnConflict(..)
+  , Conflict (..)
+  , Index (..)
   , Upsert(..)
   , insert
   , unsafeDefault

src/Rel8/Statement/Insert.hs

@@ -50,7 +50,7 @@ data Insert a where
     , rows :: Query exprs
       -- ^ The rows to insert. This can be an arbitrary query — use
       -- 'Rel8.values' insert a static list of rows.
-    , onConflict :: OnConflict names
+    , onConflict :: OnConflict exprs
       -- ^ What to do if the inserted rows conflict with data already in the
       -- table.
     , returning :: Returning names a

src/Rel8/Statement/OnConflict.hs

@@ -11,13 +11,14 @@
 
 module Rel8.Statement.OnConflict
   ( OnConflict(..)
+  , Conflict (..)
+  , Index (..)
   , Upsert(..)
   , ppOnConflict
   )
 where
 
 -- base
-import Data.Foldable ( toList )
 import Data.Kind ( Type )
 import Prelude
 
@@ -31,28 +32,32 @@ import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )
 -- rel8
 import Rel8.Expr ( Expr )
 import Rel8.Expr.Opaleye (toPrimExpr)
-import Rel8.Schema.Name ( Name, Selects, ppColumn )
+import Rel8.Schema.Escape (escape)
+import Rel8.Schema.Name ( Selects )
+import Rel8.Schema.HTable (hfoldMap)
 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 )
 
 
 -- | 'OnConflict' represents the @ON CONFLICT@ clause of an @INSERT@
 -- statement. This specifies what ought to happen when one or more of the
 -- rows proposed for insertion conflict with an existing row in the table.
 type OnConflict :: Type -> Type
-data OnConflict names
+data OnConflict exprs
   = Abort
     -- ^ Abort the transaction if there are conflicting rows (Postgres' default)
-  | DoNothing
-    -- ^ @ON CONFLICT DO NOTHING@
-  | DoUpdate (Upsert names)
-    -- ^ @ON CONFLICT DO UPDATE@
+  | DoNothing (Maybe (Conflict exprs))
+    -- ^ @ON CONFLICT DO NOTHING@, or @ON CONFLICT (...) DO NOTHING@ if an
+    -- explicit conflict target  is supplied. Specifying a conflict target is
+    -- essential when your table has has deferrable constraints — @ON
+    -- CONFLICT@ can't work on deferrable constraints, so it's necessary
+    -- to explicitly name one of its non-deferrable constraints in order to
+    -- use @ON CONFLICT@.
+  | DoUpdate (Upsert exprs)
+    -- ^ @ON CONFLICT (...) DO UPDATE ...@
 
 
 -- | The @ON CONFLICT (...) DO UPDATE@ clause of an @INSERT@ statement, also
@@ -69,35 +74,75 @@ data OnConflict names
 -- are specified by listing the columns that comprise them along with an
 -- optional predicate in the case of partial indexes.
 type Upsert :: Type -> Type
-data Upsert names where
-  Upsert :: (Selects names exprs, Projecting names index, excluded ~ exprs) =>
-    { index :: Projection names index
-      -- ^ The set of columns comprising the @UNIQUE@ index that forms our
-      -- conflict target, projected from the set of columns for the whole
-      -- table
-    , predicate :: Maybe (exprs -> Expr Bool)
-      -- ^ An optional predicate used to specify a
-      -- [partial index](https://www.postgresql.org/docs/current/indexes-partial.html).
+data Upsert exprs where
+  Upsert :: excluded ~ exprs =>
+    { conflict :: Conflict exprs
+      -- ^ The conflict target to supply to @DO UPDATE@.
     , set :: excluded -> exprs -> exprs
       -- ^ How to update each selected row.
     , updateWhere :: excluded -> exprs -> Expr Bool
       -- ^ Which rows to select for update.
     }
-    -> Upsert names
+    -> Upsert exprs
+
+
+-- | Represents what PostgreSQL calls a
+-- [@conflict_target@](https://www.postgresql.org/docs/current/sql-insert.html#SQL-ON-CONFLICT)
+-- in an @ON CONFLICT@ clause of an @INSERT@ statement.
+type Conflict :: Type -> Type
+data Conflict exprs
+  = OnConstraint String
+  -- ^ Use a specific named constraint for the conflict target. This
+  -- corresponds the the syntax @ON CONFLICT constraint@ in PostgreSQL.
+  | OnIndex (Index exprs)
+  -- ^ Have PostgreSQL perform what it calls _unique index inference_ by
+  -- giving it a description of the target index.
+
+
+-- | A description of the target unique index — its columns (and/or
+-- expressions) and, in the case of partial indexes, a predicate.
+type Index :: Type -> Type
+data Index exprs where
+  Index :: Table Expr index =>
+    { columns :: exprs -> index
+      -- ^ The set of columns and/or expressions comprising the @UNIQUE@ index
+    , predicate :: Maybe (exprs -> Expr Bool)
+      -- ^ An optional predicate used to specify a
+      -- [partial index](https://www.postgresql.org/docs/current/indexes-partial.html).
+    }
+    -> Index exprs
 
 
-ppOnConflict :: TableSchema names -> OnConflict names -> Doc
-ppOnConflict schema = \case
+ppOnConflict :: Selects names exprs => TableSchema names -> OnConflict exprs -> Doc
+ppOnConflict schema@TableSchema {columns} = \case
   Abort -> mempty
-  DoNothing -> text "ON CONFLICT DO NOTHING"
-  DoUpdate upsert -> ppUpsert schema upsert
+  DoNothing conflict -> text "ON CONFLICT" <+> foldMap (ppConflict row) conflict <+> text "DO NOTHING"
+  DoUpdate upsert -> ppUpsert schema row upsert
+  where
+    row = view columns
+
 
+ppConflict :: exprs -> Conflict exprs -> Doc
+ppConflict row = \case
+  OnConstraint name -> "ON CONSTRAINT" <+> escape name
+  OnIndex index -> ppIndex row index
 
-ppUpsert :: TableSchema names -> Upsert names -> Doc
-ppUpsert schema@TableSchema {columns} Upsert {..} =
-  text "ON CONFLICT" <+>
-  ppIndex columns index <+> foldMap (ppPredicate columns) predicate <+>
-  text "DO UPDATE" $$
+
+ppIndex :: exprs -> Index exprs -> Doc
+ppIndex row Index {columns, predicate} =
+  parens (Opaleye.commaH id exprs) <>
+  foldMap (ppPredicate . ($ row)) predicate
+  where
+    exprs = hfoldMap (pure . parens . ppExpr) $ toColumns $ columns row
+
+
+ppPredicate :: Expr Bool -> Doc
+ppPredicate condition = text "WHERE" <+> ppExpr condition
+
+
+ppUpsert :: Selects names exprs => TableSchema names -> exprs -> Upsert exprs -> Doc
+ppUpsert schema@TableSchema {columns} row Upsert {..} =
+  text "ON CONFLICT" <+> ppConflict row conflict <+> "DO UPDATE" $$
   ppSet schema (set excluded) $$
   ppWhere schema (updateWhere excluded)
   where
@@ -107,16 +152,5 @@ ppUpsert schema@TableSchema {columns} Upsert {..} =
       }
 
 
-ppIndex :: (Table Name names, Projecting names index)
-  => names -> Projection names index -> Doc
-ppIndex columns index =
-  parens $ Opaleye.commaV ppColumn $ toList $
-    showNames $ Cols $ apply index $ toColumns columns
-
-
-ppPredicate :: Selects names exprs
-  => names -> (exprs -> Expr Bool) -> Doc
-ppPredicate schema where_ = text "WHERE" <+> ppExpr condition
-  where
-    ppExpr = Opaleye.ppSqlExpr . Opaleye.sqlExpr . toPrimExpr
-    condition = where_ (view schema)
+ppExpr :: Expr a -> Doc
+ppExpr = Opaleye.ppSqlExpr . Opaleye.sqlExpr . toPrimExpr

src/Rel8/Table/Verify.hs

@@ -1,35 +1,34 @@
-
 {-# language BlockArguments #-}
-{-# language LambdaCase #-}
-{-# language RecordWildCards #-}
-{-# language RankNTypes #-}
-{-# language DuplicateRecordFields #-}
-{-# language DerivingStrategies #-}
-{-# language OverloadedRecordDot #-}
-{-# language TypeApplications #-}
-{-# language NamedFieldPuns #-}
-{-# language ScopedTypeVariables #-}
-{-# language StandaloneDeriving #-}
 {-# language DeriveAnyClass #-}
+{-# language DeriveGeneric #-}
+{-# language DerivingStrategies #-}
+{-# language DuplicateRecordFields #-}
 {-# language FlexibleContexts #-}
 {-# language FlexibleInstances #-}
-{-# language DeriveGeneric #-}
+{-# language GADTs #-}
 {-# language GeneralizedNewtypeDeriving #-}
+{-# language LambdaCase #-}
+{-# language NamedFieldPuns #-}
+{-# language OverloadedRecordDot #-}
 {-# language OverloadedStrings #-}
-{-# language GADTs #-}
+{-# language RankNTypes #-}
+{-# language RecordWildCards #-}
+{-# language ScopedTypeVariables #-}
+{-# language StandaloneDeriving #-}
+{-# language TypeApplications #-}
+{-# options_ghc -Wno-partial-fields #-}
 
 module Rel8.Table.Verify
-    ( getSchemaErrors
-    , SomeTableSchema(..)
-    , showCreateTable
-    , checkedShowCreateTable
-    ) where
+  ( getSchemaErrors
+  , SomeTableSchema(..)
+  , showCreateTable
+  , checkedShowCreateTable
+  )
+where
 
 -- base
-import Control.Monad
 import Data.Bits (shiftR, (.&.))
-import Data.Either (lefts)
-import Data.Function
+import Data.Function ((&))
 import Data.Functor ((<&>))
 import Data.Functor.Const
 import Data.Functor.Contravariant ( (>$<) )
@@ -48,32 +47,45 @@ import qualified Prelude as P
 import qualified Data.Map as M
 
 -- hasql
-import Hasql.Connection
 import qualified Hasql.Statement as HS
 
 -- rel8
-import Rel8 -- not importing this seems to cause a type error???
 import Rel8.Column ( Column )
 import Rel8.Column.List ( HList )
 import Rel8.Expr ( Expr )
+import Rel8.Expr.Eq ((==.))
+import Rel8.Expr.Ord ((>.))
+import Rel8.Expr.Order (asc)
 import Rel8.Generic.Rel8able (GFromExprs, Rel8able)
 import Rel8.Query ( Query )
+import Rel8.Query.Each (each)
+import Rel8.Query.Filter (filter)
+import Rel8.Query.List (many)
+import Rel8.Query.Order (orderBy)
 import Rel8.Schema.HTable
 import Rel8.Schema.Name ( Name(Name) )
 import Rel8.Schema.Null hiding (nullable)
-import qualified Rel8.Schema.Null as Null
-import qualified Rel8.Statement.Run as RSR
-import Rel8.Schema.Table ( TableSchema(..) )
-import Rel8.Schema.Spec
-import Rel8.Schema.Result ( Result )
 import Rel8.Schema.QualifiedName ( QualifiedName(..) )
-import Rel8.Table ( Columns )
+import Rel8.Schema.Result ( Result )
+import Rel8.Schema.Spec (Spec (Spec))
+import qualified Rel8.Schema.Spec
+import Rel8.Schema.Table ( TableSchema(..) )
+import Rel8.Statement.Run (run1)
+import Rel8.Statement.Select (select)
+import Rel8.Table (Columns, toColumns)
 import Rel8.Table.List ( ListTable )
-import Rel8.Table.Serialize ( ToExprs )
+import Rel8.Table.Name (namesFromLabelsWith)
+import Rel8.Table.Rel8able ()
+import Rel8.Table.Serialize (ToExprs, lit)
 import Rel8.Type ( DBType(..) )
 import Rel8.Type.Eq ( DBEq )
+import Rel8.Type.Information (parseTypeInformation)
+import qualified Rel8.Type.Information
 import Rel8.Type.Name ( TypeName(..) )
 
+-- semialign
+import Data.Semialign (align)
+
 -- these
 import Data.These
 
@@ -338,7 +350,7 @@ showCreateTable_helper name typeMap = "CREATE TABLE " <> show name <> " ("
     ++ "\n);"
   where
     go :: (String, TypeInfo) -> String
-    go (name, typeInfo) = "\n    " ++ show name ++ " " ++ showTypeInfo typeInfo
+    go (name', typeInfo) = "\n    " ++ show name' ++ " " ++ showTypeInfo typeInfo
 
 
 -- |@'showCreateTable'@ shows an example CREATE TABLE statement for the table.
@@ -378,17 +390,9 @@ checkTypeEquality env db hs
     sameMods = db.typeName.modifiers == hs.typeName.modifiers
     sameDims = db.typeName.arrayDepth == hs.typeName.arrayDepth
 
-    sameName = equalName db.typeName.name hs.typeName.name
-
     toName :: TypeInfo -> String
     toName typeInfo = case typeInfo.typeName.name of
-        QualifiedName name _ -> L.dropWhile (=='_') name
-
-equalName :: QualifiedName -> QualifiedName -> Bool
-equalName (QualifiedName a (Just b)) (QualifiedName a' (Just b'))
-  = L.dropWhile (=='_') a == L.dropWhile (=='_') a' && b == b'
-equalName (QualifiedName a _) (QualifiedName a' _)
-  = dropWhile (=='_') a == dropWhile (=='_') a'
+        QualifiedName name _ -> L.dropWhile (== '_') name
 
 -- check types for a single table
 compareTypes
@@ -430,7 +434,7 @@ compareTypes env attrMap typeMap = fmap (uncurry go) $ M.assocs (disjointUnion a
                 (T.unpack attr.typ.typname)
                 (Just $ T.unpack attr.namespace.nspname)
             , modifiers = toModifier
-                (T.dropWhile (=='_') attr.typ.typname)
+                (T.dropWhile (== '_') attr.typ.typname)
                 attr.attribute.atttypmod
             , arrayDepth = fromIntegral attr.attribute.attndims
             }
@@ -444,14 +448,10 @@ compareTypes env attrMap typeMap = fmap (uncurry go) $ M.assocs (disjointUnion a
     toModifier _ _ = []
 
     disjointUnion :: Ord k => M.Map k a -> M.Map k b -> M.Map k (These a b)
-    disjointUnion a b = M.unionWith go (fmap This a) (fmap That b)
-      where
-        go :: These a b -> These a b -> These a b
-        go (This a) (That b) = These a b
-        go _ _ = undefined
+    disjointUnion = align
 
 
--- |@pShowTable@ is a helper function which takes a grid of text and prints it
+-- |@pShowTable@ i's a helper f'unction which takes a grid of text and prints' it'
 -- as a table, with padding so that cells are lined in columns, and a bordered
 -- header for the first row
 pShowTable :: [[Text]] -> Text
@@ -464,7 +464,7 @@ pShowTable xs
   where
     addHeaderBorder :: [Text] -> [Text]
     addHeaderBorder [] = []
-    addHeaderBorder (x : xs) = x : T.replicate (T.length x) "-" : xs
+    addHeaderBorder (a : as) = a : T.replicate (T.length a) "-" : as
 
     xs' :: [[Text]]
     xs' = L.transpose xs
@@ -489,8 +489,8 @@ pShowErrors = T.intercalate "\n\n" . fmap go
         [ "Table "
         , T.pack (show name)
         , " 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."
-        , pShowTable (["DB name", "Haskell label"] : (M.assocs duplicates <&> \(name, typs) ->
-            [ T.pack name
+        , pShowTable (["DB name", "Haskell label"] : (M.assocs duplicates <&> \(name', typs) ->
+            [ T.pack name'
             , T.intercalate " " $ fmap (\typ -> T.intercalate "/" $ fmap T.pack typ.label) $ NonEmpty.toList typs
             ]))
         ]
@@ -531,8 +531,8 @@ showTypeInfo typeInfo = concat
     ]
   where
     name = case typeInfo.typeName.name of
-        QualifiedName a Nothing -> show (dropWhile (=='_') a)
-        QualifiedName a (Just b) -> show b <> "." <> show (dropWhile (=='_') a)
+        QualifiedName a Nothing -> show (dropWhile (== '_') a)
+        QualifiedName a (Just b) -> show b <> "." <> show (dropWhile (== '_') a)
 
     modifiers :: [String]
     modifiers = typeInfo.typeName.modifiers