266c320 · rowtype-yoga/purescript-yoga-postgres

git.iko.soy/rowtype-yoga/purescript-yoga-postgres

Add builder INSERT, UPDATE, ON CONFLICT with type-safe execution

commit266c320f7f338dac7615a4ad0c76fcd2e76d0c92 authorMark <mark.eibes@gmail.com> dateFri 13 Feb 2026, 16:01 (8 months ago) parente9ae8f1

2 files changed+353−16

compare with main

unifiedsplit

src/Yoga/Postgres/Schema.purs+220−15 test/Schema.purs+133−1

src/Yoga/Postgres/Schema.purs+220−15

@@ -2,8 +2,10 @@ module Yoga.Postgres.Schema where

33import Prelude

5+import Data.Array as Array

56import Data.Array (intercalate, mapWithIndex, foldl)

67import Data.Maybe (Maybe(..))

8+import Data.Nullable (toNullable)

79import Unsafe.Coerce (unsafeCoerce)

810import Data.Reflectable (class Reflectable, reflectType)

911import Data.String.Regex (regex, replace') as Regex

@@ -16,12 +18,14 @@ import Data.Symbol (class IsSymbol, reflectSymbol)

1618import Data.Tuple.Nested (type (/\))

1719import Effect.Aff (Aff)

1820import Foreign (Foreign, unsafeToForeign)

21+import Prim.Boolean (True, False)

1922import Prim.Row (class Cons, class Lacks) as Row

2023import Prim.RowList as RL

2124import Prim.RowList (class RowToList)

2225import Prim.Symbol (class Cons, class Append) as Symbol

2326import Prim.TypeError (class Fail, Beside, Text, Quote)

2427import Record (get) as Record

28+import Type.Data.Boolean (class Or)

2529import Type.Proxy (Proxy(..))

2630import Type.RowList (class ListToRow)

2731import Yoga.JSON (class ReadForeign, readImpl)

@@ -887,10 +891,10 @@ else instance

887891-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

888892

889893newtype Q :: Symbol -> Row Type -> Row Type -> Row Type -> Type

890−newtype Q name cols result params = Q String

894+newtype Q name cols result params = Q { sql :: String, values :: Array PG.PGValue }

891895

892896from :: forall name cols. Proxy (Table name cols) -> Q name cols () ()

893−from _ = Q ""

897+from _ = Q { sql: "", values: [] }

894898

895899selectAll

896900 :: forall name cols result r p

@@ -898,7 +902,7 @@ selectAll

898902 => StripColumns cols result

899903 => Q name cols r p

900904 -> Q name cols result p

901−selectAll _ = Q ("SELECT * FROM " <> reflectSymbol (Proxy :: Proxy name))

905+selectAll _ = Q { sql: "SELECT * FROM " <> reflectSymbol (Proxy :: Proxy name), values: [] }

902906

903907select

904908 :: forall @sel name cols result r p

@@ -907,7 +911,7 @@ select

907911 => ParseSelect sel cols result

908912 => Q name cols r p

909913 -> Q name cols result p

910−select _ = Q ("SELECT " <> reflectSymbol (Proxy :: Proxy sel) <> " FROM " <> reflectSymbol (Proxy :: Proxy name))

914+select _ = Q { sql: "SELECT " <> reflectSymbol (Proxy :: Proxy sel) <> " FROM " <> reflectSymbol (Proxy :: Proxy name), values: [] }

911915

912916where_

913917 :: forall @whr name cols result params p

@@ -915,10 +919,195 @@ where_

915919 => ParseWhere whr cols params

916920 => Q name cols result p

917921 -> Q name cols result params

918−where_ (Q base) = Q (base <> " WHERE " <> reflectSymbol (Proxy :: Proxy whr))

922+where_ (Q q) = Q (q { sql = q.sql <> " WHERE " <> reflectSymbol (Proxy :: Proxy whr) })

919923

920924toSQL :: forall name cols result params. Q name cols result params -> String

921−toSQL (Q s) = s

925+toSQL (Q q) = q.sql

926+

927+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

928+-- Type-level IsAutoGenerated (Boolean kind)

929+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

930+

931+class IsAutoGeneratedTC :: Type -> Boolean -> Constraint

932+class IsAutoGeneratedTC constraints result | constraints -> result

933+

934+instance IsAutoGeneratedTC AutoIncrement True

935+else instance IsAutoGeneratedTC (Default a) True

936+else instance IsAutoGeneratedTC (DefaultInt a) True

937+else instance IsAutoGeneratedTC (DefaultBool a) True

938+else instance (IsAutoGeneratedTC a ra, IsAutoGeneratedTC b rb, Or ra rb result) => IsAutoGeneratedTC (a /\ b) result

939+else instance IsAutoGeneratedTC a False

940+

941+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

942+-- InsertableColumnsRL: filter out auto-generated columns

943+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

944+

945+class InsertableColumnsRL :: RL.RowList Type -> RL.RowList Type -> Constraint

946+class InsertableColumnsRL tableRL outRL | tableRL -> outRL

947+

948+instance InsertableColumnsRL RL.Nil RL.Nil

949+instance

950+ ( IsAutoGeneratedTC constraints isAuto

951+ , InsertableColumnDecide isAuto name typ tail outRL

952+ ) =>

953+ InsertableColumnsRL (RL.Cons name (Column typ constraints) tail) outRL

954+

955+class InsertableColumnDecide :: Boolean -> Symbol -> Type -> RL.RowList Type -> RL.RowList Type -> Constraint

956+class InsertableColumnDecide isAuto name typ tail outRL | isAuto name typ tail -> outRL

957+

958+instance InsertableColumnsRL tail outRL => InsertableColumnDecide True name typ tail outRL

959+instance InsertableColumnsRL tail outRL => InsertableColumnDecide False name typ tail (RL.Cons name typ outRL)

960+

961+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

962+-- RecordValuesRL: extract record values in RowList order

963+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

964+

965+class FieldToPGValue :: Type -> Constraint

966+class FieldToPGValue a where

967+ fieldToPGValue :: a -> PG.PGValue

968+

969+instance FieldToPGValue a => FieldToPGValue (Maybe a) where

970+ fieldToPGValue = toNullable >>> unsafeCoerce

971+else instance FieldToPGValue a where

972+ fieldToPGValue = unsafeCoerce

973+

974+class RecordValuesRL :: RL.RowList Type -> Row Type -> Constraint

975+class RecordValuesRL rl row where

976+ recordValuesRL :: Proxy rl -> { | row } -> Array PG.PGValue

977+

978+instance RecordValuesRL RL.Nil row where

979+ recordValuesRL _ _ = []

980+

981+instance

982+ ( IsSymbol name

983+ , Row.Cons name typ rest row

984+ , FieldToPGValue typ

985+ , RecordValuesRL tail row

986+ ) =>

987+ RecordValuesRL (RL.Cons name typ tail) row where

988+ recordValuesRL _ rec =

989+ [ fieldToPGValue (Record.get (Proxy :: Proxy name) rec) ]

990+ <> recordValuesRL (Proxy :: Proxy tail) rec

991+

992+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

993+-- INSERT builder

994+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

995+

996+insert

997+ :: forall name cols colsRL insertableRL insertRow

998+ . RowToList cols colsRL

999+ => InsertableColumnsRL colsRL insertableRL

1000+ => ListToRow insertableRL insertRow

1001+ => IsSymbol name

1002+ => InsertColumnsRL colsRL

1003+ => RecordValuesRL insertableRL insertRow

1004+ => { | insertRow }

1005+ -> Q name cols () ()

1006+ -> Q name cols () ()

1007+insert rec _ = Q { sql, values }

1008+ where

1009+ tableName = reflectSymbol (Proxy :: Proxy name)

1010+ colNames = insertColumnsRL (Proxy :: Proxy colsRL)

1011+ placeholders = colNames # mapWithIndex \i _ -> "$" <> show (i + 1)

1012+ sql = "INSERT INTO " <> tableName

1013+ <> " ("

1014+ <> intercalate ", " colNames

1015+ <> ")"

1016+ <> " VALUES ("

1017+ <> intercalate ", " placeholders

1018+ <> ")"

1019+ values = recordValuesRL (Proxy :: Proxy insertableRL) rec

1020+

1021+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

1022+-- RETURNING clause

1023+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

1024+

1025+returning

1026+ :: forall @sel name cols result p

1027+ . IsSymbol sel

1028+ => ParseSelect sel cols result

1029+ => Q name cols () p

1030+ -> Q name cols result p

1031+returning (Q q) = Q (q { sql = q.sql <> " RETURNING " <> reflectSymbol (Proxy :: Proxy sel) })

1032+

1033+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

1034+-- UPDATE builder (SET)

1035+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

1036+

1037+class ValidateSetColumnsRL :: RL.RowList Type -> Row Type -> Constraint

1038+class ValidateSetColumnsRL rl cols

1039+

1040+instance ValidateSetColumnsRL RL.Nil cols

1041+instance

1042+ ( Row.Cons name (Column typ constraints) rest cols

1043+ , ValidateSetColumnsRL tail cols

1044+ ) =>

1045+ ValidateSetColumnsRL (RL.Cons name typ tail) cols

1046+

1047+class SetClauseRL :: RL.RowList Type -> Constraint

1048+class SetClauseRL rl where

1049+ setClauseRL :: Proxy rl -> Int -> Array String

1050+

1051+instance SetClauseRL RL.Nil where

1052+ setClauseRL _ _ = []

1053+

1054+instance (IsSymbol name, SetClauseRL tail) => SetClauseRL (RL.Cons name typ tail) where

1055+ setClauseRL _ idx =

1056+ [ reflectSymbol (Proxy :: Proxy name) <> " = $" <> show idx ]

1057+ <> setClauseRL (Proxy :: Proxy tail) (idx + 1)

1058+

1059+set

1060+ :: forall name cols setRow setRL

1061+ . RowToList setRow setRL

1062+ => IsSymbol name

1063+ => ValidateSetColumnsRL setRL cols

1064+ => SetClauseRL setRL

1065+ => RecordValuesRL setRL setRow

1066+ => { | setRow }

1067+ -> Q name cols () ()

1068+ -> Q name cols () ()

1069+set rec _ = Q { sql, values }

1070+ where

1071+ tableName = reflectSymbol (Proxy :: Proxy name)

1072+ setClauses = setClauseRL (Proxy :: Proxy setRL) 1

1073+ sql = "UPDATE " <> tableName <> " SET " <> intercalate ", " setClauses

1074+ values = recordValuesRL (Proxy :: Proxy setRL) rec

1075+

1076+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

1077+-- ON CONFLICT

1078+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

1079+

1080+onConflict

1081+ :: forall @target @action name cols result params

1082+ . IsSymbol target

1083+ => IsSymbol action

1084+ => ValidateColumns target cols

1085+ => Q name cols result params

1086+ -> Q name cols result params

1087+onConflict (Q q) = Q

1088+ ( q

1089+ { sql = q.sql

1090+ <> " ON CONFLICT ("

1091+ <> reflectSymbol (Proxy :: Proxy target)

1092+ <> ") "

1093+ <> reflectSymbol (Proxy :: Proxy action)

1094+ }

1095+ )

1096+

1097+onConflictDoNothing

1098+ :: forall @target name cols result params

1099+ . IsSymbol target

1100+ => ValidateColumns target cols

1101+ => Q name cols result params

1102+ -> Q name cols result params

1103+onConflictDoNothing (Q q) = Q

1104+ ( q

1105+ { sql = q.sql

1106+ <> " ON CONFLICT ("

1107+ <> reflectSymbol (Proxy :: Proxy target)

1108+ <> ") DO NOTHING"

1109+ }

1110+ )

9221111

9231112-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

9241113-- Query execution

@@ -950,9 +1139,9 @@ namedParamRegex = case Regex.regex "\\$[a-zA-Z_][a-zA-Z0-9_]*" Regex.global of

9501139 Right r -> r

9511140 Left _ -> unsafeCoerce unit

9521141

953−replaceNamedParams :: Array { name :: String, value :: Foreign } -> String -> { sql :: String, values :: Array PG.PGValue }

954−replaceNamedParams entries sql = do

955− let indexed = entries # mapWithIndex \i e -> { idx: i + 1, name: e.name, value: e.value }

1142+replaceNamedParams :: Int -> Array { name :: String, value :: Foreign } -> String -> { sql :: String, values :: Array PG.PGValue }

1143+replaceNamedParams offset entries sql = do

1144+ let indexed = entries # mapWithIndex \i e -> { idx: offset + i + 1, name: e.name, value: e.value }

9561145 let replacements = indexed # foldl (\m e -> Map.insert ("$" <> e.name) ("$" <> show e.idx) m) Map.empty

9571146 let

9581147 sql' = Regex.replace' namedParamRegex

@@ -972,10 +1161,11 @@ runQuery

9721161 -> { | params }

9731162 -> Q name cols result params

9741163 -> Aff (Array { | result })

975−runQuery conn params (Q sql) = do

1164+runQuery conn params (Q q) = do

9761165 let entries = paramsToArray (Proxy :: Proxy paramsRL) params

977− let { sql: sql', values } = replaceNamedParams entries sql

978− result <- PG.query (PG.SQL sql') values conn

1166+ let { sql, values } = replaceNamedParams (Array.length q.values) entries q.sql

1167+ let allValues = q.values <> values

1168+ result <- PG.query (PG.SQL sql) allValues conn

9791169 pure (unsafeDecodeRows result.rows)

9801170

9811171runQueryOne

@@ -987,12 +1177,27 @@ runQueryOne

9871177 -> { | params }

9881178 -> Q name cols result params

9891179 -> Aff (Maybe { | result })

990−runQueryOne conn params (Q sql) = do

1180+runQueryOne conn params (Q q) = do

9911181 let entries = paramsToArray (Proxy :: Proxy paramsRL) params

992− let { sql: sql', values } = replaceNamedParams entries sql

993− result <- PG.queryOne (PG.SQL sql') values conn

1182+ let { sql, values } = replaceNamedParams (Array.length q.values) entries q.sql

1183+ let allValues = q.values <> values

1184+ result <- PG.queryOne (PG.SQL sql) allValues conn

9941185 pure (result <#> unsafeDecodeRow)

9951186

1187+runExecute

1188+ :: forall name cols params paramsRL

1189+ . RowToList params paramsRL

1190+ => ParamsToArray paramsRL params

1191+ => PG.Connection

1192+ -> { | params }

1193+ -> Q name cols () params

1194+ -> Aff Int

1195+runExecute conn params (Q q) = do

1196+ let entries = paramsToArray (Proxy :: Proxy paramsRL) params

1197+ let { sql, values } = replaceNamedParams (Array.length q.values) entries q.sql

1198+ let allValues = q.values <> values

1199+ PG.execute (PG.SQL sql) allValues conn

1200+

9961201unsafeDecodeRows :: forall a. ReadForeign a => Array Foreign -> Array a

9971202unsafeDecodeRows = map unsafeDecodeRow

9981203

test/Schema.purs+133−1

@@ -149,7 +149,57 @@ builderWhereComplex :: String

149149builderWhereComplex = typedWhereComplex # toSQL

150150

151151-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

152−-- Phase 9: Query execution (type annotations prove correctness)

152+-- Phase 9: Builder INSERT / UPDATE / ON CONFLICT

153+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

154+

155+typedInsert

156+ :: Q "users" _ () ()

157+typedInsert = from usersTable # insert { name: "Alice", email: "alice@example.com", age: Nothing :: Maybe Int }

158+

159+typedInsertReturning

160+ :: Q "users" _ (id :: Int, name :: String) ()

161+typedInsertReturning = from usersTable

162+ # insert { name: "Alice", email: "alice@example.com", age: Nothing :: Maybe Int }

163+ # returning @"id, name"

164+

165+typedSet

166+ :: Q "users" _ () ()

167+typedSet = from usersTable # set { name: "Bob" }

168+

169+typedSetWhere

170+ :: Q "users" _ () (id :: Int)

171+typedSetWhere = from usersTable # set { name: "Bob" } # where_ @"id = $id"

172+

173+typedSetReturning

174+ :: Q "users" _ (id :: Int, name :: String, email :: String) (id :: Int)

175+typedSetReturning = from usersTable

176+ # set { name: "Bob" }

177+ # where_ @"id = $id"

178+ # returning @"id, name, email"

179+

180+typedUpsert

181+ :: Q "users" _ () ()

182+typedUpsert = from usersTable

183+ # insert { name: "Alice", email: "alice@example.com", age: Nothing :: Maybe Int }

184+ # onConflictDoNothing @"email"

185+

186+builderInsert :: String

187+builderInsert = typedInsert # toSQL

188+

189+builderInsertReturning :: String

190+builderInsertReturning = typedInsertReturning # toSQL

191+

192+builderSet :: String

193+builderSet = typedSet # toSQL

194+

195+builderSetWhere :: String

196+builderSetWhere = typedSetWhere # toSQL

197+

198+builderUpsert :: String

199+builderUpsert = typedUpsert # toSQL

200+

201+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

202+-- Phase 10: Query execution (type annotations prove correctness)

153203-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

154204

155205queryAllUsers :: PG.Connection -> Aff (Array { id :: Int, name :: String, email :: String, age :: Maybe Int })

@@ -228,6 +278,25 @@ spec = do

228278 it "builds complex WHERE" do

229279 builderWhereComplex `shouldEqual` "SELECT * FROM users WHERE name = $name AND age > $age"

230280

281+ describe "Builder INSERT" do

282+ it "builds INSERT" do

283+ builderInsert `shouldSatisfy` contains (Pattern "INSERT INTO users")

284+ builderInsert `shouldSatisfy` contains (Pattern "(age, email, name)")

285+ builderInsert `shouldSatisfy` contains (Pattern "VALUES ($1, $2, $3)")

286+ it "builds INSERT with RETURNING" do

287+ builderInsertReturning `shouldSatisfy` contains (Pattern "INSERT INTO users")

288+ builderInsertReturning `shouldSatisfy` contains (Pattern "RETURNING id, name")

289+

290+ describe "Builder UPDATE" do

291+ it "builds UPDATE SET" do

292+ builderSet `shouldEqual` "UPDATE users SET name = $1"

293+ it "builds UPDATE SET with WHERE" do

294+ builderSetWhere `shouldEqual` "UPDATE users SET name = $1 WHERE id = $id"

295+

296+ describe "Builder ON CONFLICT" do

297+ it "builds INSERT ON CONFLICT DO NOTHING" do

298+ builderUpsert `shouldSatisfy` contains (Pattern "ON CONFLICT (email) DO NOTHING")

299+

231300integrationSpec :: PG.Connection -> Spec Unit

232301integrationSpec conn = do

233302 describe "Builder query execution" do

@@ -276,3 +345,66 @@ integrationSpec conn = do

276345 # runQuery conn { name: "Bob", age: 20 }

277346 Array.length rows `shouldEqual` 1

278347 (map _.age rows) `shouldEqual` [ Just 30 ]

348+

349+ describe "Builder insert execution" do

350+ it "inserts a row and returns count" do

351+ count <- from usersTable

352+ # insert { name: "Charlie", email: "charlie@example.com", age: Just 28 }

353+ # runExecute conn {}

354+ count `shouldEqual` 1

355+ rows <- from usersTable

356+ # select @"name"

357+ # where_ @"name = $name"

358+ # runQuery conn { name: "Charlie" }

359+ Array.length rows `shouldEqual` 1

360+

361+ it "inserts with RETURNING" do

362+ rows <- from usersTable

363+ # insert { name: "Diana", email: "diana@example.com", age: Nothing }

364+ # returning @"id, name, email"

365+ # runQuery conn {}

366+ Array.length rows `shouldEqual` 1

367+ (map _.name rows) `shouldEqual` [ "Diana" ]

368+ (map _.email rows) `shouldEqual` [ "diana@example.com" ]

369+

370+ describe "Builder update execution" do

371+ it "updates a row" do

372+ count <- from usersTable

373+ # set { email: "alice-updated@example.com" }

374+ # where_ @"name = $name"

375+ # runExecute conn { name: "Alice" }

376+ count `shouldEqual` 1

377+ result <- from usersTable

378+ # select @"email"

379+ # where_ @"name = $name"

380+ # runQueryOne conn { name: "Alice" }

381+ case result of

382+ Just r -> r.email `shouldEqual` "alice-updated@example.com"

383+ Nothing -> shouldEqual "found" "nothing"

384+

385+ it "updates with RETURNING" do

386+ rows <- from usersTable

387+ # set { age: Just 99 }

388+ # where_ @"name = $name"

389+ # returning @"name, age"

390+ # runQuery conn { name: "Bob" }

391+ Array.length rows `shouldEqual` 1

392+ (map _.age rows) `shouldEqual` [ Just 99 ]

393+

394+ describe "Builder upsert execution" do

395+ it "ON CONFLICT DO NOTHING skips duplicate" do

396+ count <- from usersTable

397+ # insert { name: "Duplicate", email: "bob@example.com", age: Nothing }

398+ # onConflictDoNothing @"email"

399+ # runExecute conn {}

400+ count `shouldEqual` 0

401+

402+ it "ON CONFLICT DO UPDATE" do

403+ rows <- from usersTable

404+ # insert { name: "Updated", email: "bob@example.com", age: Just 40 }

405+ # onConflict @"email" @"DO UPDATE SET name = EXCLUDED.name, age = EXCLUDED.age"

406+ # returning @"name, age"

407+ # runQuery conn {}

408+ Array.length rows `shouldEqual` 1

409+ (map _.name rows) `shouldEqual` [ "Updated" ]

410+ (map _.age rows) `shouldEqual` [ Just 40 ]