pg-schema 0.7.1.2 → 0.8.0.0

raw patch · 20 files changed

+1420/−382 lines, 20 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog.md +19/−0
• pg-schema.cabal +9/−2
• src/PgSchema/Ann.hs +246/−7
• src/PgSchema/DML.hs +85/−29
• src/PgSchema/DML/Insert.hs +3/−2
• src/PgSchema/DML/Insert/Types.hs +44/−9
• src/PgSchema/DML/InsertJSON.hs +132/−107
• src/PgSchema/DML/KeyedWrite.hs +56/−0
• src/PgSchema/DML/Select.hs +59/−49
• src/PgSchema/DML/Select/Types.hs +46/−71
• src/PgSchema/DML/Update.hs +96/−6
• src/PgSchema/DML/UpsertByKey.hs +67/−0
• src/PgSchema/Schema.hs +73/−46
• src/PgSchema/Types.hs +5/−4
• test-pgs/Main.hs +27/−0
• test-pgs/Tests/BaseConverts.hs +6/−3
• test-pgs/Tests/Conditions.hs +96/−36
• test-pgs/Tests/Hierarchy.hs +13/−11
• test-pgs/Tests/KeyedDML.hs +308/−0
• test-pgs/Utils.hs +30/−0

@@ -1,5 +1,24 @@ # Changelog for pg-schema +## 0.8.0.0++- Fix SELECT path matching after renamer: promoted `PathElem'` (`peName`,+  `peDbName`, `peKind`) replaces `(Text, PathKind)`; runtime `pathStepMatches`+  supports point paths and broadcast by shared db fk name; independent filters+  on aliased sibling fields (e.g. `mid1RootFk` vs `mid1_root_fk2`).+- Internal SELECT paths: `[PathElemK]` in `PathCtx` / `TabOnDPathRen`; removed+  `EffPath` on renamer-only pairs; `TabOnDPath2` walks `peDbName`.+- Flat DML: `upsertByKey` / `upsertByKey_` and `updateByKey` / `updateByKey_`+  (`upsertByKey` requires all mandatory columns and a full key — always+  `INSERT … ON CONFLICT …`; `updateByKey` is key-only, never inserts, bare+  returning type `r'`, result `IO ([Maybe r'], Text)`).+- Tree DML: `updateJSON` / `updateJSON_` (update-only); `InsertMode` for the+  JSON pipeline.+- Tree returning: Maybe or Bare for `upsertJSON`.+- New constraints: `AllHasKeyTree`, `CheckHasKey`, `ReturningMatches{Insert,Upsert,Update}`,+  `FromJSON` / `ToJSON` for `Maybe` rows and `null` in returning arrays.+- Rename `TreeSch` to `HasSchema`+ ## 0.7.1.2 - Fix bug with aggregates (Min/Max/Sum/Avg) 

@@ -1,6 +1,6 @@ cabal-version:  3.12 name:           pg-schema-version:        0.7.1.2+version:        0.8.0.0 category:       Database author:         Dmitry Olshansky maintainer:     olshanskydr@gmail.com@@ -8,6 +8,10 @@ license:        BSD-3-Clause license-file:   LICENSE build-type:     Simple+tested-with:+  GHC ==9.10.3+  , GHC ==9.12.4+  , GHC ==9.14.1 synopsis:       Type-level definition of database schema and safe DML for PostgreSQL. description:     == Schema definition@@ -130,6 +134,8 @@     PgSchema.DML.Insert     PgSchema.DML.InsertJSON     PgSchema.DML.Insert.Types+    PgSchema.DML.KeyedWrite+    PgSchema.DML.UpsertByKey     PgSchema.DML.Select     PgSchema.DML.Select.Types     PgSchema.DML.Update@@ -252,7 +258,7 @@     Paths_pg_schema     PackageInfo_pg_schema   build-depends:-      base >= 4.21.0 && < 4.22+      base >= 4.20 && < 5     , bytestring >= 0.12.2 && < 0.13     , directory >= 1.3.9 && < 1.4     , pg-schema@@ -270,6 +276,7 @@     Tests.BaseConverts     Tests.Conditions     Tests.Hierarchy+    Tests.KeyedDML     Tests.InsertJSONTransaction     Tests.UpsertUniqueKey     Tests.Path

@@ -7,6 +7,8 @@ import qualified Data.Aeson.Key as Key import Data.Coerce import Data.Singletons.TH (genDefunSymbols)+import Data.Type.Bool+import Data.Type.Equality import Data.Typeable import Data.Text qualified as T import Data.Kind@@ -84,10 +86,15 @@   MapRen f '[] = '[]   MapRen f (x ': xs) = ApplyRenamer f x ': MapRen f xs -type family MapRenPath (f :: Renamer) (xs :: [(Symbol, PathKind)]) :: [(Symbol, PathKind)] where-  MapRenPath f '[] = '[]-  MapRenPath f ('(x, k) ': xs) = '(ApplyRenamer f x, k) ': MapRenPath f xs+-- | End table after walking @path@ from @t@.+type TabOnDPathRen ren sch t path = TabAtPath sch t path +-- | 'ToStar' for demotion and forced 'TabOnDPath2' walk (invalid edges error here).+type PathCtx ren sch t path =+  ( ToStar path+  , TabAtPath sch t path ~ TabAtPath sch t path+  )+ -------------------------------------------------------------------------------- -- Case dispatch --------------------------------------------------------------------------------@@ -95,6 +102,7 @@ data ColsCase = NonGenericCase | GenericCase  type family ColsCaseOf (r :: Type) :: ColsCase where+  ColsCaseOf (Maybe r)             = ColsCaseOf r   ColsCaseOf (a :. b)              = 'NonGenericCase   ColsCaseOf ((_ :: Symbol) := _) = 'NonGenericCase   ColsCaseOf r = 'GenericCase@@ -123,6 +131,7 @@ --------------------------------------------------------------------------------  type family ColsNonGeneric (ann :: Ann) r :: [ColInfo NameNSK] where+  ColsNonGeneric ann (Maybe r) = ColsNonGeneric ann r   ColsNonGeneric ann (a :. b) = Normalize (Cols ann a SP.++ Cols ann b)   ColsNonGeneric ann (fld := t) = Col ann fld t @@ -211,11 +220,24 @@     toJSON (PgTag r) = Object (KM.fromList (toPairs @ann @colsCase @cols r))     toEncoding (PgTag r) = pairs (foldMap (uncurry (.=)) $ toPairs @ann @colsCase @cols r) +type family RowNotMaybe (r :: Type) :: Constraint where+  RowNotMaybe (Maybe _) = TypeError+    ( Text "Use FromJSON (PgTag ann (Maybe r)) for optional top-level rows." )+  RowNotMaybe _ = ()+ instance-  (cols ~ Cols ann r, colsCase ~ ColsCaseOf r, FromJSONCols ann colsCase cols r)+  ( cols ~ Cols ann r, colsCase ~ ColsCaseOf r, FromJSONCols ann colsCase cols r+  , RowNotMaybe r )   => FromJSON (PgTag ann r) where    parseJSON v = PgTag <$> parseJSONCols @ann @colsCase @cols v +instance {-# OVERLAPPING #-}+  ( cols ~ Cols ann r, colsCase ~ ColsCaseOf r+  , FromJSONCols ann colsCase cols r )+  => FromJSON (PgTag ann (Maybe r)) where+   parseJSON Null = pure $ PgTag Nothing+   parseJSON v = PgTag . Just <$> parseJSONCols @ann @colsCase @cols v+ -- >>> type AnnRel = 'Ann RenamerId PgCatalog (PGC "pg_constraint") -- >>> rel = PgRelation{ constraint__namespace = PgTag "a", conname = "b", constraint__class = PgClassShort (PgTag "c") "d", constraint__fclass = PgClassShort (PgTag "e") "f", conkey = pgArr' [1,2], confkey = pgArr' [] } -- >>> rec = "conname" =: ("x" :: T.Text) :. "conname" =: ("z" :: T.Text) :. rel :. "conname" =: ("y" :: T.Text)@@ -255,6 +277,20 @@       where         keyTxt = demote @(NameSymNat sn) +instance+  ( cols ~ Cols ann r, colsCase ~ ColsCaseOf r+  , FromJSONCols ann colsCase cols r )+  => FromJSONCols ann colsCase cols (Maybe r) where+    parseJSONCols Null = pure Nothing+    parseJSONCols v = Just <$> parseJSONCols @ann @colsCase @cols v++instance+  ( cols ~ Cols ann r, colsCase ~ ColsCaseOf r+  , ToJSONCols ann colsCase cols r )+  => ToJSONCols ann colsCase cols (Maybe r) where+    toPairs Nothing = []+    toPairs (Just r) = toPairs @ann @colsCase @cols r+ -- Note: we use "split ~" instead of " '(colsA, colsB) ~ " to avoid ambiguity. instance   ( ca ~ ColsCaseOf a, cb ~ ColsCaseOf b@@ -357,10 +393,16 @@     toRow (PgTag r) = toRowCols @ann @colsCase @cols r  instance-  (cols ~ Cols ann r, colsCase ~ ColsCaseOf r, FromRowCols ann colsCase cols r)+  ( cols ~ Cols ann r, colsCase ~ ColsCaseOf r, FromRowCols ann colsCase cols r+  , RowNotMaybe r )   => FromRow (PgTag ann r) where     fromRow = PgTag <$> fromRowCols @ann @colsCase @cols +instance {-# OVERLAPPING #-}+  ( cols ~ Cols ann r, colsCase ~ ColsCaseOf r, FromRowCols ann colsCase cols r)+  => FromRow (PgTag ann (Maybe r)) where+    fromRow = PgTag . Just <$> fromRowCols @ann @colsCase @cols+ -- >>> type AnnRel = 'Ann RenamerId PgCatalog 1 (PGC "pg_constraint") -- >>> (r1 :: [PgTag AnnRel ( ("conkey" := Int16))]) <- query_ conn "select 1::int2" -- >>> r1@@ -690,8 +732,18 @@   HasAnyFullIdentity' '[] rs ks ann = ()   HasAnyFullIdentity' (_ ': _) rs ks ann = HasAnyFullIdentity rs ks ann -genDefunSymbols [ ''CheckAllMandatory, ''CheckAllMandatoryOrHasKey]+-- | Every node must include a full primary or eligible unique key.+type family CheckHasKey (ann :: Ann) (rs :: [Symbol]) :: Constraint where+  CheckHasKey ('Ann ren sch d tab) rs =+    HasAnyFullIdentity rs (IdentityCandidates sch tab) ('Ann ren sch d tab) +-- | All mandatory fields and a full primary or eligible unique key (flat upsert).+type CheckAllMandatoryAndHasKey ann rs =+  (CheckAllMandatory ann rs, CheckHasKey ann rs)++genDefunSymbols+  [ ''CheckAllMandatory, ''CheckAllMandatoryOrHasKey, ''CheckHasKey ]+ -------------------------------------------------------------------------------- -- Recursive AllMandatory / PK for tree (JSON insert / upsert) --------------------------------------------------------------------------------@@ -719,6 +771,12 @@   AllMandatoryOrHasKeyTree ann r rFlds =     WalkLevelAnn CheckAllMandatoryOrHasKeySym0 ann (TRecordInfo ann r) rFlds +type family AllHasKeyTree (ann :: Ann) (r :: Type) (rFlds :: [Symbol])+  :: Constraint where+  AllHasKeyTree ann [r] rFlds = AllHasKeyTree ann r rFlds+  AllHasKeyTree ann r rFlds =+    WalkLevelAnn CheckHasKeySym0 ann (TRecordInfo ann r) rFlds+ -------------------------------------------------------------------------------- -- Returning tree must be subtree of input tree (with path) --------------------------------------------------------------------------------@@ -750,7 +808,188 @@       , CheckSubtreeAt path fisIn xs )   CheckSubtreeAt path fisIn (_ ': xs) = CheckSubtreeAt path fisIn xs --- | Check that returning tree is a subtree of input tree+-- | Returning shape must be reachable from the input tree: each relation branch+-- in @rOut@ must exist in @rIn@. Plain columns in @rOut@ are not compared to @rIn@+-- (see 'CheckSubtreeAt'). Used by tree @*JSON@ returning rules, not flat DML. type family ReturningIsSubtree (ann :: Ann) (rIn :: Type) (rOut :: Type) :: Constraint where   ReturningIsSubtree ann rIn rOut =     CheckSubtreeAt '[] (TRecordInfo ann rIn) (TRecordInfo ann rOut)++--------------------------------------------------------------------------------+-- Returning row optionality (Maybe) vs input mandatory coverage+--------------------------------------------------------------------------------++type family AnnChild (ann :: Ann) (childTab :: NameNSK) :: Ann where+  AnnChild ('Ann ren sch _ _) childTab = 'Ann ren sch 0 childTab++type family InnerRow (r :: Type) :: Type where+  InnerRow (Maybe r) = r+  InnerRow r = TypeError+    ( Text "Update returning row must be wrapped in Maybe."+    :$$: Text "Got: " :<>: ShowType r )++type family RequireMaybeRow (r :: Type) :: Constraint where+  RequireMaybeRow (Maybe _) = ()+  RequireMaybeRow r = TypeError+    ( Text "Update returning row must be Maybe ..."+    :$$: Text "Got: " :<>: ShowType r )++-- | Flat @RETURNING@ row must not be wrapped in @Maybe@ (use @IO [Maybe r']@ on+-- 'updateByKey' for per-row absence). Nullable columns may still be @Maybe@ fields.+type family RequireBareRow (r :: Type) :: Constraint where+  RequireBareRow r = RequireBareRow' r++type family RequireBareRow' (r :: Type) :: Constraint where+  RequireBareRow' (Maybe x) = TypeError+    ( Text "Flat returning row must not be wrapped in Maybe."+    :$$: Text "Use IO [Maybe r'] on updateByKey when a row may be absent."+    :$$: Text "Got: " :<>: ShowType (Maybe x) )+  RequireBareRow' _ = ()++type family ListElem (t :: Type) :: Type where+  ListElem [e] = e+  ListElem t = TypeError+    ( Text "Expected a Haskell list type for a child branch."+    :$$: Text "Got: " :<>: ShowType t )++type family SymNatName (sn :: SymNat) :: Symbol where+  SymNatName '(s, _) = s++type family ColTypeByJsonName (name :: Symbol) (cols :: [ColInfo NameNSK]) :: Type where+  ColTypeByJsonName name '[] = TypeError+    ( Text "Returning field not found in output type: " :<>: ShowType name )+  ColTypeByJsonName name ('ColInfo sn t _ _ ': xs) =+    If (SymNatName sn == name) t (ColTypeByJsonName name xs)++type family CoveredRs (ann :: Ann) (fis :: [FieldInfo Symbol]) :: [Symbol] where+  CoveredRs ann '[] = '[]+  CoveredRs ann ('FieldInfo _ db ('RFPlain _) ': xs) = db ': CoveredRs ann xs+  CoveredRs ('Ann ren sch d tab)+    ('FieldInfo _ _ ('RFToHere ('RecordInfo _ _) _) ': xs) =+    CoveredRs ('Ann ren sch d tab) xs+  CoveredRs ann (_ ': xs) = CoveredRs ann xs++type family AssertNoMaybe (path :: [Symbol]) (tab :: NameNSK) (fld :: Symbol) (t :: Type)+  :: Constraint where+  AssertNoMaybe path tab fld (Maybe _) = TypeError+    ( Text "Returning must not use Maybe here (insert or upsert insert-capable node)."+    :$$: Text "At path: " :<>: ShowType path+    :$$: Text "Table: " :<>: ShowType tab+    :$$: Text "Field: " :<>: ShowType fld )+  AssertNoMaybe path tab fld _ = ()++type family AssertMustBeMaybe (path :: [Symbol]) (tab :: NameNSK) (fld :: Symbol)+  (t :: Type) :: Constraint where+  AssertMustBeMaybe path tab fld (Maybe _) = ()+  AssertMustBeMaybe path tab fld t = TypeError+    ( Text "Returning must use Maybe here (update or key-only upsert)."+    :$$: Text "At path: " :<>: ShowType path+    :$$: Text "Table: " :<>: ShowType tab+    :$$: Text "Field: " :<>: ShowType fld+    :$$: Text "Got: " :<>: ShowType t )++type family CheckUpsertListElem (path :: [Symbol]) (tab :: NameNSK) (fld :: Symbol)+  (restMandatory :: [Symbol]) (elemTy :: Type) :: Constraint where+  CheckUpsertListElem path tab fld '[] elemTy =+    AssertNoMaybe path tab fld (ListElem elemTy)+  CheckUpsertListElem path tab fld (_ ': _) elemTy =+    AssertMustBeMaybe path tab fld (ListElem elemTy)++type family SkipOutField (db :: Symbol) (fis :: [FieldInfo Symbol])+  :: [FieldInfo Symbol] where+  SkipOutField db '[] = '[]+  SkipOutField db ('FieldInfo _ db _ ': xs) = xs+  SkipOutField db (_ ': xs) = SkipOutField db xs++type family CheckReturningUpsertAt (path :: [Symbol]) (ann :: Ann) (rIn :: Type)+  (rOut :: Type) (fisIn :: [FieldInfo Symbol]) (fisOut :: [FieldInfo Symbol])+  :: Constraint where+  CheckReturningUpsertAt path ann rIn rOut '[] '[] = ()+  CheckReturningUpsertAt path ('Ann ren sch d tab) rIn rOut fisIn+    ('FieldInfo jsonName db ('RFToHere ('RecordInfo childTab childFIsOut) _) ': outs) =+    ( CheckUpsertListElem path tab jsonName+        (RestMandatory sch tab (CoveredRs ('Ann ren sch d tab) fisIn))+        (ColTypeByJsonName jsonName (Cols ('Ann ren sch d tab) rOut))+    , CheckReturningUpsertAt (Snoc path db) (AnnChild ('Ann ren sch d tab) childTab) rIn rOut+        (FindChildAt path db fisIn) childFIsOut+    , CheckReturningUpsertAt path ('Ann ren sch d tab) rIn rOut fisIn (SkipOutField db outs) )+  CheckReturningUpsertAt path ann rIn rOut+    (_ ': ins) ('FieldInfo _ db _ ': outs) =+    CheckReturningUpsertAt path ann rIn rOut ins (SkipOutField db outs)+  CheckReturningUpsertAt path ann rIn rOut fisIn fisOut =+    CheckSubtreeAt path fisIn fisOut++type family CheckReturningUpdateAt (path :: [Symbol]) (ann :: Ann) (rIn :: Type)+  (rOut :: Type) (fisIn :: [FieldInfo Symbol]) (fisOut :: [FieldInfo Symbol])+  :: Constraint where+  CheckReturningUpdateAt path ann rIn rOut '[] '[] = ()+  CheckReturningUpdateAt path ('Ann ren sch d tab) rIn rOut fisIn+    ('FieldInfo jsonName db ('RFToHere ('RecordInfo childTab childFIsOut) _) ': outs) =+    ( AssertMustBeMaybe path tab jsonName+        (ListElem (ColTypeByJsonName jsonName (Cols ('Ann ren sch d tab) rOut)))+    , CheckReturningUpdateAt (Snoc path db) (AnnChild ('Ann ren sch d tab) childTab) rIn rOut+        (FindChildAt path db fisIn) childFIsOut+    , CheckReturningUpdateAt path ('Ann ren sch d tab) rIn rOut fisIn (SkipOutField db outs) )+  CheckReturningUpdateAt path ann rIn rOut+    (_ ': ins) ('FieldInfo _ db _ ': outs) =+    CheckReturningUpdateAt path ann rIn rOut ins (SkipOutField db outs)+  CheckReturningUpdateAt path ann rIn rOut fisIn fisOut =+    CheckSubtreeAt path fisIn fisOut++type family CheckReturningInsertAt (path :: [Symbol]) (ann :: Ann) (rIn :: Type)+  (rOut :: Type) (fisIn :: [FieldInfo Symbol]) (fisOut :: [FieldInfo Symbol])+  :: Constraint where+  CheckReturningInsertAt path ann rIn rOut '[] '[] = ()+  CheckReturningInsertAt path ('Ann ren sch d tab) rIn rOut fisIn+    ('FieldInfo jsonName db ('RFToHere ('RecordInfo childTab childFIsOut) _) ': outs) =+    ( AssertNoMaybe path tab jsonName+        (ColTypeByJsonName jsonName (Cols ('Ann ren sch d tab) rOut))+    , CheckReturningInsertAt (Snoc path db) (AnnChild ('Ann ren sch d tab) childTab) rIn rOut+        (FindChildAt path db fisIn) childFIsOut+    , CheckReturningInsertAt path ('Ann ren sch d tab) rIn rOut fisIn (SkipOutField db outs) )+  CheckReturningInsertAt path ann rIn rOut+    (_ ': ins) ('FieldInfo _ db _ ': outs) =+    CheckReturningInsertAt path ann rIn rOut ins (SkipOutField db outs)+  CheckReturningInsertAt path ann rIn rOut fisIn fisOut =+    CheckSubtreeAt path fisIn fisOut++-- | Checks that tree @RETURNING@ type @rOut@ matches input @rIn@ after insert:+--+-- * Each relation branch in @rOut@ exists in @rIn@ at the same path; plain columns+--   in @rOut@ need not appear in @rIn@ ('CheckSubtreeAt').+-- * For every child list in @rOut@: the list element type must not be @Maybe@+--   ('AssertNoMaybe').+type family ReturningMatchesInsert (ann :: Ann) (rIn :: Type) (rOut :: Type)+  :: Constraint where+  ReturningMatchesInsert ann rIn rOut =+    ( ReturningIsSubtree ann rIn rOut+    , CheckReturningInsertAt '[] ann rIn rOut+        (TRecordInfo ann rIn) (TRecordInfo ann rOut) )++-- | Checks that tree @RETURNING@ type @rOut@ matches input @rIn@ after upsert:+--+-- * Same relation-subtree rules as 'ReturningMatchesInsert'.+-- * For each child list in @rOut@: if @rIn@ still lacks mandatory plain columns at+--   that node, the element type must be @Maybe@; otherwise it must be bare+--   ('CheckUpsertListElem').+type family ReturningMatchesUpsert (ann :: Ann) (rIn :: Type) (rOut :: Type)+  :: Constraint where+  ReturningMatchesUpsert ann rIn rOut =+    ( ReturningIsSubtree ann rIn rOut+    , CheckReturningUpsertAt '[] ann rIn rOut+        (TRecordInfo ann rIn) (TRecordInfo ann rOut) )++-- | Checks that tree @RETURNING@ type @rOut@ matches input @rIn@ after update:+--+-- * @rOut@ must be @Maybe row@ ('RequireMaybeRow'); checks apply to 'InnerRow rOut'.+-- * Each relation branch in that row exists in @rIn@ at the same path; plain columns+--   in the returning row need not appear in @rIn@.+-- * For every child list there: the element type must be @Maybe@+--   ('AssertMustBeMaybe').+type family ReturningMatchesUpdate (ann :: Ann) (rIn :: Type) (rOut :: Type)+  :: Constraint where+  ReturningMatchesUpdate ann rIn rOut =+    ( RequireMaybeRow rOut+    , ReturningIsSubtree ann rIn (InnerRow rOut)+    , CheckReturningUpdateAt '[] ann rIn (InnerRow rOut)+        (TRecordInfo ann rIn) (TRecordInfo ann (InnerRow rOut)) )

@@ -46,8 +46,13 @@ -- children in the same way. 'insertJSON' / 'insertJSON_' require every mandatory -- column and emit plain @INSERT@ only (duplicates fail in the database). -- 'upsertJSON' / 'upsertJSON_' relax mandatory requirements and may @UPDATE@ or--- @INSERT … ON CONFLICT …@ (see their Haddock). Plain 'insertSch' / 'insertSch_' follow the--- same safety story for flat (non-tree) rows.+-- @INSERT … ON CONFLICT …@ (see their Haddock).+-- 'updateJSON' / 'updateJSON_' update existing rows only (never @INSERT@).+-- Flat 'insertSch', 'upsertByKey', and 'updateByKey' use 'PlainOut' for @RETURNING@+-- (any plain columns of the table; 'RequireBareRow' forbids @Maybe@ on the whole+-- row). Tree @*JSON@ uses 'ReturningMatches{Insert,Upsert,Update}' instead.+-- 'upsertByKey' requires mandatory columns and a full key; 'updateByKey' is+-- key-only and returns @IO ([Maybe r'], Text)@. -- -- 'selectSch' decodes each row into a Haskell type @r@ whose fields describe the -- root table columns and nested data for relations (multiple list-shaped children@@ -68,18 +73,13 @@ -- module PgSchema.DML   (-  -- * DML-  -- ** Select-  -- *** Execute SQL-    selectSch, selectText, Selectable-  -- *** Monad to set Query Params-  , MonadQP, qpEmpty+  -- * Select+    selectSch, selectText+  -- ** Query Params+  , QueryParamAnn, QueryParam(..), qpEmpty   , qRoot, qPath, qPathFromHere, qPathToHere, qWhere, qOrderBy   , qDistinct, qDistinctOn, qLimit, qOffset-  -- **** Internals-  , QueryParam(..), QueryParamAnn, CondWithPath(..), OrdWithPath(..)-  , LimOffWithPath(..), DistWithPath(..)-  -- *** Conditions+  -- ** Conditions   -- | Example: @"name" =? "John"@   , (<?),(>?),(<=?),(>=?),(=?)   -- | Null-safe equality on nullable columns (@IS NOT DISTINCT FROM@).@@ -88,28 +88,80 @@   -- | Example: @"name" ~~? "%joh%"@   ,(~=?),(~~?)   , (|||), (&&&), pnot, pnull, pin, pinArr-  , pparent, pchild, TabParam(..), defTabParam-  , pUnsafeCond, UnsafeCol(..)-  , Cond(..), CondAnn, Cmp(..), BoolOp(..)+  , pparent, pchild+  , pUnsafeCond+  -- ** Order By and Limit/Offset+  , ordf, ascf, descf, defLO, lo1+  -- ** Internals+  , Selectable, CRecInfo(..)+  , MonadQP, CondWithPath(..), OrdWithPath(..)+  , Cond(..), CondAnn, Cmp(..), BoolOp(..), TabParam(..), defTabParam   , CondMonad, SomeToField(..), showCmp, tabPref, qual   , CDBField, CDBValue, CDBFieldNullable, CRelDef-  -- *** Order By and others-  , ordf, ascf, descf, defLO, lo1+  , LimOffWithPath(..), DistWithPath(..)   , OrdDirection(..), OrdFld(..), Dist(..), LO(..)-  -- ** Plain Insert-  , insertSch, insertSch_, insertText, insertText_, AllPlain-  , InsertNonReturning, InsertReturning-  -- ** Update+  -- * Plain DML+  -- | You can insert, update or upsert data.+  --+  -- - For insert you need all mandatory fields.+  -- - For key-based update you need a full primary or unique key.+  -- - For upsert you need all mandatory fields _and_ some key.+  --+  -- You can get in return any subset of the columns of the table which was affected by the operation.+  -- All rows returned in the same order as the input tree.+  -- For update you get `Maybe t`. It is `Nothing` if the row was not found by the key.+  --+  -- All these constraints are checked at compile time.+  --+  -- There is also operations to update or delete data by a condition.+  --+  , insertSch, insertSch_, insertText, insertText_+  , upsertByKey, upsertByKey_, upsertByKeyText, upsertByKeyText_+  , updateByKey, updateByKey_, updateByKeyText, updateByKeyText_   , updateByCond, updateByCond_, updateText, updateText_-  , UpdateReturning, UpdateNonReturning, CRecInfo(..)-  -- ** Tree-base Insert/Upsert+  , deleteByCond, deleteText+  -- ** Constraints+  , AllPlain, InsertNonReturning, InsertReturning+  , UpsertByKeyNonReturning, UpsertByKeyReturning+  , UpdateByKeyNonReturning, UpdateByKeyReturning+  , UpdateReturning, UpdateNonReturning+  -- * Tree-based DML+  -- | You can insert, update or upsert data right into the tree structure+  -- (to the several related tables at once).+  --+  -- - For insert you need all mandatory fields at every node.+  -- - For update you need a full primary or unique key at every node.+  -- - For upsert you need all mandatory fields _or_ some key at every node.+  --+  --     At each node:+  --+  --     - the operation works like an insert if there is no key+  --     - the operation works like an update if there is not all mandatory fields+  --     - the operation works like an upsert if there is all mandatory fields and a key exists+  --+  -- You don't need foreign keys for children in your data (and often even keys for parents).+  -- They will be determined automatically.+  --+  -- You can get in return any subset of the columns of the tables which were affected by the operation.+  -- All rows returned in the same order as the input tree.+  -- For update or some nodes of upsert (where not all mandatory fields are present),+  -- the returning type is `Maybe t`. It is 'Nothing' if the row was not found by the key.+  --+  -- All these constraints are checked at compile time.+  --+  -- For all these operations you should use types that can be converted to JSON (and from JSON for returning).+  -- You don't need instances but all fields should be serializable into JSON.+  -- I.e. you can't use 'Bytestring' for fields here.   , insertJSON, insertJSON_, upsertJSON, upsertJSON_-  , insertJSONText, insertJSONText_, upsertJSONText, upsertJSONText_-  , TreeIn, TreeOut, AllMandatoryTree, AllMandatoryOrHasKeyTree, TreeSch+  , updateJSON, updateJSON_, insertJSONText, insertJSONText_+  , upsertJSONText, upsertJSONText_, updateJSONText, updateJSONText_+  -- ** Constraints+  , TreeIn, TreeOut, AllMandatoryTree, AllMandatoryOrHasKeyTree, AllHasKeyTree+  , HasSchema   , InsertTreeNonReturning, InsertTreeReturning-  , UpsertTreeNonReturning, UpsertTreeReturning, TRecordInfo-  -- ** Delete-  , deleteByCond, deleteText+  , UpsertTreeNonReturning, UpsertTreeReturning+  , UpdateTreeNonReturning, UpdateTreeReturning, TRecordInfo+  , ReturningMatchesInsert, ReturningMatchesUpsert, ReturningMatchesUpdate   -- * Types   , Ann(..), ToStar   -- ** Renamers@@ -121,7 +173,9 @@   -- ** Enum   , PGEnum   -- ** Aggregates-  , Aggr'(..), Aggr(..), AggrFun(..)+  , Aggr(..), Aggr'(..), AggrFun(..)+  -- ** Unsafe+  , UnsafeCol(..)   -- ** Arrays   , PgArr(..), pgArr', unPgArr'   -- ** Conversion checks@@ -129,6 +183,7 @@   -- ** Other types   , PgChar(..), PgOid(..)   , NameNS'(..), type (->>), NameNSK, (->>)+  , PathElem'(..), PathElem, PathElemK, PathKind(..)   , TRelDef, RelDef'(..), RdFrom, RdTo, FdType, FdNullable, CTabDef(..)   ) where @@ -139,6 +194,7 @@ import PgSchema.DML.Insert as I import PgSchema.DML.Insert.Types as I import PgSchema.DML.InsertJSON as I+import PgSchema.DML.UpsertByKey as UBK import PgSchema.DML.Update as U import PgSchema.DML.Delete as D import PgSchema.Schema as S

@@ -14,9 +14,10 @@   -- | Insert records into a table.--- You can request any subset of columns from the inserted row via the result type. ----- All mandatory fields having no defaults should be present.+-- Returning type @r'@ may name any plain columns of the table ('PlainOut');+-- they need not appear in the input row (e.g. @RETURNING id@ without @id@ in @r@).+-- All mandatory fields having no defaults should be present in @r@. -- insertSch   :: forall ann -> forall r r'. InsertReturning ann r r'

@@ -13,8 +13,10 @@ -- Plain Insert / Upsert / Update -------------------------------------------------------------------------------- +-- | Check that (input) record corresponds to annotation, can be converted to Row and contains only plain fields. type PlainIn ann r = (CRecInfo ann r, AllPlain ann r, ToRow (PgTag ann r)) +-- | Check that (output) record corresponds to annotation, can be converted from Row and contains only plain fields. type PlainOut ann r' = (CRecInfo ann r', AllPlain ann r', FromRow (PgTag ann r'))  -- | Plain insert without @RETURNING@.@@ -22,10 +24,10 @@ type InsertNonReturning ann r =   (PlainIn ann r, CheckAllMandatory ann (ColsDbNames (Cols ann r))) --- | Plain insert with @RETURNING@.--- Check that all inserted and returned fields belong to the root table--- and all mandatory fields are present.-type InsertReturning ann r r' = (InsertNonReturning ann r, PlainOut ann r')+-- | Plain insert with @RETURNING@: @r'@ is any bare plain column subset of the+-- table ('PlainOut'); tree 'ReturningMatchesInsert' is for 'insertJSON' only.+type InsertReturning ann r r' =+  ( InsertNonReturning ann r, PlainOut ann r', RequireBareRow r' )  -- | Plain update with @RETURNING@. -- Check that all updated and returned fields belong to the root table.@@ -35,10 +37,34 @@ -- Check that all updated fields belong to the root table. type UpdateNonReturning ann r = PlainIn ann r -type TreeSch ann = CSchema (AnnSch ann)+-- | Upsert one table row by primary / unique key (@ToRow@, no JSON).+--+-- Requires all mandatory fields and a full primary or eligible unique key so+-- the operation is always @INSERT … ON CONFLICT …@. Use 'InsertNonReturning' or+-- 'UpdateByKeyNonReturning' for insert-only or update-only flat writes.+type UpsertByKeyNonReturning ann r =+  ( PlainIn ann r, HasSchema ann+  , CheckAllMandatoryAndHasKey ann (ColsDbNames (Cols ann r)) ) +type UpsertByKeyReturning ann r r' =+  ( UpsertByKeyNonReturning ann r, PlainOut ann r', RequireBareRow r' )++-- | Update one table row by primary / unique key (@ToRow@, no JSON).+type UpdateByKeyNonReturning ann r =+  ( PlainIn ann r, HasSchema ann+  , CheckHasKey ann (ColsDbNames (Cols ann r)) )++-- | Flat update by key: bare @r'@; the API returns @IO ([Maybe r'], Text)@.+type UpdateByKeyReturning ann r r' =+  ( UpdateByKeyNonReturning ann r, PlainOut ann r', RequireBareRow r' )++-- | Check that annotation contains a schema.+type HasSchema ann = CSchema (AnnSch ann)++-- | Check that (input) record corresponds to annotation and can be converted to JSON. type TreeIn ann r = (CRecInfo ann r, ToJSON (PgTag ann r)) +-- | Check that (output) record corresponds to annotation and can be converted from JSON. type TreeOut ann r' = (CRecInfo ann r', FromJSON (PgTag ann r'),   Typeable ann, Typeable r') @@ -47,7 +73,7 @@ -- Check that all mandatory fields are present in all tables in tree. -- Reference fields in the child tables are not checked - they are inserted automatically. type InsertTreeNonReturning ann r =-  (TreeSch ann, TreeIn ann r, AllMandatoryTree ann r '[])+  (HasSchema ann, TreeIn ann r, AllMandatoryTree ann r '[])  -- | Insert tree with @RETURNING@. --@@ -56,7 +82,7 @@ -- -- It also checks that we get returnings only from the tables we inserted into. type InsertTreeReturning ann r r' =-  ( InsertTreeNonReturning ann r, TreeOut ann r', ReturningIsSubtree ann r r' )+  ( InsertTreeNonReturning ann r, TreeOut ann r', ReturningMatchesInsert ann r r' )  -- | Upsert tree without @RETURNING@. --@@ -64,7 +90,7 @@ -- present at each tree node. -- Reference fields in the child tables are not checked - they are inserted automatically. type UpsertTreeNonReturning ann r =-  (TreeSch ann, TreeIn ann r, AllMandatoryOrHasKeyTree ann r '[])+  (HasSchema ann, TreeIn ann r, AllMandatoryOrHasKeyTree ann r '[])  -- | Upsert tree with @RETURNING@. --@@ -74,4 +100,13 @@ -- -- It also checks that we get returnings only from the tables we upserted into. type UpsertTreeReturning ann r r' =-  ( UpsertTreeNonReturning ann r, TreeOut ann r', ReturningIsSubtree ann r r' )+  ( UpsertTreeNonReturning ann r, TreeOut ann r', ReturningMatchesUpsert ann r r' )++-- | Update tree without @RETURNING@ (key required at every node).+type UpdateTreeNonReturning ann r =+  (HasSchema ann, TreeIn ann r, AllHasKeyTree ann r '[])++-- | Update tree with @RETURNING@ ('Maybe' on every list row in @r'@).+type UpdateTreeReturning ann r r' =+  ( UpdateTreeNonReturning ann r, TreeOut ann r'+  , ReturningMatchesUpdate ann r r' )

@@ -1,7 +1,10 @@ {-# LANGUAGE OverloadedRecordDot #-} module PgSchema.DML.InsertJSON-  ( insertJSON, insertJSON_, upsertJSON, upsertJSON_-  , insertJSONText, insertJSONText_, upsertJSONText, upsertJSONText_ ) where+  ( InsertMode(..)+  , insertJSON, insertJSON_, upsertJSON, upsertJSON_+  , updateJSON, updateJSON_+  , insertJSONText, insertJSONText_, upsertJSONText, upsertJSONText_+  , updateJSONText, updateJSONText_ ) where  import Control.Monad import Control.Monad.RWS@@ -18,6 +21,7 @@ import Data.Traversable import PgSchema.Ann import PgSchema.DML.Insert.Types+import PgSchema.DML.KeyedWrite (mandatoryDbNames, pickKeyNames) import Database.PostgreSQL.LibPQ qualified as PQ import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.Internal (withConnection)@@ -28,77 +32,65 @@ import Prelude as P  +data InsertMode = Insert | Upsert | Update deriving (Eq, Show)++ -- | Insert records into a table and its children using JSON data internally. -- -- Uses the same SQL pipeline as 'upsertJSON', but each row is a plain @INSERT@ -- (no @UPDATE@, no @INSERT … ON CONFLICT …@). Any duplicate primary or unique key--- raises a PostgreSQL error.------ Requires all mandatory columns at every node (see 'InsertTreeReturning').-+-- raises a PostgreSQL error. Requires all mandatory columns at every node+-- ('InsertTreeReturning'; 'ReturningMatchesInsert' on @r'@). Flat 'insertSch'+-- uses 'PlainOut' only. insertJSON   :: forall ann -> forall r r'. InsertTreeReturning ann r r'   => Connection -> [r] -> IO ([r'], Text)-insertJSON ann @r @r' conn rs = insertJSONImpl ann @r @r' conn rs True+insertJSON ann @r @r' conn rs = insertJSONImpl ann @r @r' conn rs Insert  -- | Like 'insertJSON', but does not return rows. -- insertJSON_   :: forall ann -> forall r. InsertTreeNonReturning ann r   => Connection -> [r] -> IO Text-insertJSON_ ann @r conn rs = insertJSONImpl_ ann @r conn rs True+insertJSON_ ann @r conn rs = insertJSONImpl_ ann @r conn rs Insert  -- | Upsert a forest of rows into the root table and its /child/ tables in one -- round-trip, using JSON inside PostgreSQL (same pipeline as 'insertJSON'). ----- __Input shape (@r@):__ a record tree that may contain the root table’s columns--- and nested /child/ branches (one-to-many from the root downward). There are no--- nested /parent/ branches: parent keys are implied by the tree you send, not by--- embedding parent rows inside children.------ __Output shape (@r'@):__ a record tree whose graph of nested tables is a--- /subgraph/ of the input: the same tables can appear, but you choose which--- columns (and which levels) appear in the result—whatever is available through--- the generated @RETURNING@/result projection. Field sets may differ from @r@;--- relation structure cannot grow beyond what you sent in.------ __What to supply at each node:__ at every level, each row must either include--- all mandatory columns (for columns that are mandatory in the schema /sense of--- this API/) or, alternatively, enough columns to identify an existing row via--- the primary key or a unique constraint (including constraints with nullable--- columns when the table has no @NOT NULL@ unique constraint besides PK).--- If a nullable key column is @null@ in the payload, conflict/update semantics--- follow PostgreSQL (see haddock on 'upsertJSON').--- Foreign-key columns that are filled in by the parent level (for example--- after an auto-generated id on insert) do /not/ need to be present on the child--- payload.------ __Insert vs update vs upsert per row:__ the engine picks one of @INSERT@,--- @UPDATE@, or @UPSERT@ from the keys and mandatory fields you provide:------ * all mandatory fields present and no full identity key  →  @INSERT@--- * identity (PK or first eligible unique whose columns are all in the node), not all mandatory  →  @UPDATE@--- * identity present /and/ all mandatory fields  →  @UPSERT@ (@INSERT … ON CONFLICT …@)------ 'insertJSON' shares this execution path but is insert-only at runtime and--- requires /every/ mandatory field at compile time. 'upsertJSON' relaxes both.+-- See Haddock on previous versions for input/output shape and per-row @INSERT@ /+-- @UPDATE@ / @UPSERT@ selection. Returning list elements use bare rows where the+-- input node has all mandatory fields, and @Maybe@ otherwise ('ReturningMatchesUpsert'). upsertJSON   :: forall ann -> forall r r'. UpsertTreeReturning ann r r'   => Connection -> [r] -> IO ([r'], Text)-upsertJSON ann @r @r' conn rs = insertJSONImpl ann @r @r' conn rs False+upsertJSON ann @r @r' conn rs = insertJSONImpl ann @r @r' conn rs Upsert  -- | Like 'upsertJSON', but does not return rows. -- upsertJSON_   :: forall ann -> forall r. UpsertTreeNonReturning ann r   => Connection -> [r] -> IO Text-upsertJSON_ ann @r conn rs = insertJSONImpl_ ann @r conn rs False+upsertJSON_ ann @r conn rs = insertJSONImpl_ ann @r conn rs Upsert +-- | Update an existing forest (never @INSERT@). Returning type @r'@ must satisfy+-- 'ReturningMatchesUpdate' (@Maybe@ on each child list element). Flat+-- 'updateByKey' instead uses bare @r'@ and returns @IO ([Maybe r'], Text)@.+updateJSON+  :: forall ann -> forall r r'. UpdateTreeReturning ann r r'+  => Connection -> [r] -> IO ([r'], Text)+updateJSON ann @r @r' conn rs = insertJSONImpl ann @r @r' conn rs Update++-- | Like 'updateJSON', but does not return rows.+--+updateJSON_+  :: forall ann -> forall r. UpdateTreeNonReturning ann r+  => Connection -> [r] -> IO Text+updateJSON_ ann @r conn rs = insertJSONImpl_ ann @r conn rs Update+ insertJSONImpl-  :: forall ann -> forall r r'. (TreeSch ann, TreeIn ann r, TreeOut ann r')-  => Connection -> [r] -> Bool -> IO ([r'], Text)-  -- ^ @Bool@ is @isInsertOnly@.-insertJSONImpl ann @r @r' conn rs isInsertOnly = withTransactionIfNot conn do+  :: forall ann -> forall r r'. (HasSchema ann, TreeIn ann r, TreeOut ann r')+  => Connection -> [r] -> InsertMode -> IO ([r'], Text)+insertJSONImpl ann @r @r' conn rs mode = withTransactionIfNot conn do   let sql' = T.unpack sql in trace' sql' $ void $ execute_ conn $ fromString sql'   [Only res] <- let q = "select pg_temp.__ins(?)" in     traceShow' q@@ -107,7 +99,7 @@   void $ execute_ conn "drop function pg_temp.__ins"   pure (unPgTag @ann @r' <$> res, sql)   where-    sql = insertJSONText' isInsertOnly (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))+    sql = insertJSONText' mode (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))       (getRecordInfo @ann @r) (getRecordInfo @ann @r').fields  withTransactionIfNot :: Connection -> IO a -> IO a@@ -124,50 +116,61 @@         \unknown transaction status"  insertJSONImpl_-  :: forall ann -> forall r. (TreeSch ann, TreeIn ann r)-  => Connection -> [r] -> Bool -> IO Text-insertJSONImpl_ ann @r conn rs isInsertOnly = withTransactionIfNot conn do+  :: forall ann -> forall r. (HasSchema ann, TreeIn ann r)+  => Connection -> [r] -> InsertMode -> IO Text+insertJSONImpl_ ann @r conn rs mode = withTransactionIfNot conn do   void $ trace' (T.unpack sql) $ execute_ conn $ fromString $ T.unpack sql   void $ execute conn "call pg_temp.__ins(?)" $ Only $ PgTag @ann @r <$> rs   sql <$ execute_ conn "drop procedure pg_temp.__ins"   where-    sql = insertJSONText' isInsertOnly (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))+    sql = insertJSONText' mode (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))       (getRecordInfo @ann @r) []  insertJSONText_ :: forall ann -> forall r s.-  (IsString s, Monoid s, Ord s, TreeSch ann, CRecInfo ann r) => s+  (IsString s, Monoid s, Ord s, HasSchema ann, CRecInfo ann r) => s insertJSONText_ ann @r =-  insertJSONText' True (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))+  insertJSONText' Insert (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))     (getRecordInfo @ann @r) []  insertJSONText :: forall ann -> forall r r'.-  ( TreeSch ann, CRecInfo ann r, CRecInfo ann r'+  ( HasSchema ann, CRecInfo ann r, CRecInfo ann r'   , IsString s, Monoid s, Ord s ) => s insertJSONText ann @r @r' =-  insertJSONText' True (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))+  insertJSONText' Insert (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))     (getRecordInfo @ann @r) (getRecordInfo @ann @r').fields  upsertJSONText_ :: forall ann -> forall r s.-  (IsString s, Monoid s, Ord s, TreeSch ann, CRecInfo ann r) => s+  (IsString s, Monoid s, Ord s, HasSchema ann, CRecInfo ann r) => s upsertJSONText_ ann @r =-  insertJSONText' False (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))+  insertJSONText' Upsert (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))     (getRecordInfo @ann @r) []  upsertJSONText :: forall ann -> forall r r'.-  ( TreeSch ann, CRecInfo ann r, CRecInfo ann r'+  ( HasSchema ann, CRecInfo ann r, CRecInfo ann r'   , IsString s, Monoid s, Ord s ) => s upsertJSONText ann @r @r' =-  insertJSONText' False (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))+  insertJSONText' Upsert (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))     (getRecordInfo @ann @r) (getRecordInfo @ann @r').fields --- | @isInsertOnly@: plain @INSERT@ only ('insertJSON'); 'False' enables upsert--- key resolution ('upsertJSON').+updateJSONText_ :: forall ann -> forall r s.+  (IsString s, Monoid s, Ord s, HasSchema ann, CRecInfo ann r) => s+updateJSONText_ ann @r =+  insertJSONText' Update (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))+    (getRecordInfo @ann @r) []++updateJSONText :: forall ann -> forall r r'.+  ( HasSchema ann, CRecInfo ann r, CRecInfo ann r'+  , IsString s, Monoid s, Ord s ) => s+updateJSONText ann @r @r' =+  insertJSONText' Update (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))+    (getRecordInfo @ann @r) (getRecordInfo @ann @r').fields+ insertJSONText'   :: forall s. (IsString s, Monoid s, Ord s)-  => Bool+  => InsertMode   -> M.Map NameNS TypDef -> M.Map NameNS TabInfo -> RecordInfo Text   -> [FieldInfo Text] -> s-insertJSONText' isInsertOnly mapTypes mapTabs ir qfs = unlines'+insertJSONText' mode mapTypes mapTabs ir qfs = unlines'   [ maybe     "create or replace procedure pg_temp.__ins(data_0 jsonb) as $$"     (const "create or replace function pg_temp.__ins(data_0 jsonb) returns jsonb as $$")@@ -181,13 +184,10 @@   , "$$ language plpgsql;" ]   where     (mbRes, (decl, body)) =-      evalRWS (insertJSONTextM isInsertOnly mapTypes mapTabs ir qfs [] [])+      evalRWS (insertJSONTextM mode mapTypes mapTabs ir qfs [] [] [])         ("  ",0) 0  type MonadInsert s = RWS (s, Int) ([s],[s]) Int--- R: (leading spaces to format code, number of table in tree)--- W: (lines of declarations, lines of function body)--- S: maximum number of table in tree "in use"  data OP = INS | UPD | UPS deriving (Eq, Show) @@ -197,40 +197,37 @@   , info :: v }   deriving (Eq, Show) --- | Runtime conflict/update targets: PK, then @NOT NULL@ unique constraints,--- then nullable unique constraints only when the table has no @NOT NULL@ UK.--- Compile-time checks use all keys from 'IdentityCandidates'.-identityCandidatesFromTab :: TabInfo -> [[Text]]-identityCandidatesFromTab ti =-  P.filter (not . P.null) [ti.tiDef.tdKey] <> notNullUks <> nullUks-  where-    isNullable = (== Just True) . fmap (.fdNullable) . (`M.lookup` ti.tiFlds)-    (nullUks, notNullUks) = L.partition (P.any isNullable) ti.tiDef.tdUniq--mandatoryDbNames :: TabInfo -> [Text]-mandatoryDbNames ti =-  M.keys $ M.filter (\fd -> not $ fd.fdNullable || fd.fdHasDefault) ti.tiFlds- insertJSONTextM   :: forall s. (IsString s, Monoid s, Ord s)-  => Bool+  => InsertMode   -> M.Map NameNS TypDef -> M.Map NameNS TabInfo -> RecordInfo Text-  -> [FieldInfo Text] -> [s] -> [s] -> MonadInsert s (Maybe s)-insertJSONTextM isInsertOnly mapTypes mapTabs ri qfs fromFields toVars = do+  -> [FieldInfo Text] -> [s] -> [s] -> [Text] -> MonadInsert s (Maybe s)+insertJSONTextM mode mapTypes mapTabs ri qfs fromFields toVars parentDbKeys = do   (spaces, n) <- ask   let     sn = show' n     dataN = "data_" <> sn     rowN  = "row_" <> sn+    foundN = "found_" <> sn     mbArrN = ("arr_" <> sn) <$ guard (not $ P.null qfs)     decs = (if n == 0 then P.id else (dataN <> " jsonb;" :))-      [rowN <> " record;"]+      (foundN <> " boolean;" : [rowN <> " record;"])       <> foldMap (pure . (<> " jsonb[];")) mbArrN <> qretDecls     qretDecls = qretPairs <&> \(fld, typ) -> fld <> sn <> " " <> typ <> "; "     initArray = foldMap (pure . (<> ":= '{}';")) mbArrN     startLoop =       ["for " <> rowN <> " in select * from jsonb_array_elements("       <> dataN <> ")", "loop"]+    keyOnlyInput =+      let+        mbTab = mapTabs M.!? ri.tabName+        mflds = foldMap (fmap fromText . mandatoryDbNames) mbTab+        srcFldsLoc = parentDbKeys <> ((.dbName) <$> iplains)+      in not $ P.null $ mflds L.\\ srcFldsLoc+    keyNamesTxt = case mapTabs M.!? ri.tabName of+      Just ti ->+        fromMaybe [] $ pickKeyNames ti (parentDbKeys <> ((.dbName) <$> iplains))+      Nothing -> []     (ins, op) = resolve       where         jsonFld ip = case mapTypes M.!? ip.info.fdType of@@ -258,12 +255,7 @@         ins0 =           [ "  insert into " <> qualTabName <> "(" <> intercalate' ", " srcFlds <> ")"           , "    values (" <> intercalate' ", " srcVars <> ")"]-        mbTab = mapTabs M.!? ri.tabName-        mflds = foldMap (fmap fromText . mandatoryDbNames) mbTab-        keyNames-          | isInsertOnly = []-          | otherwise = F.fold $ L.find (P.null . (L.\\ srcFlds))-              $ fmap fromText <$> foldMap identityCandidatesFromTab mbTab+        keyNames = fromText <$> keyNamesTxt         (plainsKey, plainsOthers) =           L.partition ((`L.elem` keyNames) . fst) plains         sWhere = "where " <> intercalate' " and "@@ -284,20 +276,25 @@               <> ["  " <> intercalate' " " xs]             Nothing -> ins0 <> addSemiColon ([ "    on conflict do nothing"] <> rets)               <> ["  if not found then"-                , "    select " <> intercalate' ", " qretFlds <> " into " <> intercalate' ", " qretVars+                , "    select " <> intercalate' ", " qretFlds <> " into "+                  <> intercalate' ", " qretVars                 , "      from " <> qualTabName                 , "      " <> sWhere <> ";"                 , "  end if;"]           | P.null conflictCols = addSemiColon ins0           | otherwise = addSemiColon $ ins0             <> [ "    on conflict (" <> intercalate' ", " conflictCols <> ")"-              , "      do update set " <> intercalate' ", " (plainsOthers <&>-                  \(name, _) -> name <> " = " <> "EXCLUDED." <> name) ]+              , "      do update set " <> intercalate' ", "+                  (plainsOthers <&> \(name, _) -> name <> " = EXCLUDED." <> name) ]             <> rets         resolve-          | not isInsertOnly, not $ P.null $ mflds L.\\ srcFlds =+          | mode == Update =             (addSemiColon (upd0 <> rets), UPD)-          | not isInsertOnly, not $ P.null keyNames = (ups0 keyNames, UPS)+          | mode == Insert =+            (addSemiColon (ins0 <> rets), INS)+          | keyOnlyInput =+            (addSemiColon (upd0 <> rets), UPD)+          | not $ P.null keyNamesTxt = (ups0 keyNames, UPS)           | otherwise = (addSemiColon (ins0 <> rets), INS)     endLoop = "end loop;"     processChildren = do@@ -310,27 +307,55 @@         let           qfs' = foldMap ((.fields) . snd)             $ L.find (\(qc, _) -> qc.jsonName == child.jsonName) qchildren-        mbArr <- local (second $ const n') $ insertJSONTextM isInsertOnly+        let parentKeys = nub $ P.map (.fromName) child.info+        mbArr <- local (second $ const n') $ insertJSONTextM mode           mapTypes mapTabs           childRi qfs' (fromText . (.fromName) <$> child.info)           ((<> sn) . fromText . (.toName) <$> child.info)+          parentKeys         pure (fromText child.jsonName, mbArr)+      pure arrs+    appendReturning arrN arrs =       let-        appendArray = foldMap (\arrN -> pure $ arrN <> ":= array_append("-          <> arrN <> ", jsonb_build_object(" <> jsonFlds <> "));") mbArrN-          where-            jsonFlds = intercalate' ", "-              $ (qplains <&> \qp -> "'" <> fromText qp.jsonName-              <> "', " <> fromText qp.dbName <> sn)-              <> (arrs <&> \(jsonN, arr) -> "'" <> jsonN <> "', to_jsonb(" <> arr <> ")")-      tell (mempty, fmap (spaces' <>) appendArray)-  tell (decs, fmap (spaces <>) $ initArray <> startLoop <> ins)-  case op of+        jsonFlds = intercalate' ", "+          $ (qplains <&> \qp -> "'" <> fromText qp.jsonName+            <> "', " <> fromText qp.dbName <> sn)+          <> (arrs <&> \(jsonN, arr) -> "'" <> jsonN <> "', to_jsonb(" <> arr <> ")")+        obj = "jsonb_build_object(" <> jsonFlds <> ")"+      in case (mode, op) of+        (Update, UPD) ->+          [ spaces <> "  if " <> foundN <> " then"+          , spaces <> "    " <> arrN <> " := array_append(" <> arrN <> ", " <> obj <> ");"+          , spaces <> "  else"+          , spaces <> "    " <> arrN <> " := array_append("+            <> arrN <> ", 'null'::jsonb);"+          , spaces <> "  end if;" ]+        (Upsert, UPD)+          | keyOnlyInput ->+            [ spaces <> "  if " <> foundN <> " then"+            , spaces <> "    " <> arrN <> " := array_append(" <> arrN <> ", " <> obj <> ");"+            , spaces <> "  else"+            , spaces <> "    " <> arrN <> " := array_append("+              <> arrN <> ", 'null'::jsonb);"+            , spaces <> "  end if;" ]+          | otherwise ->+            [ spaces <> "  if " <> foundN <> " then"+            , spaces <> "    " <> arrN <> " := array_append(" <> arrN <> ", " <> obj <> ");"+            , spaces <> "  end if;" ]+        _ ->+          [ spaces <> "  " <> arrN <> " := array_append(" <> arrN <> ", " <> obj <> ");" ]+  tell (decs, fmap (spaces <>) $ initArray <> startLoop <> ins+    <> [spaces <> "  " <> foundN <> " := found;"])+  arrs <- case op of     UPD -> do       tell (mempty, pure $ spaces <> "  if found then")-      local (first ("    " <>)) processChildren+      ch <- local (first ("    " <>)) processChildren       tell (mempty, pure $ spaces <> "  end if;")+      pure ch     _ -> local (first ("  " <>)) processChildren+  case mbArrN of+    Nothing -> pure ()+    Just arrN -> tell (mempty, appendReturning arrN arrs)   tell (mempty, pure $ spaces <> endLoop)   pure mbArrN   where

@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedRecordDot #-}+module PgSchema.DML.KeyedWrite+  ( mandatoryDbNames, identityCandidatesFromTab, pickKeyNames+  , keyWhereClause, upsertOnConflict+  , keyedUpdateSetAndKeys ) where++import Data.List as L+import Data.Map as M+import Data.Maybe+import Data.Text as T+import PgSchema.Schema+import Prelude as P+++-- | Runtime conflict/update targets (same order as 'InsertJSON').+identityCandidatesFromTab :: TabInfo -> [[Text]]+identityCandidatesFromTab ti =+  P.filter (not . P.null) [ti.tiDef.tdKey] <> notNullUks <> nullUks+  where+    isNullable = (== Just True) . fmap (.fdNullable) . (`M.lookup` ti.tiFlds)+    (nullUks, notNullUks) = L.partition (P.any isNullable) ti.tiDef.tdUniq++mandatoryDbNames :: TabInfo -> [Text]+mandatoryDbNames ti =+  M.keys $ M.filter (\fd -> not $ fd.fdNullable || fd.fdHasDefault) ti.tiFlds++pickKeyNames :: TabInfo -> [Text] -> Maybe [Text]+pickKeyNames ti srcFlds =+  L.find (P.null . (L.\\ srcFlds)) $ identityCandidatesFromTab ti++keyWhereClause :: [(Text, Text)] -> Text+keyWhereClause pairs =+  " where " <> T.intercalate " and "+    (L.zipWith keyValDistinct (fst <$> pairs) (snd <$> pairs))+  where+    keyValDistinct name val = name <> " IS NOT DISTINCT FROM " <> val++-- | Partition plain columns for @UPDATE@ (SET non-keys, then WHERE keys).+keyedUpdateSetAndKeys+  :: TabInfo -> [(Text, Text)] -> ([(Text, Text)], [(Text, Text)])+keyedUpdateSetAndKeys ti plains =+  let+    srcFlds = fst <$> plains+    keyNames = fromMaybe [] $ pickKeyNames ti srcFlds+  in L.partition ((`L.elem` keyNames) . fst) plains++upsertOnConflict :: [(Text, Text)] -> [Text] -> Text+upsertOnConflict plainsOthers conflictCols =+  case (L.null plainsOthers, conflictCols) of+    (True, _) -> " on conflict do nothing"+    (_, []) -> ""+    (_, cols) ->+      " on conflict (" <> T.intercalate ", " cols <> ")"+        <> " do update set "+        <> T.intercalate ", "+          ( L.map (\(name, _) -> name <> " = EXCLUDED." <> name) plainsOthers )

@@ -27,13 +27,12 @@ import GHC.TypeLits import PgSchema.Types import PgSchema.Utils.Internal-import PgSchema.Utils.TF import Prelude as P   data QueryRead ren sch t = QueryRead   { qrCurrTabNum  :: Int-  , qrPath        :: [(Text, PathKind)]+  , qrPath        :: [PathElem]   , qrParam       :: QueryParam ren sch t }  data ParentInfo = ParentInfo@@ -42,7 +41,7 @@   , piToNum       :: Int   , piParentTab   :: NameNS   , piRefs        :: [Ref' Text]-  , piPath        :: [(Text, PathKind)] }+  , piPath        :: [PathElem] }   deriving Show  data QueryState = QueryState@@ -52,6 +51,11 @@  type MonadQuery ren sch t m = (MonadRWS (QueryRead ren sch t) [SomeToField] QueryState m) +-- | Checks that @r@ describes a decodable @SELECT@ row for @ann@:+--+-- * 'CRecInfo': every field of @r@ maps to a plain column or relation edge of the+--   root table in the schema (field names, kinds, and nesting match 'Cols').+-- * 'FromRow': each mapped field can be read from a PostgreSQL result column. type Selectable ann r = (CRecInfo ann r, FromRow (PgTag ann r))  -- | Run a single @SELECT@ for root table @tab@ (see annotation @ann@ with schema@@ -119,27 +123,27 @@   let     basePath = L.reverse qrPath     (unTextI -> condText, condPars) = F.fold $ L.reverse-      $ mapMaybe (\(CondWithPath @path cond) -> let p = demote @(MapRenPath ren path) in+      $ mapMaybe (\(CondWithPath p cond) ->         if-          | not (basePath `L.isPrefixOf` p) -> Nothing-          | p == basePath -> Just $ first TextI $ pgCond qrCurrTabNum cond-          | otherwise -> L.find ((p ==) . (basePath <>) . (.piPath)) parents+          | not (pathIsPrefixOf basePath p) -> Nothing+          | pathsEqual p basePath -> Just $ first TextI $ pgCond qrCurrTabNum cond+          | otherwise -> L.find (parentPathMatches p basePath . (.piPath)) parents             <&> \pari -> first (TextI @" and ") $ pgCond pari.piToNum cond         ) qrParam.qpConds     (unTextI -> ordText, ordPars) = F.fold $ L.reverse-      $ mapMaybe (\(OrdWithPath @path ord) -> let p = demote @(MapRenPath ren path) in+      $ mapMaybe (\(OrdWithPath p ord) ->         if-          | not (basePath `L.isPrefixOf` p) -> Nothing-          | p == basePath -> Just $ pgOrd qrCurrTabNum ord-          | otherwise -> L.find ((p ==) . (basePath <>) . (.piPath)) parents+          | not (pathIsPrefixOf basePath p) -> Nothing+          | pathsEqual p basePath -> Just $ pgOrd qrCurrTabNum ord+          | otherwise -> L.find (parentPathMatches p basePath . (.piPath)) parents             <&> \pari -> pgOrd pari.piToNum ord         ) qrParam.qpOrds     (distTexts, distPars) = F.fold $ L.reverse-      $ mapMaybe (\(DistWithPath @path dist) -> let p = demote @(MapRenPath ren path) in+      $ mapMaybe (\(DistWithPath p dist) ->         if-          | not (basePath `L.isPrefixOf` p) -> Nothing-          | p == basePath -> Just $ pgDist qrCurrTabNum dist-          | otherwise -> L.find ((p ==) . (basePath <>) . (.piPath)) parents+          | not (pathIsPrefixOf basePath p) -> Nothing+          | pathsEqual p basePath -> Just $ pgDist qrCurrTabNum dist+          | otherwise -> L.find (parentPathMatches p basePath . (.piPath)) parents             <&> \pari -> pgDist pari.piToNum dist         ) qrParam.qpDistinct     sel@@ -219,10 +223,12 @@         , piToNum     = n2         , piParentTab = ri.tabName         , piRefs      = refs-        , piPath      = (fi.fieldDbName, FromHere) : qrPath } : qsParents }+        , piPath      = mkPathStep fi.fieldName fi.fieldDbName FromHere : qrPath }+        : qsParents }     n2 <- gets qsLastTabNum     (flds, pars) <- listen $ local-      (\qr -> qr{ qrCurrTabNum = n2, qrPath = (fi.fieldDbName, FromHere) : qrPath })+      (\qr -> qr{ qrCurrTabNum = n2+        , qrPath = mkPathStep fi.fieldName fi.fieldDbName FromHere : qrPath })       $ traverse fieldM ri.fields     val <- if L.any (fdNullable . fromDef) refs       then do@@ -236,7 +242,8 @@     QueryState {qsLastTabNum = (+1) -> tabNum, qsParents} <- get     modify (const $ QueryState tabNum [])     selText <- local-      (\qr -> qr { qrCurrTabNum = tabNum, qrPath = (fi.fieldDbName, ToHere) : qrPath })+      (\qr -> qr { qrCurrTabNum = tabNum+        , qrPath = mkPathStep fi.fieldName fi.fieldDbName ToHere : qrPath })       $ selectM (refCond tabNum qrCurrTabNum refs) ri     modify (\qs -> qs { qsParents = qsParents })     let@@ -261,18 +268,18 @@         fldt n = (("t" <> show' n <> ".") <>)  withLOWithPath-  :: forall ren sch t r. (LO -> r) -> [(Text, PathKind)] -> LimOffWithPath ren sch t -> Maybe r-withLOWithPath f p (LimOffWithPath @p lo) =-  guard (p == demote @(MapRenPath ren p)) >> pure (f lo)+  :: forall ren sch t r. (LO -> r) -> [PathElem] -> LimOffWithPath ren sch t -> Maybe r+withLOWithPath f p (LimOffWithPath p' lo) =+  guard (pathsEqual p p') >> pure (f lo)  withLOsWithPath-  :: forall ren sch t r. (LO -> r) -> [(Text, PathKind)] -> [LimOffWithPath ren sch t] -> Maybe r+  :: forall ren sch t r. (LO -> r) -> [PathElem] -> [LimOffWithPath ren sch t] -> Maybe r withLOsWithPath f p = join . L.find isJust . L.map (withLOWithPath f p) -lowp :: forall ren sch t. forall (path::[(Symbol, PathKind)]) ->-  (ToStar (MapRenPath ren path), TabDPath sch t (MapRenPath ren path)-  , Snd (TabOnDPath2 sch t (MapRenPath ren path)) ~ RelMany) => LO -> LimOffWithPath ren sch t-lowp p = LimOffWithPath @p+lowp :: forall ren sch t. forall (path :: [PathElemK]) ->+  ( PathCtx ren sch t path, PathEndsMany sch t path ) =>+  LO -> LimOffWithPath ren sch t+lowp p = LimOffWithPath @p (demote @p)  rootLO :: forall ren sch t. LO -> LimOffWithPath ren sch t rootLO = lowp []@@ -282,7 +289,7 @@   maybe "" ((" limit " <>) . show') ml    <> maybe "" ((" offset " <>) . show') mo -loByPath :: forall ren sch t. [(Text, PathKind)] -> [LimOffWithPath ren sch t] -> Text+loByPath :: forall ren sch t. [PathElem] -> [LimOffWithPath ren sch t] -> Text loByPath p = fromMaybe mempty . withLOsWithPath convLO p  runCond :: Int -> CondMonad a -> (a,[SomeToField])@@ -371,59 +378,62 @@ pgDist n dist = evalRWS (convDist dist) ("o", pure n) 0  withCondWithPath :: forall ren sch t r. (forall t'. Cond ren sch t' -> r) ->-  [(Text, PathKind)] -> CondWithPath ren sch t -> Maybe r-withCondWithPath f p (CondWithPath @p' cond) = f cond <$ guard (p == demote @(MapRenPath ren p'))+  [PathElem] -> CondWithPath ren sch t -> Maybe r+withCondWithPath f p (CondWithPath p' cond) =+  f cond <$ guard (pathsEqual p p')  withCondsWithPath :: forall ren sch t r. (forall t'. Cond ren sch t' -> r) ->-  [(Text, PathKind)] -> [CondWithPath ren sch t] -> Maybe r+  [PathElem] -> [CondWithPath ren sch t] -> Maybe r withCondsWithPath f p = join . L.find isJust . L.map (withCondWithPath f p) -cwp :: forall path -> forall ren sch t t1.-  (t1 ~ TabOnDPath sch t (MapRenPath ren path), ToStar (MapRenPath ren path))-  => Cond ren sch t1 -> CondWithPath ren sch t-cwp p = CondWithPath @p+cwp :: forall path -> forall ren sch t.+  PathCtx ren sch t path =>+  Cond ren sch (TabOnDPathRen ren sch t path) -> CondWithPath ren sch t+cwp p = CondWithPath @p (demote @p)  rootCond :: Cond ren sch t -> CondWithPath ren sch t rootCond = cwp [] -condByPath :: Int -> [(Text, PathKind)] -> [CondWithPath ren sch t] -> (Text, [SomeToField])+condByPath :: Int -> [PathElem] -> [CondWithPath ren sch t] -> (Text, [SomeToField]) condByPath num p = F.fold . withCondsWithPath (pgCond num) p -ordByPath :: Int -> [(Text, PathKind)] -> [OrdWithPath ren sch t] -> (TextI ",", [SomeToField])+ordByPath :: Int -> [PathElem] -> [OrdWithPath ren sch t] -> (TextI ",", [SomeToField]) ordByPath num p = F.fold . withOrdsWithPath (pgOrd num) p -distByPath :: Int -> [(Text, PathKind)] -> [DistWithPath ren sch t] -> (DistTexts, [SomeToField])+distByPath :: Int -> [PathElem] -> [DistWithPath ren sch t] -> (DistTexts, [SomeToField]) distByPath num p = F.fold . withDistsWithPath (pgDist num) p  withOrdWithPath :: forall ren sch t r. (forall t'. [OrdFld ren sch t'] -> r) ->-  [(Text, PathKind)] -> OrdWithPath ren sch t -> Maybe r-withOrdWithPath f p (OrdWithPath @p ord) = f ord <$ guard (p == demote @(MapRenPath ren p))+  [PathElem] -> OrdWithPath ren sch t -> Maybe r+withOrdWithPath f p (OrdWithPath p' ord) =+  f ord <$ guard (pathsEqual p p')  withDistWithPath :: forall ren sch t r. (forall t'. Dist ren sch t' -> r) ->-  [(Text, PathKind)] -> DistWithPath ren sch t -> Maybe r-withDistWithPath f p (DistWithPath @p dist) = f dist <$ guard (p == demote @(MapRenPath ren p))+  [PathElem] -> DistWithPath ren sch t -> Maybe r+withDistWithPath f p (DistWithPath p' dist) =+  f dist <$ guard (pathsEqual p p')  -- withOrdsWithPath :: forall ren sch t r . (forall t'. [OrdFld ren sch t'] -> r) ->-  [(Text, PathKind)] -> [OrdWithPath ren sch t] -> Maybe r+  [PathElem] -> [OrdWithPath ren sch t] -> Maybe r withOrdsWithPath f p = join . L.find isJust . L.map (withOrdWithPath f p)  withDistsWithPath :: forall ren sch t r . (forall t'. Dist ren sch t' -> r) ->-  [(Text, PathKind)] -> [DistWithPath ren sch t] -> Maybe r+  [PathElem] -> [DistWithPath ren sch t] -> Maybe r withDistsWithPath f p = join . L.find isJust . L.map (withDistWithPath f p)  owp :: forall path -> forall sch t t'.-  (ToStar (MapRenPath ren path), TabOnDPath sch t (MapRenPath ren path) ~ t') =>+  ( PathCtx ren sch t path, TabOnDPathRen ren sch t path ~ t' ) =>   [OrdFld ren sch t'] -> OrdWithPath ren sch t-owp p = OrdWithPath @p+owp p = OrdWithPath @p (demote @p)  rootOrd :: forall ren sch t. [OrdFld ren sch t] -> OrdWithPath ren sch t rootOrd = owp [] -dwp :: forall path -> forall ren sch t t'.-  (ToStar (MapRenPath ren path), TabOnDPath2 sch t (MapRenPath ren path) ~ '(t', 'RelMany)) =>-  Dist ren sch t' -> DistWithPath ren sch t-dwp p = DistWithPath @p+dwp :: forall path -> forall ren sch t.+  ( PathCtx ren sch t path, PathEndsMany sch t path ) =>+  Dist ren sch (TabOnDPathRen ren sch t path) -> DistWithPath ren sch t+dwp p = DistWithPath @p (demote @p)  rootDist :: forall ren sch t. Dist ren sch t -> DistWithPath ren sch t rootDist = dwp []

@@ -29,7 +29,6 @@ import PgSchema.Ann import PgSchema.Schema import PgSchema.Types-import PgSchema.Utils.Internal import PgSchema.Utils.TF  @@ -53,7 +52,7 @@ qpEmpty = QueryParam [] [] [] []  type MonadQP ren sch t path-  = (TabDPath sch t (MapRenPath ren path), ToStar (MapRenPath ren path))+  = PathCtx ren sch t path   => RWS (Proxy path) () (QueryParam ren sch t) ()  -- | Execute 'MonadQP' and get 'QueryParam'.@@ -67,8 +66,8 @@ -- The 'Symbol' must name the foreign-key constraint (edge to the parent or from the child) -- for the step away from the current table. ---qPath :: forall ren sch t path path' path'' tabPath p' k. forall (p :: Symbol)-  -> PathCheck 'Nothing p ren sch t path path' path'' tabPath p' k+qPath :: forall ren sch t path path' tabPath p' k. forall (p :: Symbol)+  -> PathCheck 'Nothing p ren sch t path path' tabPath p' k   => MonadQP ren sch t path' -> MonadQP ren sch t path qPath _p m = put . fst . execRWS m Proxy =<< get @@ -77,8 +76,8 @@ -- The 'Symbol' must name the foreign-key constraint (edge to the parent) -- for the step away from the current table. ---qPathFromHere :: forall ren sch t path path' path'' tabPath p' k. forall (p :: Symbol)-  -> PathCheck ('Just 'FromHere) p ren sch t path path' path'' tabPath p' k+qPathFromHere :: forall ren sch t path path' tabPath p' k. forall (p :: Symbol)+  -> PathCheck ('Just 'FromHere) p ren sch t path path' tabPath p' k   => MonadQP ren sch t path' -> MonadQP ren sch t path qPathFromHere _p m = put . fst . execRWS m Proxy =<< get @@ -87,52 +86,23 @@ -- The 'Symbol' must name the foreign-key constraint (edge from the child) -- for the step away from the current table. ---qPathToHere :: forall ren sch t path path' path'' tabPath p' k. forall (p :: Symbol)-  -> PathCheck ('Just 'ToHere) p ren sch t path path' path'' tabPath p' k+qPathToHere :: forall ren sch t path path' tabPath p' k. forall (p :: Symbol)+  -> PathCheck ('Just 'ToHere) p ren sch t path path' tabPath p' k   => MonadQP ren sch t path' -> MonadQP ren sch t path qPathToHere _p m = put . fst . execRWS m Proxy =<< get -type family ResolvePathKind-  (pathKind :: Maybe PathKind) (hasFrom :: Bool) (hasTo :: Bool) (tab :: NameNSK) (name :: Symbol)-  :: PathKind where-    ResolvePathKind ('Just 'FromHere) 'True _ _ _ = 'FromHere-    ResolvePathKind ('Just 'ToHere) _ 'True _ _ = 'ToHere-    ResolvePathKind 'Nothing 'True 'False _ _ = 'FromHere-    ResolvePathKind 'Nothing 'False 'True _ _ = 'ToHere-    ResolvePathKind ('Just 'FromHere) _ _ tab name = TypeError-      (TE.Text "Relation is not available in from-here direction."-      :$$: TE.Text "Use qPathToHere or qPath."-      :$$: TE.Text ""-      :$$: TE.Text "Table: " :<>: ShowType tab-      :$$: TE.Text "Relation: " :<>: ShowType name-      :$$: TE.Text "" )-    ResolvePathKind ('Just 'ToHere) _ _ tab name = TypeError-      (TE.Text "Relation is not available in to-here direction."-      :$$: TE.Text "Use qPathFromHere or qPath."-      :$$: TE.Text ""-      :$$: TE.Text "Table: " :<>: ShowType tab-      :$$: TE.Text "Relation: " :<>: ShowType name-      :$$: TE.Text "" )-    ResolvePathKind 'Nothing _ _ tab name = TypeError-      (TE.Text "qPath cannot be used for self-reference relation."-      :$$: TE.Text "Use qPathFromHere or qPathToHere."-      :$$: TE.Text ""-      :$$: TE.Text "Table: " :<>: ShowType tab-      :$$: TE.Text "Relation: " :<>: ShowType name-      :$$: TE.Text "" )--type PathCheck pathKind p ren sch t path path' path'' tabPath p' k =+type PathCheck pathKind p ren sch t path path' tabPath p' k =   ( p' ~ ApplyRenamer ren p-  , tabPath ~ TabOnDPath sch t (MapRenPath ren path)+  , tabPath ~ TabOnDPathRen ren sch t path   , k ~ ResolvePathKind pathKind (HasFromStep sch tabPath p') (HasToStep sch tabPath p') tabPath p'-  , path' ~ (path ++ '[ '(p, k)])-  , path'' ~ MapRenPath ren (path ++ '[ '(p, k)])-  , ToStar path'', TabDPath sch t path'' )+  , path' ~ (path ++ '[ 'PathElem p p' k ])+  , PathCtx ren sch t path'+  ) -- | Add @WHERE@ condition for the current table. -- -- If several 'qWhere' exist they are composed according to the 'Monoid' instance for 'Cond', i.e. with '(&&&)'-qWhere :: forall ren sch t path. Cond ren sch (TabOnDPath sch t (MapRenPath ren path)) -> MonadQP ren sch t path-qWhere c = modify \qp -> qp { qpConds = CondWithPath @path c : qp.qpConds }+qWhere :: forall ren sch t path. Cond ren sch (TabOnDPathRen ren sch t path) -> MonadQP ren sch t path+qWhere c = modify \qp -> qp { qpConds = CondWithPath @path (demote @path) c : qp.qpConds }  -- | Add @ORDER BY@ condition for the current table --@@ -149,14 +119,14 @@ -- -- we get @ORDER BY t1.f1, t2.f2 DESC, t1.f3@ ---qOrderBy :: forall ren sch t path. [OrdFld ren sch (TabOnDPath sch t (MapRenPath ren path))] -> MonadQP ren sch t path-qOrderBy ofs = modify \qp -> qp { qpOrds = OrdWithPath @path ofs : qp.qpOrds }+qOrderBy :: forall ren sch t path. [OrdFld ren sch (TabOnDPathRen ren sch t path)] -> MonadQP ren sch t path+qOrderBy ofs = modify \qp -> qp { qpOrds = OrdWithPath @path (demote @path) ofs : qp.qpOrds }  -- | Add `DISTINCT` condition for the current table. -- It is applied only to "root" or "children" tables.-qDistinct :: forall ren sch t path t'. TabOnDPath2 sch t path ~ '(t', 'RelMany) =>+qDistinct :: forall ren sch t path. PathEndsMany sch t path =>   MonadQP ren sch t path-qDistinct = modify \qp -> qp { qpDistinct = DistWithPath @path Distinct : qp.qpDistinct }+qDistinct = modify \qp -> qp { qpDistinct = DistWithPath @path (demote @path) Distinct : qp.qpDistinct }  -- | Add @DISTINCT ON@ condition for the current table. --@@ -176,60 +146,60 @@ -- -- we get @DISTINCT ON (t1.f1, t2.f2, t1.f3) ... ORDER BY t1.f1, t2.f2 DESC, t1.f3, t1.f0 DESC@ ---qDistinctOn :: forall ren sch t path. [OrdFld ren sch (TabOnDPath sch t (MapRenPath ren path))] -> MonadQP ren sch t path-qDistinctOn ofs = modify \qp -> qp { qpDistinct = DistWithPath @path (DistinctOn ofs) : qp.qpDistinct }+qDistinctOn :: forall ren sch t path. [OrdFld ren sch (TabOnDPathRen ren sch t path)] -> MonadQP ren sch t path+qDistinctOn ofs =+  modify \qp -> qp { qpDistinct = DistWithPath @path (demote @path) (DistinctOn ofs) : qp.qpDistinct }  -- | Add `LIMIT` condition for the current table. -- It is applied only to "root" or "children" tables. -- -- If 'qLimit' is applied several times on the same path, only the last one is used-qLimit :: forall ren sch t path. Snd (TabOnDPath2 sch t (MapRenPath ren path)) ~ RelMany-  => Natural -> MonadQP ren sch t path+qLimit :: forall ren sch t path. PathEndsMany sch t path =>+  Natural -> MonadQP ren sch t path qLimit n = modify \qp -> qp { qpLOs = mk qp.qpLOs }   where     mk xs = case L.break eq xs of       (xs1, []) -> new : xs1       (xs1, x:xs2) -> xs1 <> [upd x] <> xs2-    eq (LimOffWithPath @p _) = demote @(MapRenPath ren p) == demote @(MapRenPath ren path)-    upd (LimOffWithPath @p lo) = LimOffWithPath @p lo{ limit = Just n }-    new = LimOffWithPath @path LO { limit = Just n, offset = Nothing }+    eq (LimOffWithPath p _) = pathsEqual p (demote @path)+    upd (LimOffWithPath @p' p lo) = LimOffWithPath @p' p lo{ limit = Just n }+    new = LimOffWithPath @path (demote @path) LO { limit = Just n, offset = Nothing }  -- | Add `OFFSET` condition for the current table. -- It is applied only to "root" or "children" tables. -- -- If 'qOffset' is applied several times on the same path, only the last one is used-qOffset :: forall ren sch t path. Snd (TabOnDPath2 sch t (MapRenPath ren path)) ~ RelMany-  => Natural -> MonadQP ren sch t path+qOffset :: forall ren sch t path. PathEndsMany sch t path =>+  Natural -> MonadQP ren sch t path qOffset n = modify \qp -> qp { qpLOs = mk qp.qpLOs }   where     mk xs = case L.break eq xs of       (xs1, []) -> new : xs1       (xs1, x:xs2) -> xs1 <> [upd x] <> xs2-    eq (LimOffWithPath @p _) = demote @(MapRenPath ren p) == demote @(MapRenPath ren path)-    upd (LimOffWithPath @p lo) = LimOffWithPath @p lo{offset = Just n}-    new = LimOffWithPath @path LO { offset = Just n, limit = Nothing }+    eq (LimOffWithPath p _) = pathsEqual p (demote @path)+    upd (LimOffWithPath @p' p lo) = LimOffWithPath @p' p lo{offset = Just n}+    new = LimOffWithPath @path (demote @path) LO { offset = Just n, limit = Nothing }  -- | GADT to safely set `where` condition data CondWithPath ren sch t where-  CondWithPath ::  forall (path :: [(Symbol, PathKind)]) ren sch t. ToStar (MapRenPath ren path)-    => Cond ren sch (TabOnDPath sch t (MapRenPath ren path)) -> CondWithPath ren sch t+  CondWithPath :: forall (path :: [PathElemK]) ren sch t. PathCtx ren sch t path+    => [PathElem] -> Cond ren sch (TabOnDPathRen ren sch t path) -> CondWithPath ren sch t  -- | GADT to safely set `order by` clauses data OrdWithPath ren sch t where-  OrdWithPath :: forall (path :: [(Symbol, PathKind)]) ren sch t. ToStar (MapRenPath ren path)-    => [OrdFld ren sch (TabOnDPath sch t (MapRenPath ren path))] -> OrdWithPath ren sch t+  OrdWithPath :: forall (path :: [PathElemK]) ren sch t. PathCtx ren sch t path+    => [PathElem] -> [OrdFld ren sch (TabOnDPathRen ren sch t path)] -> OrdWithPath ren sch t  -- | GADT to safely set `distinct/distinct on` clauses data DistWithPath ren sch t where-  DistWithPath :: forall (path :: [(Symbol, PathKind)]) ren sch t. ToStar (MapRenPath ren path)-    => Dist ren sch (TabOnDPath sch t (MapRenPath ren path)) -> DistWithPath ren sch t+  DistWithPath :: forall (path :: [PathElemK]) ren sch t. PathCtx ren sch t path+    => [PathElem] -> Dist ren sch (TabOnDPathRen ren sch t path) -> DistWithPath ren sch t  -- | GADT to safely set `limit/offset` clauses data LimOffWithPath ren sch t where-  LimOffWithPath :: forall (path :: [(Symbol, PathKind)]) ren sch t.-    ( TabDPath sch t (MapRenPath ren path), ToStar (MapRenPath ren path)-    , Snd (TabOnDPath2 sch t (MapRenPath ren path)) ~ 'RelMany )-    => LO -> LimOffWithPath ren sch t+  LimOffWithPath :: forall (path :: [PathElemK]) ren sch t.+    ( PathCtx ren sch t path, PathEndsMany sch t path )+    => [PathElem] -> LO -> LimOffWithPath ren sch t  -- | Comparison constructors; each is paired with its corresponding operator -- (e.g. '(:=)' with '(=?)').@@ -352,7 +322,7 @@   , order :: [OrdFld ren sch tab]   , lo :: LO } --- | Default empty 'TabParam'.+-- | Default empty 'TabParam': no conditions, no ordering, no limits. defTabParam :: TabParam ren sch tab defTabParam = TabParam mempty mempty defLO @@ -465,17 +435,20 @@   DistinctOn :: [OrdFld ren sch tab] -> Dist ren sch tab  {-# INLINE ordf #-}+-- | Sort by field in the given direction. ordf   :: forall fld -> forall sch tab. CDBField sch tab (ApplyRenamer ren fld)   => OrdDirection -> OrdFld ren sch tab ordf fld = OrdFld @fld  {-# INLINE ascf #-}+-- | Sort ascending by field. ascf :: forall fld -> forall sch tab. CDBField sch tab (ApplyRenamer ren fld)   => OrdFld ren sch tab ascf fld = ordf fld Asc  {-# INLINE descf #-}+-- | Sort descending by field. descf :: forall fld -> forall sch tab. CDBField sch tab (ApplyRenamer ren fld)   => OrdFld ren sch tab descf fld = ordf fld Desc@@ -485,8 +458,10 @@   , offset :: Maybe Natural }   deriving Show +-- | No limit and no offset. defLO :: LO defLO = LO Nothing Nothing +-- | Limit 1 and no offset. lo1 :: LO lo1 = LO (Just 1) Nothing

@@ -1,22 +1,112 @@-module PgSchema.DML.Update where+{-# LANGUAGE AllowAmbiguousTypes #-}+module PgSchema.DML.Update+  ( updateByKey, updateByKey_, updateByKeyText, updateByKeyText_+  , updateByCond, updateByCond_, updateText, updateText_+  , updateByKeyRowParams ) where  import Data.String import Data.Text as T import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.ToField (Action)+import Database.PostgreSQL.Simple.ToRow (ToRow(..)) import GHC.Int import PgSchema.Ann import PgSchema.DML.Select import PgSchema.DML.Select.Types+import Control.Monad (forM)+import Data.List as L+import Data.Maybe import PgSchema.DML.Insert.Types-import PgSchema.Schema+import PgSchema.DML.KeyedWrite+import Data.Map qualified as M+import PgSchema.Schema (CSchema, qualName, tabInfoMap) import PgSchema.Types import PgSchema.Utils.Internal import Prelude as P --- TODO:--- updateByKey Connection -> [r] -> IO [r']--- updateByKeyJSON Connection -> [r] -> IO [r']--- updateExp (e.q. update t set a = a + c + 1 where b > 10)+newtype KeyedUpdateParams = KeyedUpdateParams { keyedUpdateActions :: [Action] }++instance ToRow KeyedUpdateParams where+  toRow = keyedUpdateActions++updateByKeyRowParams+  :: forall ann r+  . (CRecInfo ann r, CSchema (AnnSch ann), ToRow (PgTag ann r))+  => r -> KeyedUpdateParams+updateByKeyRowParams rec =+  let+    ri = getRecordInfo @ann @r+    ti = tabInfoMap @(AnnSch ann) M.! ri.tabName+    keyNames = fromMaybe [] $ pickKeyNames ti [fi.fieldDbName | fi <- ri.fields]+    (fldKeys, fldOthers) =+      L.partition ((`L.elem` keyNames) . (.fieldDbName)) ri.fields+    allActs = toRow (PgTag @ann @r rec)+    pick fi =+      allActs+        !! fromMaybe (error "updateByKeyRowParams: field")+          (L.findIndex ((== fi.fieldDbName) . (.fieldDbName)) ri.fields)+  in KeyedUpdateParams $ P.map pick (fldOthers ++ fldKeys)++-- | Update rows by primary / unique key from record fields (never inserts).+--+-- Returning type @r'@ is a bare row; the result is @IO ([Maybe r'], Text)@+-- with @Nothing@ when no row matched the key.+updateByKey+  :: forall ann -> forall r r'. UpdateByKeyReturning ann r r'+  => Connection -> [r] -> IO ([Maybe r'], Text)+updateByKey ann @r @r' conn recs =+  let sql = updateByKeyText ann @r @r' in+  trace' (T.unpack sql) do+    rs <- forM recs \rec -> do+      rows <- query conn (fromString $ T.unpack sql) (updateByKeyRowParams @ann @r rec)+      pure $ case rows of+        [x] -> Just (unPgTag @ann @r' x)+        _ -> Nothing+    pure (rs, sql)++-- | Update rows by key without @RETURNING@.+updateByKey_+  :: forall ann -> forall r. UpdateByKeyNonReturning ann r+  => Connection -> [r] -> IO (Int64, Text)+updateByKey_ ann @r conn recs =+  let sql = updateByKeyText_ ann @r in+  trace' (T.unpack sql) do+    n <- executeMany conn (fromString $ T.unpack sql)+      $ fmap (updateByKeyRowParams @ann @r) recs+    pure (n, sql)++updateByKeyText+  :: forall ann -> forall r r' s+  . ( CRecInfo ann r, CRecInfo ann r', IsString s, Monoid s, HasSchema ann ) => s+updateByKeyText ann @r @r' =+  updateByKeyText_ ann @r <> " returning " <> fs'+  where+    ri' = getRecordInfo @ann @r'+    fs' = fromString $ T.unpack $ T.intercalate "," [fi.fieldDbName | fi <- ri'.fields]++updateByKeyText_+  :: forall ann -> forall r s+  . (IsString s, Monoid s, CRecInfo ann r, HasSchema ann) => s+updateByKeyText_ ann @r = fromString $ T.unpack $ updateByKeyStmt ann @r++updateByKeyStmt+  :: forall ann -> forall r. (CRecInfo ann r, HasSchema ann) => T.Text+updateByKeyStmt ann @r =+  let+    ri = getRecordInfo @ann @r+    ti = tabInfoMap @(AnnSch ann) M.! ri.tabName+    plains = [ (fromText fi.fieldDbName, "?") | fi <- ri.fields ]+    (plainsKey, plainsOthers) = keyedUpdateSetAndKeys ti plains+    nameVal n v = n <> " = " <> v+    setClause =+      case plainsOthers of+        [] -> case plainsKey of+          (n, _) : _ -> n <> " = " <> n+          [] -> "id = id"+        xs -> T.intercalate ", " (uncurry nameVal <$> xs)+  in "update " <> qualName ri.tabName+    <> " set " <> setClause+    <> keyWhereClause plainsKey  -- | Update rows matching a condition; the result type selects which columns are returned. updateByCond :: forall ann -> forall r r'.

@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedRecordDot #-}+module PgSchema.DML.UpsertByKey+  ( upsertByKey, upsertByKey_, upsertByKeyText, upsertByKeyText_ ) where++import Data.List as L+import Data.Maybe+import Data.String+import Data.Text as T+import Database.PostgreSQL.Simple+import GHC.Int+import PgSchema.Ann+import PgSchema.DML.Insert.Types+import PgSchema.DML.KeyedWrite+import Data.Map qualified as M+import PgSchema.Schema (qualName, tabInfoMap)+import PgSchema.Types+import PgSchema.Utils.Internal+import Prelude as P+++upsertByKey+  :: forall ann -> forall r r'. UpsertByKeyReturning ann r r'+  => Connection -> [r] -> IO ([r'], Text)+upsertByKey ann @r @r' conn recs = let sql = upsertByKeyText ann @r @r' in+  trace' (T.unpack sql) do+    (, sql)+      <$> fmap (fmap (unPgTag @ann @r'))+      ( returning conn (fromString $ T.unpack sql)+      $ fmap (PgTag @ann @r) recs )++upsertByKey_+  :: forall ann -> forall r. UpsertByKeyNonReturning ann r+  => Connection -> [r] -> IO (Int64, Text)+upsertByKey_ ann @r conn recs = let sql = upsertByKeyText_ ann @r in+  trace' (T.unpack sql)+    $ fmap (, sql)+    . executeMany conn (fromString $ T.unpack sql)+    . fmap (PgTag @ann @r) $ recs++upsertByKeyText+  :: forall ann -> forall r r' s+  . (UpsertByKeyReturning ann r r', IsString s, Monoid s) => s+upsertByKeyText ann @r @r' = upsertByKeyText_ ann @r <> " returning " <> fs'+  where+    ri' = getRecordInfo @ann @r'+    fs' = fromText $ T.intercalate "," [fi.fieldDbName | fi <- ri'.fields]++upsertByKeyText_+  :: forall ann -> forall r s+  . (UpsertByKeyNonReturning ann r, IsString s, Monoid s) => s+upsertByKeyText_ ann @r = fromString $ T.unpack $ upsertByKeyStmt ann @r++upsertByKeyStmt :: forall ann -> forall r. UpsertByKeyNonReturning ann r => Text+upsertByKeyStmt ann @r+  | L.null plainsOthers = ins <> " on conflict do nothing"+  | otherwise = ins <> upsertOnConflict plainsOthers keyNames+  where+    ri = getRecordInfo @ann @r+    ti = tabInfoMap @(AnnSch ann) M.! ri.tabName+    flds = [ (fromText fi.fieldDbName, "?") | fi <- ri.fields ]+    srcFlds = fst <$> flds+    keyNames = fromMaybe [] $ pickKeyNames ti srcFlds+    (_, plainsOthers) = keyedUpdateSetAndKeys ti flds+    ins =+      "insert into " <> qualName ri.tabName+      <> "(" <> intercalate' ", " srcFlds <> ") values ("+      <> intercalate' ", " (snd <$> flds) <> ")"

@@ -2,7 +2,6 @@ {-# LANGUAGE ParallelListComp #-} module PgSchema.Schema where -import Data.Kind import Data.List as L import Data.Map as M import Data.Singletons@@ -61,6 +60,13 @@ -- | Direction of one path step relative to the current table. data PathKind = FromHere | ToHere deriving (Show, Eq) +-- | One step of a 'SELECT' query path: logical branch name, DB fk name, direction.+data PathElem' s = PathElem+  { peName   :: s+  , peDbName :: s+  , peKind   :: PathKind+  } deriving (Show, Eq)+ -- | Field of a logical record: plain column, aggregate, or relation hop. data RecField' s p   = RFEmpty s -- ^ Placeholder / unnamed slot (depending on schema codegen).@@ -88,7 +94,7 @@  genSingletons   [ ''AggrFun, ''NameNS', ''TypDef', ''FldDef', ''TabDef', ''RelDef', ''RelType-  , ''PathKind+  , ''PathKind, ''PathElem'   , ''RecField', ''Ref' ]  type NameNSK = NameNS' Symbol@@ -104,7 +110,41 @@ type FldDef = FldDef' Text type TabDef = TabDef' Text type RelDef = RelDef' Text+type PathElemK = PathElem' Symbol+type PathElem = PathElem' Text +mkPathStep :: Text -> Text -> PathKind -> PathElem+mkPathStep name db kind = PathElem{peName = name, peDbName = db, peKind = kind}++-- | Broadcast step: 'peName' is the db/fk key from 'qPath', not a Haskell field.+pathStepBroadcast :: PathElem -> Bool+pathStepBroadcast s = s.peName == s.peDbName++-- | Whether a query-path step applies to a runtime tree-path step.+pathStepMatches :: PathElem -> PathElem -> Bool+pathStepMatches cond rt =+  cond.peKind == rt.peKind+  && cond.peDbName == rt.peDbName+  && ( cond.peName == rt.peName+    || cond.peName == cond.peDbName+    )++pathsEqual :: [PathElem] -> [PathElem] -> Bool+pathsEqual xs ys =+  L.length xs == L.length ys+  && and (L.zipWith pathStepMatches xs ys)++pathIsPrefixOfBy :: (PathElem -> PathElem -> Bool) -> [PathElem] -> [PathElem] -> Bool+pathIsPrefixOfBy _ [] _ = True+pathIsPrefixOfBy f (x : xs) (y : ys) = f x y && pathIsPrefixOfBy f xs ys+pathIsPrefixOfBy _ _ [] = False++pathIsPrefixOf :: [PathElem] -> [PathElem] -> Bool+pathIsPrefixOf = pathIsPrefixOfBy $ flip pathStepMatches++parentPathMatches :: [PathElem] -> [PathElem] -> [PathElem] -> Bool+parentPathMatches p basePath piPath = pathsEqual p (basePath <> piPath)+ infixr 9 ->> (->>) :: Text -> Text -> NameNS (->>) = NameNS@@ -113,14 +153,6 @@  type SimpleType c = 'TypDef c 'Nothing '[] -type family GetRelTab (froms :: [(NameNSK, RelDefK)])-  (tos :: [(NameNSK, RelDefK)]) (s :: Symbol) :: (NameNSK, RelType) where-    GetRelTab '[] '[] s = TypeError ('Text "No relation by name" ':$$: 'ShowType s)-    GetRelTab ('(a,b) ':xs) ys s =-      If (NnsName a == s) '(RdTo b, RelOne) (GetRelTab xs ys s)-    GetRelTab '[] ('(c,d) ':ys) s =-      If (NnsName c == s) '(RdFrom d, RelMany) (GetRelTab '[] ys s)- type IsMandatory fd = Not (FdNullable fd || FdHasDefault fd) type IsMandatory' sch tab fld = IsMandatory (GetFldDef sch tab fld) @@ -151,9 +183,10 @@   AppendPK '[] uks = uks   AppendPK pk uks = pk ': uks --- | Keys accepted by 'CheckAllMandatoryOrHasKey': PK plus every unique+-- | Keys accepted by 'CheckAllMandatoryOrHasKey' (tree upsert) and+-- 'CheckHasKey' (flat 'updateByKey' / 'upsertByKey'): PK plus every unique -- constraint from the schema (catalog order). Runtime key choice uses--- 'PgSchema.DML.InsertJSON.identityCandidatesFromTab' and its priority rules.+-- 'PgSchema.DML.KeyedWrite.identityCandidatesFromTab' and its priority rules. type family IdentityCandidates sch tab :: [[Symbol]] where   IdentityCandidates sch tab =     AppendPK (TdKey (TTabDef sch tab)) (TdUniq (TTabDef sch tab))@@ -288,10 +321,6 @@ typDefMap = M.fromList $ L.zip   (demote @(TTypes sch)) (demote @(Map1 (TTypDefSym1 sch) (TTypes sch))) -type TRelTab sch t name = GetRelTab-  (Map2 (TRelDefSym1 sch) (TFrom sch t)) (Map2 (TRelDefSym1 sch) (TTo sch t))-  name- type family GetRelDef (rels :: [(NameNSK, RelDefK)]) (s :: Symbol) :: RelDefK where   GetRelDef '[] s = TypeError ('Text "No relation by name" ':$$: 'ShowType s)   GetRelDef ('(a, b) ': xs) s = If (NnsName a == s) b (GetRelDef xs s)@@ -302,32 +331,26 @@ type family TRelToTab sch t name :: NameNSK where   TRelToTab sch t name = RdFrom (GetRelDef (Map2 (TRelDefSym1 sch) (TTo sch t)) name) -type family TabOnPath2 sch (t :: NameNSK) (path :: [Symbol]) :: (NameNSK, RelType) where-  TabOnPath2 sch t '[] = '(t, 'RelMany)-  TabOnPath2 sch t '[x] = TRelTab sch t x-  TabOnPath2 sch t (x ': xs) = TabOnPath2 sch (Fst (TRelTab sch t x)) xs--type TabOnPath sch (t :: NameNSK) (path :: [Symbol]) = Fst (TabOnPath2 sch t path)-+-- | Walk a directed @path@ from root table @t@. ---type family TabPath sch (t :: NameNSK) (path :: [Symbol]) :: Constraint where-  TabPath sch t '[] = ()-  TabPath sch t (x ': xs) = TabPath sch (Fst (TRelTab sch t x)) xs--type family TabOnDPath2 sch (t :: NameNSK) (path :: [(Symbol, PathKind)]) :: (NameNSK, RelType) where+-- Each step is a 'PathElem' (schema walk uses 'peDbName'). Result: end table and+-- its cardinality ('RelOne' for a single parent step, 'RelMany' for a single child).+type family TabOnDPath2 sch (t :: NameNSK) (path :: [PathElemK]) :: (NameNSK, RelType) where   TabOnDPath2 sch t '[] = '(t, 'RelMany)-  TabOnDPath2 sch t '[ '(name, 'FromHere)] = '(TRelFromTab sch t name, 'RelOne)-  TabOnDPath2 sch t '[ '(name, 'ToHere)] = '(TRelToTab sch t name, 'RelMany)-  TabOnDPath2 sch t ('(name, 'FromHere) ': xs) = TabOnDPath2 sch (TRelFromTab sch t name) xs-  TabOnDPath2 sch t ('(name, 'ToHere) ': xs) = TabOnDPath2 sch (TRelToTab sch t name) xs+  TabOnDPath2 sch t '[ 'PathElem _ name 'FromHere] =+    '(TRelFromTab sch t name, 'RelOne)+  TabOnDPath2 sch t '[ 'PathElem _ name 'ToHere] =+    '(TRelToTab sch t name, 'RelMany)+  TabOnDPath2 sch t ('PathElem _ name 'FromHere ': xs) =+    TabOnDPath2 sch (TRelFromTab sch t name) xs+  TabOnDPath2 sch t ('PathElem _ name 'ToHere ': xs) =+    TabOnDPath2 sch (TRelToTab sch t name) xs -type family TabOnDPath sch (t :: NameNSK) (path :: [(Symbol, PathKind)]) :: NameNSK where-  TabOnDPath sch t path = Fst (TabOnDPath2 sch t path)+-- | Table reached after walking directed @path@ from @t@ ('Fst' of 'TabOnDPath2').+type TabAtPath sch t path = Fst (TabOnDPath2 sch t path) -type family TabDPath sch (t :: NameNSK) (path :: [(Symbol, PathKind)]) :: Constraint where-  TabDPath sch t '[] = ()-  TabDPath sch t ('(name, 'FromHere) ': xs) = TabDPath sch (TRelFromTab sch t name) xs-  TabDPath sch t ('(name, 'ToHere) ': xs) = TabDPath sch (TRelToTab sch t name) xs+-- | Current position has child cardinality ('RelMany'): root or child table.+type PathEndsMany sch t path = Snd (TabOnDPath2 sch t path) ~ 'RelMany  type RecField = RecField' Text type Ref = Ref' Text@@ -355,26 +378,30 @@ type HasFromStep sch tab name = HasRelName (TFrom sch tab) name type HasToStep   sch tab name = HasRelName (TTo sch tab) name -type family CheckStep (pathKind :: (Maybe PathKind)) (hasFrom :: Bool) (hasTo :: Bool) sch tab name :: Constraint where-  CheckStep ('Just FromHere) 'True _ sch tab name = ()-  CheckStep ('Just 'ToHere)   _ 'True sch tab name = ()-  CheckStep 'Nothing 'True 'False sch tab name = ()-  CheckStep 'Nothing 'False 'True sch tab name = ()-  CheckStep ('Just 'FromHere) _ _ sch tab name = TypeError+-- | Resolve 'PathKind' for 'qPath' / 'qPathFromHere' / 'qPathToHere'.+type family ResolvePathKind+  (pathKind :: Maybe PathKind) (hasFrom :: Bool) (hasTo :: Bool) (tab :: NameNSK)+  (name :: Symbol)+  :: PathKind where+  ResolvePathKind ('Just 'FromHere) 'True _ _ _ = 'FromHere+  ResolvePathKind ('Just 'ToHere) _ 'True _ _ = 'ToHere+  ResolvePathKind 'Nothing 'True 'False _ _ = 'FromHere+  ResolvePathKind 'Nothing 'False 'True _ _ = 'ToHere+  ResolvePathKind ('Just 'FromHere) _ _ tab name = TypeError     ( TL.Text "Relation is not available in from-here direction."     :$$: TL.Text "Use qPathToHere or qPath."     :$$: TL.Text ""     :$$: TL.Text "Table: " :<>: ShowType tab     :$$: TL.Text "Relation: " :<>: ShowType name     :$$: TL.Text "" )-  CheckStep ('Just 'ToHere) _ _ sch tab name = TypeError+  ResolvePathKind ('Just 'ToHere) _ _ tab name = TypeError     ( TL.Text "Relation is not available in to-here direction."     :$$: TL.Text "Use qPathFromHere or qPath."     :$$: TL.Text ""     :$$: TL.Text "Table: " :<>: ShowType tab     :$$: TL.Text "Relation: " :<>: ShowType name     :$$: TL.Text "" )-  CheckStep 'Nothing _ _ sch tab name = TypeError+  ResolvePathKind 'Nothing _ _ tab name = TypeError     ( TL.Text "qPath cannot be used for self-reference relation."     :$$: TL.Text "Use qPathFromHere or qPathToHere."     :$$: TL.Text ""

@@ -66,9 +66,10 @@ #endif  --- | Introduce `enum` database types.+-- | Representation of `enum` database types.+-- -- Data instances are produced by schema generation.--- You can use these data instances in you records to @SELECT@/@INSERT@/@UPSERT@ data+-- You can use these data instances in your records to @SELECT@ | @INSERT@ | @UPSERT@ data. data family PGEnum sch (name :: NameNSK) :: Type  instance@@ -111,9 +112,9 @@   size = F.size . P.show #endif --- | Introduce aggregate functions.+-- | Representation of aggregate functions. ----- I.e. @"fld" := Aggr AMin (Maybe Int32)@ means "minimum value of the field `fld`"+-- E.g. @\"fld\" := Aggr AMin (Maybe Int32)@ means "minimum value of the field `fld`" -- -- 'Aggr' requires a 'Maybe' argument for all functions except @count@. --

@@ -12,6 +12,7 @@ import Tests.Hierarchy import Tests.InsertJSONTransaction import Tests.UpsertUniqueKey+import Tests.KeyedDML import Tests.Conditions import Tests.Aggregates @@ -48,6 +49,28 @@       , testProperty "Failure rolls back standalone transaction" $           prop_insertJSON_rolls_back_on_failure pool       ]+    , testGroup "Keyed DML (test_dml)"+      [ testProperty "upsertByKey insert then key patch" $+          prop_upsert_by_key_insert_then_update pool+      , testProperty "upsertByKey composite unique" $+          prop_upsert_by_key_composite_unique pool+      , testProperty "upsertByKey always INSERT ON CONFLICT SQL" $+          prop_upsert_by_key_never_pure_update pool+      , testProperty "updateByKey found" $ prop_update_by_key_found pool+      , testProperty "updateByKey not found" $+          prop_update_by_key_not_found pool+      , testProperty "updateByKey never inserts" $+          prop_update_by_key_never_inserts pool+      , testProperty "updateJSON bad root id" $+          prop_update_json_not_found_returns_nothing pool+      , testProperty "updateJSON found" $ prop_update_json_found pool+      , testProperty "upsertJSON returning positions" $+          prop_upsert_json_returning_positions pool+      , testProperty "upsertJSON full row bare returning" $+          prop_upsert_json_full_row_bare_returning pool+      , testProperty "updateJSON child key miss" $+          prop_update_json_child_maybe pool+      ]     , testGroup "Upsert by unique key (test_dml)"       [ testProperty "upsertJSON on composite unique without PK in payload" $           prop_upsert_json_by_composite_unique pool@@ -61,6 +84,10 @@     , testGroup "Query (test_dml)"       [ testProperty "'Simple' queries" $ prop_cond_query pool       , testProperty "Conditions by duplicated path" $ prop_cond_by_dup_path pool+      , testProperty "Renamer: independent filters per aliased fk field" $+          prop_renamer_alias_dual_fields pool+      , testProperty "Renamer: broadcast qPath by shared db fk" $+          prop_renamer_broadcast_dual_fields pool       ]     , testGroup "Aggregates (test_dml)"       [ testProperty "Aggr' on plain column is not in GROUP BY" $

@@ -61,11 +61,12 @@ prop_base_converts pool = withTests 30 $ property do   recs <- forAll (genData BaseConverts)   (resSel, resIns, resUpd) <- evalIO $ withPool pool \conn -> do+    void $ delByCond "base_converts" conn mempty     void $ insSch_ "base_converts" conn recs     (res, _) <- selSch "base_converts" conn qpEmpty     res'' <- updByCond "base_converts" conn       ("cint4" =: Just (10 :: Int32)) ("cboolean" =? Just False)-    (res', _) <- insSch "base_converts" conn recs+    (res' :: [BaseConverts], _) <- insSch "base_converts" conn recs     pure (res, res', res'')   L.sort resSel === L.sort recs   resIns === recs@@ -77,11 +78,12 @@   recs <- forAll (genData BaseArrConverts)   ds <- forAll $ Gen.list (Range.linear 0 20) genUTCTime   (resSel, resIns, resUpd::[BaseArrConverts]) <- evalIO $ withPool pool \conn -> do+    void $ delByCond "base_arr_converts" conn mempty     void $ insSch_ "base_arr_converts" conn recs     (res, _) <- selSch "base_arr_converts" conn qpEmpty     res'' <- updByCond "base_arr_converts" conn       ("ctimestamptz" =: Just (pgArr' ds)) mempty-    (res', _) <- insSch "base_arr_converts" conn recs+    (res' :: [BaseArrConverts], _) <- insSch "base_arr_converts" conn recs     pure (res, res', res'')   L.sort resSel === L.sort recs   resIns === recs@@ -91,11 +93,12 @@ prop_ext_converts pool = withTests 30 $ property do   recs <- forAll (genData ExtConverts)   (resSel, resIns, resUpd) <- evalIO $ withPool pool \conn -> do+    void $ delByCond "ext_converts" conn mempty     void $ insSch_ "ext_converts" conn recs     (res, _) <- selSch "ext_converts" conn qpEmpty     res'' <- updByCond "ext_converts" conn       ("ccitext" =: Just ("CaSes" :: CI Text)) ("ccolor" =? Just Color_red)-    (res', _) <- insSch "ext_converts" conn recs+    (res' :: [ExtConverts], _) <- insSch "ext_converts" conn recs     pure (res, res', res'')   L.sort resSel === L.sort recs   resIns === recs

@@ -6,6 +6,7 @@  module Tests.Conditions where +import Control.Monad (forM_) import Control.Monad.IO.Class import Data.Functor import Data.Function@@ -14,7 +15,7 @@ import Data.Pool as Pool import Data.Text as T import Database.PostgreSQL.Simple-import GHC.Generics+import GHC.Generics (Generic) import GHC.Int import GHC.Stack (HasCallStack) import Hedgehog@@ -22,20 +23,10 @@ import Utils  -data RootI = MkRootI-  { code :: Text-  , grp :: Int32-  , someEmpty :: ()-  , name :: Text }-  deriving (Show, Generic)-  deriving anyclass GenDefault--data Mid1I = MkMid1I-  { pos :: Int32-  , flag :: Bool-  , sort_key :: Int32-  , payload :: Maybe Text }-  deriving (Show, Generic)+data LeafI = MkLeafI+  { leafNo :: Int32+  , value :: Double }+  deriving stock (Eq, Ord, Show, Generic)   deriving anyclass GenDefault  data Mid2I = MkMid2I@@ -43,28 +34,51 @@   , kind :: Text   , flag :: Bool   , priority :: Int32 }-  deriving (Show, Generic, Eq, Ord)+  deriving stock (Eq, Ord, Show, Generic)   deriving anyclass GenDefault -data LeafI = MkLeafI-  { leaf_no :: Int32-  , value :: Double }-  deriving (Generic, Eq, Ord, Show)+data Mid1I = MkMid1I+  { pos :: Int32+  , flag :: Bool+  , sortKey :: Int32+  , payload :: Maybe Text }+  deriving stock (Eq, Ord, Show, Generic)   deriving anyclass GenDefault -eqRoot :: RootI -> RootI -> Bool-eqRoot r1 r2 = (r1.code, r1.grp) == (r2.code, r2.grp)+data RootI = MkRootI+  { code :: Text+  , grp :: Int32+  , someEmpty :: ()+  , name :: Text }+  deriving stock (Show, Generic)+  deriving anyclass GenDefault  type InsData = "mid1_root_fk" := [Mid1I]   :. "mid2_root_fk" := ["leaf_mid2_fk" := [LeafI] :. Mid2I]   :. RootI +-- | Two edges in the result type that renamer maps to the same DB fk+-- ('mid1_root_fk2' -> 'mid1_root_fk'); each branch gets its own 'qPath' filter.+data RootDualMid1 = MkRootDualMid1+  { code :: Text+  , grp :: Int32+  , someEmpty :: ()+  , name :: Text+  , mid1RootFk :: [Mid1I] -- Renamer renames it to "mid1_root_fk"+  , mid1_root_fk2 :: [Mid1I] -- Renamer renames it to "mid1_root_fk"+  }+  deriving stock (Show, Generic)+  deriving anyclass GenDefault++eqRoot :: RootI -> RootI -> Bool+eqRoot r1 r2 = (r1.code, r1.grp) == (r2.code, r2.grp)+ insData :: MonadIO m => Pool Connection -> PropertyT m [InsData] insData pool = do   rootsIn <- forAll (L.nubBy eqRoot <$> genData' RootI 1 200)   mid1In <- forAll (genData' Mid1I 0 10)   mid2In <- forAll (L.nubBy ((==) `on` (.seq)) <$> genData' Mid2I 0 10)-  leafIn <- forAll (L.nubBy ((==) `on` (.leaf_no)) <$> genData' LeafI 0 10)+  leafIn <- forAll (L.nubBy ((==) `on` (.leafNo)) <$> genData' LeafI 0 10)   let     inIns = rootsIn <&> \r -> "mid1_root_fk" =: mid1In       :. "mid2_root_fk" =: (mid2In <&> \m2 -> "leaf_mid2_fk" =: leafIn :. m2)@@ -94,27 +108,73 @@           qWhere $ pparent (TS "leaf_mid2_fk")             $ pparent (TS "mid2_root_fk") $ "grp" >? (0::Int32)         qOrderBy [descf "kind"]-  L.length (L.filter (\(PgTag m1s :. _ :. r) ->-    (r.grp > 100 || r.grp `L.elem` [0..70])-    && L.any ((<100) . (.sort_key)) (L.take 2 $ L.sortBy (comparing (.pos)) m1s)-    )-    inIns) === L.length res+  L.length (L.filter rootMatches inIns) === L.length res+  where+    rootMatches (PgTag m1s :. _ :. r) =+      (r.grp > 100 || r.grp `L.elem` [0..70])+      && L.any ((<100) . (.sortKey))+        (L.take 2 $ L.sortBy (comparing (.pos)) m1s) -type OutData = "mid2_root_fk" := [Mid2I] :. InsData+-- | 'qPath' / 'qWhere' on 'mid1_root_fk' vs 'mid1_root_fk2' must not be merged+-- just because both edges share one fk in the database.+prop_renamer_alias_dual_fields :: Pool Connection -> Property+prop_renamer_alias_dual_fields pool = withTests 30 $ property do+  inIns <- insData pool+  (sel :: [RootDualMid1], _) <- evalIO $ withResource pool \conn ->+    selSch "root" conn $ qRoot do+      qPath "mid1RootFk" do+        qWhere $ "flag" =? True+      qPath "mid1_root_fk2" do+        qWhere $ "pos" >? (5 :: Int32)+  forM_ sel \root -> do+    let+      expectFk = [ m1+        | PgTag m1s :. _ :. r <- inIns+        , (r.code, r.grp) == (root.code, root.grp)+        , m1 <- m1s+        , m1.flag+        ]+      expectFk2 = [ m1+        | PgTag m1s :. _ :. r <- inIns+        , (r.code, r.grp) == (root.code, root.grp)+        , m1 <- m1s+        , m1.pos > 5+        ]+    L.sort root.mid1RootFk === L.sort expectFk+    L.sort root.mid1_root_fk2 === L.sort expectFk2 --- We can have similar pathes in select.--- Params are applied for all branches with this path+-- | 'qPath' by shared db fk name applies one 'qWhere' to every matching branch.+prop_renamer_broadcast_dual_fields :: Pool Connection -> Property+prop_renamer_broadcast_dual_fields pool = withTests 30 $ property do+  inIns <- insData pool+  (sel :: [RootDualMid1], _) <- evalIO $ withResource pool \conn ->+    selSch "root" conn $ qRoot do+      qPath "mid1_root_fk" do+        qWhere $ "flag" =? True+  forM_ sel \root -> do+    let+      expectFlag = [ m1+        | PgTag m1s :. _ :. r <- inIns+        , (r.code, r.grp) == (root.code, root.grp)+        , m1 <- m1s+        , m1.flag+        ]+    L.sort root.mid1RootFk === L.sort expectFlag+    L.sort root.mid1_root_fk2 === L.sort expectFlag++-- | Duplicate 'mid2_root_fk' in the result type: filters on the path+-- and on nested 'leaf_mid2_fk' apply per branch and may diverge. prop_cond_by_dup_path :: Pool Connection -> Property prop_cond_by_dup_path pool = withTests 30 $ property do   inIns <- insData pool-  (sel :: [OutData], _) <- evalIO $ withResource pool \conn ->+  (sel :: ["mid2_root_fk" := [Mid2I] :. InsData], _) <- evalIO $ withResource pool \conn ->     selSch "root" conn $ qRoot-      $ qPath "mid2_root_fk" do+      $ qPath "mid2_root_fk" do -- there are two "mid2_root_fk" branches         qWhere $ "flag" =? True-        qPath "leaf_mid2_fk" do-          qWhere $ "leaf_no" >? (100::Int32)+        qPath "leaf_mid2_fk" do -- only one "leaf_mid2_fk" branch+          qWhere $ "leaf_no" >? (97::Int32)   L.sort [m2 | (PgTag m2s :. _) <- sel, m2 <- m2s]     === L.sort [m2 | (_ :. PgTag m2s :. _) <- inIns, (_ :. m2) <- m2s, m2.flag]   L.sort [(m2, L.length ls) | (_ :. _ :. PgTag m2s :. _) <- sel, (PgTag ls :. m2) <- m2s]-    === L.sort [(m2, L.length $ L.filter ((>100) . (.leaf_no)) ls)+    === L.sort [(m2, L.length $ L.filter ((>97) . (.leafNo)) ls)       | (_ :. PgTag m2s :. _) <- inIns, (PgTag ls :. m2) <- m2s, m2.flag]

@@ -11,7 +11,7 @@ import Data.Functor import Data.Int (Int32, Int64) import Data.List qualified as L-import Data.Maybe (fromMaybe, isJust)+import Data.Maybe (fromMaybe, isJust, mapMaybe, catMaybes) import Data.Pool as Pool import Data.Proxy (Proxy(..)) import Data.Text (Text)@@ -120,25 +120,26 @@       insJSON "root" conn inIns     (fst -> (outSel1' :: ["id" := Int32 :. "mid1RootFk" := [Mid1Rec] :. RootRec])) <-       selSch "root" conn qpEmpty-    (outUps' :: ["id" := Int32 :. "mid1_root_fk" := [Mid1Rec] :. RootRec], _txt) <-+    (outUps' :: [Maybe ("id" := Int32 :. "mid1_root_fk" := [Mid1Rec] :. RootRec)], _txt) <-       upsJSON "root" conn $ outIns' <&> \(ir :. PgTag ms) -> "mid1_root_fk" =:         (ms <&> \(i :. flag :. x) -> i :. (not <$> flag) :. x) :. ir-    -- T.putStrLn $ "\n\n" <> txt <> "\n\n"     (fst -> (outSel2' :: ["id" := Int32 :. "mid1_root_fk" := [Mid1Rec] :. RootRec])) <-       selSch "root" conn qpEmpty     pure (outIns', outSel1', outUps', outSel2')+  assert $ all isJust outUps && not (null outUps)+  let outUpsBare = catMaybes outUps   L.sort (inIns <&> \(ms :. _) -> L.length ms) ===     L.sort (outIns <&> \(_ :. ms) -> L.length ms)   L.length outIns === L.length outSel1   L.length outIns === L.length outSel2-  L.length outIns === L.length outUps+  L.length outIns === L.length outUpsBare   (L.sort outIns <&> \(ir :. ms) -> ir :. length ms)     === (L.sort outSel2 <&> \(ir :. ms :. _) -> ir :. length ms)   (L.sort outIns <&> \(ir :. ms) -> ir :. length ms)-    === (L.sort outUps <&> \(ir :. ms :. _) -> ir :. length ms)+    === (L.sort outUpsBare <&> \(ir :. ms :. _) -> ir :. length ms)   (L.sort outIns <&> \(ir :. PgTag ms) -> ir :. length (filter (\(_ :. PgTag b :. _) -> b) ms))     === (L.sort outSel2 <&> \(ir :. PgTag ms :. _) -> ir :. length (filter (\(PgTag b :. _) -> not b) ms))-  (L.sort outUps <&> \(ir :. PgTag ms :. _) -> ir :. length (filter (\(PgTag b :. _) -> b) ms))+  (L.sort outUpsBare <&> \(ir :. PgTag ms :. _) -> ir :. length (filter (\(PgTag b :. _) -> b) ms))     === (L.sort outSel2 <&> \(ir :. PgTag ms :. _) -> ir :. length (filter (\(PgTag b :. _) -> b) ms))  prop_hier_insert_composite_fk :: Pool Connection -> Property@@ -153,25 +154,26 @@       insJSON "root" conn inIns     (fst -> (outSel1' :: ["id" := Int32 :. "mid2_root_fk" := [Mid2Rec] :. RootRec])) <-       selSch "root" conn qpEmpty-    (outUps' :: ["id" := Int32 :. "mid2_root_fk" := [Mid2Rec] :. RootRec], _txt) <-+    (outUps' :: [Maybe ("id" := Int32 :. "mid2_root_fk" := [Mid2Rec] :. RootRec)], _txt) <-       upsJSON "root" conn $ outIns' <&> \(ir :. PgTag ms) -> "mid2_root_fk" =:         (ms <&> \m -> m { flag = not m.flag }) :. ir-    -- T.putStrLn $ "\n\n" <> txt <> "\n\n"     (fst -> (outSel2' :: ["id" := Int32 :. "mid2_root_fk" := [Mid2Rec] :. RootRec])) <-       selSch "root" conn qpEmpty     pure (outIns', outSel1', outUps', outSel2')+  assert $ all isJust outUps && not (null outUps)+  let outUpsBare = catMaybes outUps   L.sort (inIns <&> \(ms :. _) -> L.length ms) ===     L.sort (outIns <&> \(_ :. ms) -> L.length ms)   L.length outIns === L.length outSel1   L.length outIns === L.length outSel2-  L.length outIns === L.length outUps+  L.length outIns === L.length outUpsBare   (L.sort outIns <&> \(ir :. ms) -> ir :. length ms)     === (L.sort outSel2 <&> \(ir :. ms :. _) -> ir :. length ms)   (L.sort outIns <&> \(ir :. ms) -> ir :. length ms)-    === (L.sort outUps <&> \(ir :. ms :. _) -> ir :. length ms)+    === (L.sort outUpsBare <&> \(ir :. ms :. _) -> ir :. length ms)   (L.sort outIns <&> \(ir :. PgTag ms) -> ir :. length (filter (.flag) ms))     === (L.sort outSel2 <&> \(ir :. PgTag ms :. _) -> ir :. length (filter (not . (.flag)) ms))-  (L.sort outUps <&> \(ir :. PgTag ms :. _) -> ir :. length (filter (.flag) ms))+  (L.sort outUpsBare <&> \(ir :. PgTag ms :. _) -> ir :. length (filter (.flag) ms))     === (L.sort outSel2 <&> \(ir :. PgTag ms :. _) -> ir :. length (filter (.flag) ms))  prop_hier_select_child_with_parent :: Pool Connection -> Property

@@ -0,0 +1,308 @@+{-# LANGUAGE BlockArguments #-}+-- |+-- Flat keyed DML: 'upsertByKey' needs mandatory fields and a full key+-- ('INSERT … ON CONFLICT'); key-only patches use 'updateByKey' only.+module Tests.KeyedDML where++import Control.Monad (void, when, unless)+import Data.Int (Int32)+import Data.List qualified as L+import Data.Maybe (Maybe(..))+import Data.Pool as Pool+import Data.Text (Text)+import Data.Text qualified as T+import Database.PostgreSQL.Simple (Connection)+import Hedgehog+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import PgSchema.DML+import Sch+import Utils++type RootRec =+  "code" := Text :. "grp" := Int32 :. "name" := Text :. "someEmpty" := ()++type RootRetBare = "id" := Int32 :. RootRec++type RootKeyPatch =+  "code" := Text :. "grp" := Int32 :. "name" := Text :. "someEmpty" := ()++type RootKeyRet = "id" := Int32 :. "name" := Text++type RootSel = "code" := Text :. "grp" := Int32 :. "name" := Text++type NullableRow =+  "code" := Text :. "suffix" := Maybe Text :. "name" := Text+    :. "note" := Maybe Text :. "someEmpty" := ()++type NullableKeyPatch =+  "code" := Text :. "suffix" := Maybe Text :. "note" := Maybe Text+    :. "someEmpty" := ()++type NullableKeyRet = "id" := Int32 :. "note" := Maybe Text++type RootPatchOnly =+  "id" := Int32 :. "code" := Text :. "grp" := Int32 :. "name" := Text+    :. "someEmpty" := ()++type RootKeyOnlyPatch = "id" := Int32 :. "name" := Text++type RootUpsOutMaybe = Maybe ("id" := Int32 :. "name" := Text)++type RootUpdOutMaybe = RootUpsOutMaybe++type RootUpsBare = "id" := Int32 :. RootRec++type Mid1Rec =+  "flag" := Bool :. "pos" := Int32 :. "sortKey" := Int32 :. "payload" := Maybe Text++type RootWithMid1 = "mid1_root_fk" := [Mid1Rec] :. RootRec++type RootInsWithMid =+  "id" := Int32 :. "mid1_root_fk" := ["id" := Int32 :. Mid1Rec]++type Mid1KeyPatch = "id" := Int32 :. Mid1Rec++type Mid1KeyRet = "id" := Int32 :. "flag" := Bool++expectAbsent :: Show a => [Maybe a] -> IO ()+expectAbsent [Nothing] = pure ()+expectAbsent xs = fail $ "expected [Nothing], got " <> show xs++expectUpsertSql :: Text -> IO ()+expectUpsertSql sql = do+  let lower = T.toLower sql+  unless ("insert into" `T.isInfixOf` lower) $+    fail $ "expected INSERT upsert SQL, got: " <> T.unpack sql+  unless ("on conflict" `T.isInfixOf` lower) $+    fail $ "expected ON CONFLICT in upsert SQL, got: " <> T.unpack sql+  when (T.stripPrefix "update " (T.stripStart lower) == Just "") $+    fail $ "upsertByKey must not emit UPDATE-only SQL: " <> T.unpack sql++prop_upsert_by_key_insert_then_update :: Pool Connection -> Property+prop_upsert_by_key_insert_then_update pool = withTests 10 $ property do+  code <- forAll (Gen.text (Range.linear 3 20) Gen.alphaNum)+  grp <- forAll (Gen.int32 (Range.linear 1 10000))+  name1 <- forAll (Gen.text (Range.linear 1 20) Gen.alphaNum)+  name2 <- forAll (Gen.text (Range.linear 1 20) Gen.alphaNum)+  when (name1 == name2) discard+  evalIO $ Pool.withResource pool \conn -> do+    void $ delByCond "root" conn ("code" =? code)+    let+      full :: RootRec+      full = "code" =: code :. "grp" =: grp :. "name" =: name1 :. "someEmpty" =: ()+      row2 :: RootRec+      row2 = "code" =: code :. "grp" =: grp :. "name" =: name2 :. "someEmpty" =: ()+    ([_ :. _], sql1) <- upsertByKey (AnnSch "root") @RootRec @RootRetBare conn [full]+    expectUpsertSql sql1+    (ret, sql2) <- upsertByKey (AnnSch "root") @RootRec @RootKeyRet conn [row2]+    expectUpsertSql sql2+    case ret of+      [_ :. n] -> when (unPgTag n /= name2) $+        fail $ "expected name " <> show name2+      _ -> fail "expected one row from upsertByKey on conflict update"+    (rows :: [RootSel], _) <- selSch "root" conn $+      qRoot $ qWhere $ "code" =? code &&& "grp" =? grp+    case rows of+      [_ :. _ :. n] -> when (unPgTag n /= name2) $ fail "DB name not updated"+      _ -> fail "expected one row"++prop_upsert_by_key_composite_unique :: Pool Connection -> Property+prop_upsert_by_key_composite_unique pool = withTests 5 $ property do+  code <- forAll (Gen.text (Range.linear 3 24) Gen.alphaNum)+  name1 <- forAll (Gen.text (Range.linear 1 24) Gen.alphaNum)+  name2 <- forAll (Gen.text (Range.linear 1 24) Gen.alphaNum)+  when (name1 == name2) discard+  let grp = 5151 :: Int32+  evalIO $ Pool.withResource pool \conn -> do+    void $ delByCond "root" conn ("code" =? code)+    let+      row1 :: RootRec+      row1 = "code" =: code :. "grp" =: grp :. "name" =: name1 :. "someEmpty" =: ()+      row2 :: RootRec+      row2 = "code" =: code :. "grp" =: grp :. "name" =: name2 :. "someEmpty" =: ()+    (_, sql1) <- upsByKey_ "root" conn [row1]+    expectUpsertSql sql1+    (_, sql2) <- upsByKey_ "root" conn [row2]+    expectUpsertSql sql2+    (rows :: [RootSel], _) <- selSch "root" conn $+      qRoot $ qWhere $ "code" =? code &&& "grp" =? grp+    case rows of+      [_ :. _ :. n] ->+        when (unPgTag n /= name2) $+          fail $ "expected updated name " <> show name2+      _ -> fail $ "expected 1 row, got " <> show (L.length rows)++prop_upsert_by_key_never_pure_update :: Pool Connection -> Property+prop_upsert_by_key_never_pure_update pool = withTests 3 $ property do+  code <- forAll (Gen.text (Range.linear 3 20) Gen.alphaNum)+  grp <- forAll (Gen.int32 (Range.linear 1 10000))+  name <- forAll (Gen.text (Range.linear 1 20) Gen.alphaNum)+  evalIO $ Pool.withResource pool \conn -> do+    void $ delByCond "root" conn ("code" =? code)+    let+      row :: RootRec+      row = "code" =: code :. "grp" =: grp :. "name" =: name :. "someEmpty" =: ()+    (_, sqlExec) <- upsByKey_ "root" conn [row]+    expectUpsertSql sqlExec+    let sqlText = upsertByKeyText_ (AnnSch "root") @RootRec+    expectUpsertSql sqlText++prop_update_by_key_found :: Pool Connection -> Property+prop_update_by_key_found pool = withTests 10 $ property do+  code <- forAll (Gen.text (Range.linear 3 20) Gen.alphaNum)+  note1 <- forAll (Gen.text (Range.linear 1 20) Gen.alphaNum)+  note2 <- forAll (Gen.text (Range.linear 1 20) Gen.alphaNum)+  when (note1 == note2) discard+  let sfx = Just ("sfx" :: Text)+  evalIO $ Pool.withResource pool \conn -> do+    void $ delByCond "nullable_uq_row" conn ("code" =? code)+    let+      seed :: NullableRow+      seed =+        "code" =: code :. "suffix" =: sfx :. "name" =: "n"+          :. "note" =: Just note1 :. "someEmpty" =: ()+      patch :: NullableKeyPatch+      patch =+        "code" =: code :. "suffix" =: sfx :. "note" =: Just note2+          :. "someEmpty" =: ()+    void $ insSch_ "nullable_uq_row" conn [seed]+    (ret, _) <- updateByKey (AnnSch "nullable_uq_row") @NullableKeyPatch+      @NullableKeyRet conn [patch]+    case ret of+      [Just (_ :. n)] -> when (unPgTag n /= Just note2) $ fail "note not updated"+      _ -> fail "expected [Just]"+    (rows :: ["note" := Maybe Text], _) <- selSch "nullable_uq_row" conn $+      qRoot $ qWhere $ "code" =? code &&& "suffix" =?? sfx+    case rows of+      [n] -> when (unPgTag n /= Just note2) $ fail "DB note mismatch"+      _ -> fail "expected one row"++prop_update_by_key_not_found :: Pool Connection -> Property+prop_update_by_key_not_found pool = withTests 5 $ property do+  code <- forAll (Gen.text (Range.linear 3 20) Gen.alphaNum)+  evalIO $ Pool.withResource pool \conn -> do+    void $ delByCond "nullable_uq_row" conn ("code" =? code)+    let+      patch :: NullableKeyPatch+      patch =+        "code" =: code :. "suffix" =: Just "x" :. "note" =: Just "y"+          :. "someEmpty" =: ()+    (ret, _) <- updateByKey (AnnSch "nullable_uq_row") @NullableKeyPatch+      @NullableKeyRet conn [patch]+    expectAbsent ret+    (rows :: [NullableRow], _) <- selSch "nullable_uq_row" conn $+      qRoot $ qWhere $ "code" =? code+    unless (null rows) $ fail $ "expected 0 rows, got " <> show rows++prop_update_by_key_never_inserts :: Pool Connection -> Property+prop_update_by_key_never_inserts pool = withTests 3 $ property do+  code <- forAll (Gen.text (Range.linear 3 20) Gen.alphaNum)+  evalIO $ Pool.withResource pool \conn -> do+    void $ delByCond "root" conn mempty+    let+      patch :: RootKeyPatch+      patch =+        "code" =: code :. "grp" =: (1 :: Int32) :. "name" =: "x"+          :. "someEmpty" =: ()+    (ret, _) <- updateByKey (AnnSch "root") @RootKeyPatch @RootKeyRet conn [patch]+    expectAbsent ret+    (rows :: [RootSel], _) <- selSch "root" conn qpEmpty+    unless (null rows) $ fail $ "expected 0 rows, got " <> show rows++prop_update_json_not_found_returns_nothing :: Pool Connection -> Property+prop_update_json_not_found_returns_nothing pool = withTests 5 $ property do+  evalIO $ Pool.withResource pool \conn -> do+    void $ delByCond "root" conn mempty+    let+      bad :: RootPatchOnly+      bad =+        "id" =: (999999999 :: Int32) :. "code" =: "x" :. "grp" =: 1+          :. "name" =: "y" :. "someEmpty" =: ()+    (rets, _) <- updateJSON (AnnSch "root") @RootPatchOnly @RootUpdOutMaybe conn [bad]+    expectAbsent rets++prop_update_json_found :: Pool Connection -> Property+prop_update_json_found pool = withTests 10 $ property do+  code <- forAll (Gen.text (Range.linear 3 16) Gen.alphaNum)+  grp <- forAll (Gen.int32 (Range.linear 1 5000))+  evalIO $ Pool.withResource pool \conn -> do+    void $ delByCond "root" conn mempty+    let+      row :: RootRec+      row = "code" =: code :. "grp" =: grp :. "name" =: "seed" :. "someEmpty" =: ()+    (insOut, _) <- insertJSON (AnnSch "root") @RootRec @RootRetBare conn [row]+    insHead <- case insOut of+      (x : _) -> pure x+      [] -> fail "insertJSON returned no rows"+    let+      (PgTag rid :. _) = insHead+      patch :: RootPatchOnly+      patch =+        "id" =: rid :. "code" =: code :. "grp" =: grp :. "name" =: "patched"+          :. "someEmpty" =: ()+    (ret, _) <- updateJSON (AnnSch "root") @RootPatchOnly @RootUpdOutMaybe conn [patch]+    case ret of+      [Just (_ :. PgTag n)] -> when (n /= "patched") $ fail "name not updated"+      _ -> fail $ "unexpected updateJSON result: " <> show ret++prop_upsert_json_returning_positions :: Pool Connection -> Property+prop_upsert_json_returning_positions pool = withTests 5 $ property do+  code <- forAll (Gen.text (Range.linear 3 16) Gen.alphaNum)+  grp <- forAll (Gen.int32 (Range.linear 1 5000))+  evalIO $ Pool.withResource pool \conn -> do+    void $ delByCond "root" conn mempty+    let+      row :: RootRec+      row = "code" =: code :. "grp" =: grp :. "name" =: "n" :. "someEmpty" =: ()+    (insOut, _) <- insertJSON (AnnSch "root") @RootRec @RootRetBare conn [row]+    insHead <- case insOut of+      (x : _) -> pure x+      [] -> fail "insertJSON returned no rows"+    let+      (PgTag rid :. _) = insHead+      good :: RootKeyOnlyPatch+      good = "id" =: rid :. "name" =: "ok"+      bad :: RootKeyOnlyPatch+      bad = "id" =: (888888888 :: Int32) :. "name" =: "z"+    (rets, _) <- upsertJSON (AnnSch "root") @RootKeyOnlyPatch @RootUpsOutMaybe conn [good, bad]+    when (length rets /= 2) $ fail $ "expected 2 results, got " <> show rets+    case rets of+      [Just _, Nothing] -> pure ()+      _ -> fail $ "expected [Just, Nothing], got " <> show rets++prop_upsert_json_full_row_bare_returning :: Pool Connection -> Property+prop_upsert_json_full_row_bare_returning pool = withTests 5 $ property do+  code <- forAll (Gen.text (Range.linear 3 16) Gen.alphaNum)+  grp <- forAll (Gen.int32 (Range.linear 1 5000))+  evalIO $ Pool.withResource pool \conn -> do+    void $ delByCond "root" conn mempty+    let+      row :: RootRec+      row = "code" =: code :. "grp" =: grp :. "name" =: "n" :. "someEmpty" =: ()+    (rets, _) <- upsertJSON (AnnSch "root") @RootRec @RootUpsBare conn [row]+    case rets of+      [PgTag _ :. _] -> pure ()+      _ -> fail "expected bare upsert returning row"++-- | Root @Just@, key-only upsert patch on child table via flat @updateByKey@.+prop_update_json_child_maybe :: Pool Connection -> Property+prop_update_json_child_maybe pool = withTests 5 $ property do+  code <- forAll (Gen.text (Range.linear 3 16) Gen.alphaNum)+  grp <- forAll (Gen.int32 (Range.linear 1 5000))+  evalIO $ Pool.withResource pool \conn -> do+    void $ delByCond "mid1" conn mempty+    void $ delByCond "root" conn mempty+    let+      row :: RootRec+      row = "code" =: code :. "grp" =: grp :. "name" =: "n" :. "someEmpty" =: ()+    ([_ :. PgTag mids], _) <- insertJSON (AnnSch "root") @RootWithMid1 @RootInsWithMid conn+      [ "mid1_root_fk" =: [ "flag" =: True :. "pos" =: 1 :. "sortKey" =: 1+          :. "payload" =: Nothing ] :. row ]+    let+      midId = case mids of [PgTag i :. _] -> i; _ -> error "one mid1"+      patch :: Mid1KeyPatch+      patch = "id" =: (midId + 99999) :. "flag" =: False :. "pos" =: 1+        :. "sortKey" =: 1 :. "payload" =: Nothing+    (ret, _) <- updateByKey (AnnSch "mid1") @Mid1KeyPatch @Mid1KeyRet conn [patch]+    expectAbsent ret

@@ -102,6 +102,36 @@   => Connection -> [r] -> IO ([r'], Text) upsJSON tn = upsertJSON (AnnSch tn) +updJSON_+  :: forall tn -> forall r. UpdateTreeNonReturning (AnnSch tn) r+  => Connection -> [r] -> IO Text+updJSON_ tn = updateJSON_ (AnnSch tn)++updJSON+  :: forall tn -> forall r r'. UpdateTreeReturning (AnnSch tn) r r'+  => Connection -> [r] -> IO ([r'], Text)+updJSON tn = updateJSON (AnnSch tn)++upsByKey+  :: forall tn -> forall r r'. UpsertByKeyReturning (AnnSch tn) r r'+  => Connection -> [r] -> IO ([r'], Text)+upsByKey tn = upsertByKey (AnnSch tn)++upsByKey_+  :: forall tn -> forall r. UpsertByKeyNonReturning (AnnSch tn) r+  => Connection -> [r] -> IO (Int64, Text)+upsByKey_ tn = upsertByKey_ (AnnSch tn)++updByKey+  :: forall tn -> forall r r'. UpdateByKeyReturning (AnnSch tn) r r'+  => Connection -> [r] -> IO ([Maybe r'], Text)+updByKey tn = updateByKey (AnnSch tn)++updByKey_+  :: forall tn -> forall r. UpdateByKeyNonReturning (AnnSch tn) r+  => Connection -> [r] -> IO (Int64, Text)+updByKey_ tn = updateByKey_ (AnnSch tn)+ genDay :: Gen Day genDay = ModifiedJulianDay . fromIntegral <$> Gen.int (Range.linear 50000 80000)