@@ -2,39 +2,47 @@ module Yoga.Postgres.Schema where
22
33import Prelude
44
5−import Data.Array as Array
5+import Control.Monad.Except (except, runExcept)
66import Data.Array (intercalate, mapWithIndex, foldl)
7−import Data.Date (Date)
8−import Data.DateTime (DateTime(..), date, time)
7+import Data.Array as Array
8+import Data.Date (Date, day, month, year)
9+import Data.DateTime (DateTime(..))
10+import Data.Either (Either(..), note)
11+import Data.Enum (fromEnum, toEnum)
12+import Data.Int as Int
913import Data.JSDate as JSDate
10−import Data.Maybe (Maybe(..), maybe)
11−import Data.Time (Time)
14+import Data.List.Types (NonEmptyList)
15+import Data.Map as Map
16+import Data.Maybe (Maybe(..), fromMaybe)
1217import Data.Newtype (class Newtype)
1318import Data.Nullable (toNullable)
14−import Data.UUID (UUID)
15−import JS.BigInt (BigInt)
16−import Unsafe.Coerce (unsafeCoerce)
19+import Data.Number as Number
1720import Data.Reflectable (class Reflectable, reflectType)
18−import Data.String.Regex (regex, replace') as Regex
19−import Data.String.Regex (Regex) as Regex
21+import Data.String.CodeUnits as SCU
22+import Data.String.Common as Str
23+import Data.String.Pattern (Pattern(..))
24+import Data.String.Regex (Regex, regex, replace') as Regex
2025import Data.String.Regex.Flags (global) as Regex
21−import Control.Monad.Except (except, runExcept)
22−import Data.Either (Either(..), note)
23−import Data.Map as Map
2426import Data.Symbol (class IsSymbol, reflectSymbol)
25−import Type.Function (type (#))
26−import Effect.Aff (Aff)
27−import Foreign (Foreign, ForeignError(..), unsafeToForeign)
27+import Data.Time (Time(..))
28+import Data.Traversable (traverse)
29+import Data.UUID (UUID)
30+import Data.UUID as UUID
31+import Effect.Aff (Aff, throwError)
32+import Effect.Exception (error) as Exception
33+import Foreign (Foreign, ForeignError(..))
34+import JS.BigInt (BigInt)
2835import Prim.Boolean (True, False)
2936import Prim.Row (class Cons, class Lacks, class Union, class Nub) as Row
30−import Prim.RowList as RL
3137import Prim.RowList (class RowToList)
38+import Prim.RowList as RL
3239import Prim.Symbol (class Cons, class Append) as Symbol
3340import Prim.TypeError (class Fail, Beside, Text, Quote)
3441import Record (get) as Record
3542import Type.Proxy (Proxy(..))
3643import Type.RowList (class ListToRow)
37−import Yoga.JSON (class ReadForeign, readImpl)
44+import Unsafe.Coerce (unsafeCoerce)
45+import Yoga.JSON (class ReadForeign, class WriteForeign, readImpl, writeImpl)
3846import Yoga.Postgres as PG
3947
4048-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -60,15 +68,15 @@ data Unique a
6068
6169data Default :: forall k. k -> Type -> Type
6270data Default val a
71+data DefaultExpr :: Symbol -> Type -> Type
72+data DefaultExpr expression a
73+
6374
6475data References
6576
6677data ForeignKey :: Symbol -> Type -> Symbol -> Type -> Type
6778data ForeignKey table references col a
6879
69−data DefaultExpr :: Symbol -> Type -> Type
70−data DefaultExpr expr a
71−
7280-- Internal: used by LEFT JOIN to mark columns as nullable
7381data Nullable :: Type -> Type
7482data Nullable a
@@ -84,6 +92,9 @@ derive instance Newtype Jsonb _
8492instance ReadForeign Jsonb where
8593 readImpl = pure <<< Jsonb
8694
95+instance WriteForeign Jsonb where
96+ writeImpl (Jsonb value) = value
97+
8798-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
8899-- PGUUID: newtype over Data.UUID.UUID for Postgres integration
89100-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -100,6 +111,9 @@ instance ReadForeign PGUUID where
100111 s :: String <- readImpl f
101112 pure (unsafeCoerce s)
102113
114+instance WriteForeign PGUUID where
115+ writeImpl (PGUUID uuid) = writeImpl (UUID.toString uuid)
116+
103117-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
104118-- PGDate / PGTime: newtypes for DATE and TIME columns
105119-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -113,11 +127,38 @@ instance Show PGDate where
113127 show (PGDate d) = "(PGDate " <> show d <> ")"
114128
115129instance ReadForeign PGDate where
116− readImpl = readImpl >=>
117− JSDate.toDate
118− >>> note (pure (ForeignError "Invalid date"))
119− >>> except
120− >>> map PGDate
130+ readImpl f =
131+ except $ note (pure (ForeignError "Invalid date")) (JSDate.toDate jsDate <#> PGDate)
132+ where
133+ jsDate :: JSDate.JSDate
134+ jsDate = unsafeCoerce f
135+
136+instance WriteForeign PGDate where
137+ writeImpl (PGDate date) =
138+ writeImpl
139+ ( show (fromEnum (year date))
140+ <> "-"
141+ <> pad2 (fromEnum (month date))
142+ <> "-"
143+ <> pad2 (fromEnum (day date))
144+ )
145+ where
146+ pad2 n = if n < 10 then "0" <> show n else show n
147+
148+newtype TimestampTZ = TimestampTZ DateTime
149+
150+derive instance Newtype TimestampTZ _
151+derive instance Eq TimestampTZ
152+derive instance Ord TimestampTZ
153+instance Show TimestampTZ where
154+ show (TimestampTZ dt) = "(TimestampTZ " <> show dt <> ")"
155+
156+instance ReadForeign TimestampTZ where
157+ readImpl f =
158+ except $ note (pure (ForeignError "Invalid timestamp")) (JSDate.toDateTime jsDate <#> TimestampTZ)
159+ where
160+ jsDate :: JSDate.JSDate
161+ jsDate = unsafeCoerce f
121162
122163newtype PGTime = PGTime Time
123164
@@ -129,8 +170,44 @@ instance Show PGTime where
129170
130171instance ReadForeign PGTime where
131172 readImpl f = do
132− dt :: DateTime <- readImpl f
133− pure (PGTime (time dt))
173+ s :: String <- readImpl f
174+ except $ note (pure (ForeignError ("Invalid time: " <> s))) (parseTime s)
175+ where
176+ parseTime str = do
177+ let parts = Str.split (Pattern ":") str
178+ case parts of
179+ [ hStr, mStr, sStr ] -> do
180+ h <- Int.fromString hStr >>= toEnum
181+ mi <- Int.fromString mStr >>= toEnum
182+ let secParts = Str.split (Pattern ".") sStr
183+ s <- Int.fromString (fromMaybe sStr (Array.head secParts)) >>= toEnum
184+ let fraction = fromMaybe "" (Array.index secParts 1)
185+ let milliseconds = case SCU.length fraction of
186+ 0 -> "0"
187+ 1 -> fraction <> "00"
188+ 2 -> fraction <> "0"
189+ _ -> SCU.take 3 fraction
190+ let ms = fromMaybe bottom (Int.fromString milliseconds >>= toEnum)
191+ pure (PGTime (Time h mi s ms))
192+ _ -> Nothing
193+
194+instance WriteForeign PGTime where
195+ writeImpl (PGTime (Time hour minute second millisecond)) =
196+ writeImpl
197+ ( pad2 (fromEnum hour)
198+ <> ":"
199+ <> pad2 (fromEnum minute)
200+ <> ":"
201+ <> pad2 (fromEnum second)
202+ <> "."
203+ <> pad3 (fromEnum millisecond)
204+ )
205+ where
206+ pad2 n = if n < 10 then "0" <> show n else show n
207+ pad3 n
208+ | n < 10 = "00" <> show n
209+ | n < 100 = "0" <> show n
210+ | otherwise = show n
134211
135212-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
136213-- Point: geometric point "(x,y)"
@@ -146,8 +223,18 @@ instance Show Point where
146223
147224instance ReadForeign Point where
148225 readImpl f = do
149− { x, y } :: { x :: Number, y :: Number } <- readImpl f
150− pure (Point { x, y })
226+ s :: String <- readImpl f
227+ except $ note (pure (ForeignError ("Invalid point: " <> s))) (parsePoint s)
228+ where
229+ parsePoint str = do
230+ let inner = SCU.drop 1 (SCU.dropRight 1 str)
231+ let parts = Str.split (Pattern ",") inner
232+ case parts of
233+ [ xStr, yStr ] -> do
234+ x <- Number.fromString xStr
235+ y <- Number.fromString yStr
236+ pure (Point { x, y })
237+ _ -> Nothing
151238
152239-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
153240-- TSVector / TSQuery: full-text search types
@@ -200,7 +287,7 @@ instance ExtractType a typ => ExtractType (PrimaryKey a) typ
200287else instance ExtractType a typ => ExtractType (AutoIncrement a) typ
201288else instance ExtractType a typ => ExtractType (Unique a) typ
202289else instance ExtractType a typ => ExtractType (Default val a) typ
203−else instance ExtractType a typ => ExtractType (DefaultExpr expr a) typ
290+else instance ExtractType a typ => ExtractType (DefaultExpr expression a) typ
204291else instance ExtractType a typ => ExtractType (ForeignKey t r c a) typ
205292else instance ExtractType a typ => ExtractType (Nullable a) (Maybe typ)
206293else instance ExtractType a a
@@ -233,6 +320,9 @@ instance PGTypeName BigInt where
233320instance PGTypeName PGUUID where
234321 pgTypeName _ = "UUID"
235322
323+instance PGTypeName TimestampTZ where
324+ pgTypeName _ = "TIMESTAMPTZ"
325+
236326instance PGTypeName PGDate where
237327 pgTypeName _ = "DATE"
238328
@@ -270,8 +360,24 @@ instance Reflectable sym String => RenderDefaultValue sym String where
270360instance Reflectable val Int => RenderDefaultValue val Int where
271361 renderDefaultValue _ _ = "DEFAULT " <> show (reflectType (Proxy :: Proxy val))
272362
273−instance Reflectable val Boolean => RenderDefaultValue val Boolean where
274− renderDefaultValue _ _ = if reflectType (Proxy :: Proxy val) then "DEFAULT true" else "DEFAULT false"
363+instance RenderDefaultValue True Boolean where
364+ renderDefaultValue _ _ = "DEFAULT true"
365+
366+instance RenderDefaultValue False Boolean where
367+ renderDefaultValue _ _ = "DEFAULT false"
368+
369+instance RenderDefaultValue "true" Boolean where
370+ renderDefaultValue _ _ = "DEFAULT true"
371+
372+instance RenderDefaultValue "false" Boolean where
373+ renderDefaultValue _ _ = "DEFAULT false"
374+
375+instance RenderDefaultValue "now()" TimestampTZ where
376+ renderDefaultValue _ _ = "DEFAULT now()"
377+
378+instance RenderDefaultValue "gen_random_uuid()" PGUUID where
379+ renderDefaultValue _ _ = "DEFAULT gen_random_uuid()"
380+
275381
276382class RenderConstraint a where
277383 renderConstraint :: Proxy a -> String
@@ -288,11 +394,10 @@ else instance RenderConstraint a => RenderConstraint (Unique a) where
288394else instance (RenderDefaultValue val a, RenderConstraint a) => RenderConstraint (Default val a) where
289395 renderConstraint _ = joinConstraints (renderDefaultValue (Proxy :: Proxy val) (Proxy :: Proxy a)) (renderConstraint (Proxy :: Proxy a))
290396
291−else instance (IsSymbol expr, RenderConstraint a) => RenderConstraint (DefaultExpr expr a) where
397+else instance (IsSymbol expression, RenderConstraint a) => RenderConstraint (DefaultExpr expression a) where
292398 renderConstraint _ = joinConstraints
293− ("DEFAULT " <> reflectSymbol (Proxy :: Proxy expr))
399+ ("DEFAULT " <> reflectSymbol (Proxy :: Proxy expression))
294400 (renderConstraint (Proxy :: Proxy a))
295−
296401else instance (IsSymbol table, IsSymbol col, RenderConstraint a) => RenderConstraint (ForeignKey table References col a) where
297402 renderConstraint _ = joinConstraints
298403 ("REFERENCES " <> reflectSymbol (Proxy :: Proxy table) <> "(" <> reflectSymbol (Proxy :: Proxy col) <> ")")
@@ -353,6 +458,11 @@ instance
353458 let columns = renderColumnsRL (Proxy :: Proxy rl)
354459 "CREATE TABLE " <> tableName <> " (" <> intercalate ", " columns <> ")"
355460
461+createTableDDLIfNotExists :: forall @a. CreateTableDDL a => String
462+createTableDDLIfNotExists = do
463+ let ddl = createTableDDL @a
464+ "CREATE TABLE IF NOT EXISTS" <> SCU.drop 12 ddl
465+
356466-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
357467-- INSERT SQL generation
358468-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -364,7 +474,7 @@ instance IsAutoGenerated (AutoIncrement a) where
364474 isAutoGenerated _ = true
365475else instance IsAutoGenerated (Default v a) where
366476 isAutoGenerated _ = true
367−else instance IsAutoGenerated (DefaultExpr expr a) where
477+else instance IsAutoGenerated (DefaultExpr expression a) where
368478 isAutoGenerated _ = true
369479else instance IsAutoGenerated a => IsAutoGenerated (PrimaryKey a) where
370480 isAutoGenerated _ = isAutoGenerated (Proxy :: Proxy a)
@@ -409,15 +519,18 @@ instance
409519 insertSQLFor = do
410520 let tableName = reflectSymbol (Proxy :: Proxy name)
411521 let cols = insertColumnsRL (Proxy :: Proxy rl)
412− let placeholders = cols # mapWithIndex \i _ -> "$" <> show (i + 1)
413− "INSERT INTO " <> tableName
414− <> " ("
415− <> intercalate ", " cols
416− <> ")"
417− <> " VALUES ("
418− <> intercalate ", " placeholders
419− <> ")"
420− <> " RETURNING *"
522+ if Array.null cols then
523+ "INSERT INTO " <> tableName <> " DEFAULT VALUES RETURNING *"
524+ else do
525+ let placeholders = cols # mapWithIndex \i _ -> "$" <> show (i + 1)
526+ "INSERT INTO " <> tableName
527+ <> " ("
528+ <> intercalate ", " cols
529+ <> ")"
530+ <> " VALUES ("
531+ <> intercalate ", " placeholders
532+ <> ")"
533+ <> " RETURNING *"
421534
422535-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
423536-- SELECT SQL generation
@@ -872,6 +985,15 @@ else instance
872985 ) =>
873986 ParseSelectHandleAS "as" afterKeyword colRef tables accRL outRL
874987
988+-- Bare alias (no AS keyword): "name n" means "name AS n"
989+else instance
990+ ( ResolveColumn colRef tables entry
991+ , ExtractType entry typ
992+ , SkipSpaces afterKeyword rest
993+ , ParseSelectExpectEnd rest tables (RL.Cons keyword typ accRL) outRL
994+ ) =>
995+ ParseSelectHandleAS keyword afterKeyword colRef tables accRL outRL
996+
875997class ParseSelectExpectEnd :: Symbol -> Row (Row Type) -> RL.RowList Type -> RL.RowList Type -> Constraint
876998class ParseSelectExpectEnd sym tables accRL outRL | sym tables accRL -> outRL
877999
@@ -970,11 +1092,66 @@ instance ResolveAggregateArg "*" tables Star
9701092else instance ResolveAggregateArg "" tables Star
9711093else instance
9721094 ( SkipSpaces args trimmedFront
973− , ExtractWord trimmedFront col _rest
974− , ResolveAggregateArgCol col tables argType
1095+ , ExtractIdent trimmedFront col rest
1096+ , ResolveAggregateArgDispatch col rest tables argType
9751097 ) =>
9761098 ResolveAggregateArg args tables argType
9771099
1100+-- ExtractIdent: like ExtractWord but also stops at "(" so we can detect nested function calls
1101+class ExtractIdent :: Symbol -> Symbol -> Symbol -> Constraint
1102+class ExtractIdent sym word rest | sym -> word rest
1103+
1104+instance ExtractIdent "" "" ""
1105+else instance
1106+ ( Symbol.Cons h t sym
1107+ , ExtractIdentGo h t "" word rest
1108+ ) =>
1109+ ExtractIdent sym word rest
1110+
1111+class ExtractIdentGo :: Symbol -> Symbol -> Symbol -> Symbol -> Symbol -> Constraint
1112+class ExtractIdentGo head tail acc word rest | head tail acc -> word rest
1113+
1114+instance (SkipSpaces tail rest) => ExtractIdentGo " " tail acc acc rest
1115+else instance Symbol.Cons "," tail rest => ExtractIdentGo "," tail acc acc rest
1116+else instance Symbol.Append "(" tail rest => ExtractIdentGo "(" tail acc acc rest
1117+else instance Symbol.Append acc h word => ExtractIdentGo h "" acc word ""
1118+else instance
1119+ ( Symbol.Append acc h acc'
1120+ , Symbol.Cons nextH nextT tail
1121+ , ExtractIdentGo nextH nextT acc' word rest
1122+ ) =>
1123+ ExtractIdentGo h tail acc word rest
1124+
1125+-- After extracting the identifier, check if followed by "(" (nested function call) or not (column ref)
1126+class ResolveAggregateArgDispatch :: Symbol -> Symbol -> Row (Row Type) -> Type -> Constraint
1127+class ResolveAggregateArgDispatch col rest tables argType | col rest tables -> argType
1128+
1129+instance
1130+ ResolveAggregateArgCol col tables argType =>
1131+ ResolveAggregateArgDispatch col "" tables argType
1132+
1133+else instance
1134+ ( Symbol.Cons h t rest
1135+ , ResolveAggregateArgDispatchByHead h t col tables argType
1136+ ) =>
1137+ ResolveAggregateArgDispatch col rest tables argType
1138+
1139+class ResolveAggregateArgDispatchByHead :: Symbol -> Symbol -> Symbol -> Row (Row Type) -> Type -> Constraint
1140+class ResolveAggregateArgDispatchByHead head tail col tables argType | head tail col tables -> argType
1141+
1142+-- Nested function call: col(...)
1143+instance
1144+ ( ExtractUntilParen tail innerArgs _afterParen
1145+ , ResolveAggregateArg innerArgs tables innerArgType
1146+ , AggregateReturnType col innerArgType argType
1147+ ) =>
1148+ ResolveAggregateArgDispatchByHead "(" tail col tables argType
1149+
1150+-- Not a function call: column reference
1151+else instance
1152+ ResolveAggregateArgCol col tables argType =>
1153+ ResolveAggregateArgDispatchByHead h t col tables argType
1154+
9781155class ResolveAggregateArgCol :: Symbol -> Row (Row Type) -> Type -> Constraint
9791156class ResolveAggregateArgCol col tables argType | col tables -> argType
9801157
@@ -1059,8 +1236,8 @@ else instance
10591236class AggregateReturnTypeC :: Symbol -> Type -> Type -> Constraint
10601237class AggregateReturnTypeC funcName argType returnType | funcName argType -> returnType
10611238
1062−instance AggregateReturnTypeC "COUNT" argType Int
1063−else instance AggregateReturnTypeC "count" argType Int
1239+instance AggregateReturnTypeC "COUNT" argType BigInt
1240+else instance AggregateReturnTypeC "count" argType BigInt
10641241else instance AggregateReturnTypeC "COALESCE" argType argType
10651242else instance AggregateReturnTypeC "coalesce" argType argType
10661243else instance
@@ -2480,13 +2657,85 @@ else instance
24802657 , SkipSpaces rest1 rest2
24812658 , ExpectChar rest2 "=" rest3
24822659 , SkipSpaces rest3 rest4
2483− , ExtractWord rest4 excRef rest5
2484− , ValidateExcludedRef excRef colName
2485− , SkipSpaces rest5 rest6
2486− , ParseAssignmentsContinue rest6 cols
2660+ , SkipExpression rest4 rest5
2661+ , ParseAssignmentsContinue rest5 cols
24872662 ) =>
24882663 ParseAssignments sym cols
24892664
2665+-- | Skip a SQL expression on the RHS of an assignment.
2666+-- | Handles balanced parentheses so that e.g. now() and
2667+-- | COALESCE(EXCLUDED.value, '') are consumed as a single expression.
2668+-- | Stops at an unparenthesised comma or end-of-string.
2669+class SkipExpression :: Symbol -> Symbol -> Constraint
2670+class SkipExpression sym rest | sym -> rest
2671+
2672+instance SkipExpression "" ""
2673+else instance
2674+ ( Symbol.Cons h t sym
2675+ , SkipExpressionGo h t rest
2676+ ) =>
2677+ SkipExpression sym rest
2678+
2679+class SkipExpressionGo :: Symbol -> Symbol -> Symbol -> Constraint
2680+class SkipExpressionGo head tail rest | head tail -> rest
2681+
2682+-- Comma at depth 0 → stop, keep comma in rest
2683+instance Symbol.Cons "," tail rest => SkipExpressionGo "," tail rest
2684+-- Open paren → enter nested expression
2685+else instance
2686+ ( SkipNested tail rest1
2687+ , SkipExpression rest1 rest
2688+ ) =>
2689+ SkipExpressionGo "(" tail rest
2690+-- Space → skip and continue (expressions can have spaces, e.g. "EXCLUDED.col")
2691+else instance (SkipSpaces tail rest1, SkipExpressionAfterSpace rest1 rest) => SkipExpressionGo " " tail rest
2692+-- End of string after this char
2693+else instance SkipExpressionGo h "" ""
2694+-- Regular char → continue
2695+else instance (Symbol.Cons h2 t2 tail, SkipExpressionGo h2 t2 rest) => SkipExpressionGo h tail rest
2696+
2697+-- | After a space in an expression, check if we've hit a comma or a new assignment (word = ...).
2698+-- | If the next word is a column name followed by '=', this is a new assignment, so stop.
2699+-- | Otherwise, continue the expression.
2700+class SkipExpressionAfterSpace :: Symbol -> Symbol -> Constraint
2701+class SkipExpressionAfterSpace sym rest | sym -> rest
2702+
2703+instance SkipExpressionAfterSpace "" ""
2704+else instance
2705+ ( Symbol.Cons h t sym
2706+ , SkipExpressionAfterSpaceGo h t sym rest
2707+ ) =>
2708+ SkipExpressionAfterSpace sym rest
2709+
2710+class SkipExpressionAfterSpaceGo :: Symbol -> Symbol -> Symbol -> Symbol -> Constraint
2711+class SkipExpressionAfterSpaceGo head tail sym rest | head tail sym -> rest
2712+
2713+-- Comma → stop
2714+instance Symbol.Cons "," tail rest => SkipExpressionAfterSpaceGo "," tail sym rest
2715+-- Otherwise continue the expression
2716+else instance (SkipExpressionGo h tail rest) => SkipExpressionAfterSpaceGo h tail sym rest
2717+
2718+-- | Skip a parenthesised group (after the opening paren has been consumed).
2719+-- | Handles nesting.
2720+class SkipNested :: Symbol -> Symbol -> Constraint
2721+class SkipNested sym rest | sym -> rest
2722+
2723+instance
2724+ ( Symbol.Cons h t sym
2725+ , SkipNestedGo h t rest
2726+ ) =>
2727+ SkipNested sym rest
2728+
2729+class SkipNestedGo :: Symbol -> Symbol -> Symbol -> Constraint
2730+class SkipNestedGo head tail rest | head tail -> rest
2731+
2732+-- Close paren → done
2733+instance SkipNestedGo ")" tail tail
2734+-- Open paren → recurse
2735+else instance (SkipNested tail rest1, SkipNested rest1 rest) => SkipNestedGo "(" tail rest
2736+-- Any other char → continue
2737+else instance (SkipNested tail rest) => SkipNestedGo h tail rest
2738+
24902739class ParseAssignmentsContinue :: Symbol -> Row Type -> Constraint
24912740class ParseAssignmentsContinue sym cols
24922741
@@ -2549,7 +2798,7 @@ class IsAutoGeneratedTC constraints result | constraints -> result
25492798
25502799instance IsAutoGeneratedTC (AutoIncrement a) True
25512800else instance IsAutoGeneratedTC (Default s a) True
2552−else instance IsAutoGeneratedTC (DefaultExpr expr a) True
2801+else instance IsAutoGeneratedTC (DefaultExpr expression a) True
25532802else instance IsAutoGeneratedTC a result => IsAutoGeneratedTC (PrimaryKey a) result
25542803else instance IsAutoGeneratedTC a result => IsAutoGeneratedTC (Unique a) result
25552804else instance IsAutoGeneratedTC a result => IsAutoGeneratedTC (ForeignKey t r c a) result
@@ -2605,13 +2854,19 @@ class FieldToPGValue a where
26052854 fieldToPGValue :: a -> PG.PGValue
26062855
26072856instance FieldToPGValue a => FieldToPGValue (Maybe a) where
2608− fieldToPGValue = toNullable >>> unsafeCoerce
2857+ fieldToPGValue = case _ of
2858+ Nothing -> unsafeCoerce (toNullable Nothing)
2859+ Just value -> fieldToPGValue value
26092860else instance FieldToPGValue DateTime where
26102861 fieldToPGValue = JSDate.fromDateTime >>> unsafeCoerce
2862+else instance FieldToPGValue TimestampTZ where
2863+ fieldToPGValue (TimestampTZ dt) = JSDate.fromDateTime dt # unsafeCoerce
26112864else instance FieldToPGValue PGDate where
2612− fieldToPGValue (PGDate d) = JSDate.fromDateTime (DateTime d bottom) # unsafeCoerce
2613−else instance FieldToPGValue a where
2865+ fieldToPGValue = writeImpl >>> unsafeCoerce
2866+else instance FieldToPGValue PGUUID where
26142867 fieldToPGValue = unsafeCoerce
2868+else instance WriteForeign a => FieldToPGValue a where
2869+ fieldToPGValue = writeImpl >>> unsafeCoerce
26152870
26162871class RecordValuesRL :: RL.RowList Type -> Row Type -> Constraint
26172872class RecordValuesRL rl row where
@@ -2679,6 +2934,20 @@ else instance HasAnyDMLRL (RL.Cons "delete" Unit rest)
26792934else instance HasAnyDMLRL rest => HasAnyDMLRL (RL.Cons label typ rest)
26802935else instance Fail (Text "WHERE requires a preceding SELECT, UPDATE (set), or DELETE") => HasAnyDMLRL RL.Nil
26812936
2937+class HasMutation :: Row Type -> Constraint
2938+class HasMutation stage
2939+
2940+instance (RL.RowToList stage rl, HasMutationRL rl) => HasMutation stage
2941+
2942+class HasMutationRL :: RL.RowList Type -> Constraint
2943+class HasMutationRL rl
2944+
2945+instance HasMutationRL (RL.Cons "insert" Unit rest)
2946+else instance HasMutationRL (RL.Cons "set" Unit rest)
2947+else instance HasMutationRL (RL.Cons "delete" Unit rest)
2948+else instance HasMutationRL rest => HasMutationRL (RL.Cons label typ rest)
2949+else instance Fail (Text "RETURNING requires a preceding INSERT, UPDATE (set), or DELETE") => HasMutationRL RL.Nil
2950+
26822951toSQL :: forall tables result params stage. Q tables result params stage -> String
26832952toSQL (Q q) = q.sql
26842953
@@ -2688,6 +2957,12 @@ from _ = Q { sql: reflectSymbol (Proxy :: Proxy name), values: [] }
26882957fromAs :: forall @alias name cols tables. IsSymbol name => IsSymbol alias => Row.Cons alias cols () tables => Proxy (Table name cols) -> Q tables () () ()
26892958fromAs _ = Q { sql: reflectSymbol (Proxy :: Proxy name) <> " " <> reflectSymbol (Proxy :: Proxy alias), values: [] }
26902959
2960+into :: forall name cols tables. IsSymbol name => Row.Cons name cols () tables => Proxy (Table name cols) -> Q tables () () (into :: Unit)
2961+into _ = Q { sql: reflectSymbol (Proxy :: Proxy name), values: [] }
2962+
2963+update :: forall name cols tables. IsSymbol name => Row.Cons name cols () tables => Proxy (Table name cols) -> Q tables () () (update :: Unit)
2964+update _ = Q { sql: reflectSymbol (Proxy :: Proxy name), values: [] }
2965+
26912966selectAll
26922967 :: forall tables name cols result r p stage stage'
26932968 . SingleTable tables name cols
@@ -2695,6 +2970,7 @@ selectAll
26952970 => StripColumns cols result
26962971 => Row.Lacks "select" stage
26972972 => Row.Lacks "insert" stage
2973+ => Row.Lacks "into" stage
26982974 => Row.Lacks "set" stage
26992975 => Row.Lacks "delete" stage
27002976 => Row.Lacks "where" stage
@@ -2712,6 +2988,7 @@ select
27122988 => ParseSelect sel tables result
27132989 => Row.Lacks "select" stage
27142990 => Row.Lacks "insert" stage
2991+ => Row.Lacks "into" stage
27152992 => Row.Lacks "set" stage
27162993 => Row.Lacks "delete" stage
27172994 => Row.Lacks "where" stage
@@ -2729,6 +3006,7 @@ selectDistinct
27293006 => ParseSelect sel tables result
27303007 => Row.Lacks "select" stage
27313008 => Row.Lacks "insert" stage
3009+ => Row.Lacks "into" stage
27323010 => Row.Lacks "set" stage
27333011 => Row.Lacks "delete" stage
27343012 => Row.Lacks "where" stage
@@ -2749,6 +3027,7 @@ selectDistinctOn
27493027 => ParseSelect sel tables result
27503028 => Row.Lacks "select" stage
27513029 => Row.Lacks "insert" stage
3030+ => Row.Lacks "into" stage
27523031 => Row.Lacks "set" stage
27533032 => Row.Lacks "delete" stage
27543033 => Row.Lacks "where" stage
@@ -2953,13 +3232,17 @@ insert rec _ = Q { sql, values }
29533232 tableName = reflectSymbol (Proxy :: Proxy name)
29543233 colNames = columnNamesRL (Proxy :: Proxy userRowRL)
29553234 placeholders = colNames # mapWithIndex \i _ -> "$" <> show (i + 1)
2956− sql = "INSERT INTO " <> tableName
2957− <> " ("
2958− <> intercalate ", " colNames
2959− <> ")"
2960− <> " VALUES ("
2961− <> intercalate ", " placeholders
2962− <> ")"
3235+ sql =
3236+ if Array.null colNames then
3237+ "INSERT INTO " <> tableName <> " DEFAULT VALUES"
3238+ else
3239+ "INSERT INTO " <> tableName
3240+ <> " ("
3241+ <> intercalate ", " colNames
3242+ <> ")"
3243+ <> " VALUES ("
3244+ <> intercalate ", " placeholders
3245+ <> ")"
29633246 values = recordValuesRL (Proxy :: Proxy userRowRL) rec
29643247
29653248-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -2971,6 +3254,7 @@ returning
29713254 . SingleTable tables name cols
29723255 => IsSymbol sel
29733256 => ParseSelect sel tables result
3257+ => HasMutation stage
29743258 => Row.Lacks "returning" stage
29753259 => Row.Lacks "select" stage
29763260 => Row.Cons "returning" Unit stage stage'
@@ -2982,6 +3266,7 @@ returningAll
29823266 :: forall tables name cols result p stage stage'
29833267 . SingleTable tables name cols
29843268 => StripColumns cols result
3269+ => HasMutation stage
29853270 => Row.Lacks "returning" stage
29863271 => Row.Lacks "select" stage
29873272 => Row.Cons "returning" Unit stage stage'
@@ -3024,8 +3309,10 @@ set
30243309 => ValidateSetColumnsRL setRL cols
30253310 => SetClauseRL setRL
30263311 => RecordValuesRL setRL setRow
3312+ => HasClause "update" stage
30273313 => Row.Lacks "select" stage
30283314 => Row.Lacks "insert" stage
3315+ => Row.Lacks "into" stage
30293316 => Row.Lacks "set" stage
30303317 => Row.Lacks "delete" stage
30313318 => Row.Cons "set" Unit stage stage'
@@ -3049,6 +3336,7 @@ delete
30493336 => IsSymbol name
30503337 => Row.Lacks "select" stage
30513338 => Row.Lacks "insert" stage
3339+ => Row.Lacks "into" stage
30523340 => Row.Lacks "set" stage
30533341 => Row.Lacks "delete" stage
30543342 => Row.Cons "delete" Unit stage stage'
@@ -3289,6 +3577,66 @@ exceptAll
32893577 -> Q tables1 result params SetOpStage
32903578exceptAll (Q q1) (Q q2) = Q { sql: "(" <> q1.sql <> ") EXCEPT ALL (" <> q2.sql <> ")", values: q1.values <> q2.values }
32913579
3580+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
3581+-- CTE (WITH clause) support
3582+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
3583+
3584+newtype WithCTEs :: Row (Row Type) -> Row Type -> Type
3585+newtype WithCTEs cteTables cteParams = WithCTEs
3586+ { sql :: String, values :: Array PG.PGValue }
3587+
3588+-- Wrap a complete SELECT query as a named CTE
3589+cte
3590+ :: forall @name tables result params stage cteTables
3591+ . IsSymbol name
3592+ => HasClause "select" stage
3593+ => Row.Cons name result () cteTables
3594+ => Q tables result params stage
3595+ -> WithCTEs cteTables params
3596+cte (Q q) = WithCTEs
3597+ { sql: reflectSymbol (Proxy :: Proxy name) <> " AS (" <> q.sql <> ")"
3598+ , values: q.values
3599+ }
3600+
3601+-- Add another named CTE to an accumulator
3602+andCTE
3603+ :: forall @name tables result params stage cteTables cteParams cteTables' cteParams'
3604+ . IsSymbol name
3605+ => HasClause "select" stage
3606+ => Row.Lacks name cteTables
3607+ => Row.Cons name result cteTables cteTables'
3608+ => Row.Union cteParams params cteParams'
3609+ => Row.Nub cteParams' cteParams'
3610+ => Q tables result params stage
3611+ -> WithCTEs cteTables cteParams
3612+ -> WithCTEs cteTables' cteParams'
3613+andCTE (Q q) (WithCTEs w) = WithCTEs
3614+ { sql: w.sql <> ", " <> reflectSymbol (Proxy :: Proxy name) <> " AS (" <> q.sql <> ")"
3615+ , values: w.values <> q.values
3616+ }
3617+
3618+-- Start main query FROM a named CTE; cteTables becomes available as tables
3619+fromCTE
3620+ :: forall @name result restTables cteTables cteParams
3621+ . IsSymbol name
3622+ => Row.Cons name result restTables cteTables
3623+ => WithCTEs cteTables cteParams
3624+ -> Q cteTables () () ()
3625+fromCTE _ = Q { sql: reflectSymbol (Proxy :: Proxy name), values: [] }
3626+
3627+-- Finalize: prepend WITH clause and merge params
3628+with_
3629+ :: forall cteTables cteParams mainParams allParams result stage
3630+ . Row.Union cteParams mainParams allParams
3631+ => Row.Nub allParams allParams
3632+ => WithCTEs cteTables cteParams
3633+ -> Q cteTables result mainParams stage
3634+ -> Q cteTables result allParams stage
3635+with_ (WithCTEs w) (Q q) = Q
3636+ { sql: "WITH " <> w.sql <> " " <> q.sql
3637+ , values: w.values <> q.values
3638+ }
3639+
32923640-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
32933641-- Query execution
32943642-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -3304,28 +3652,34 @@ instance
33043652 ( IsSymbol name
33053653 , Row.Cons name typ rest row
33063654 , Row.Lacks name rest
3655+ , FieldToPGValue typ
33073656 , ParamsToArray tail row
33083657 ) =>
33093658 ParamsToArray (RL.Cons name typ tail) row where
33103659 paramsToArray _ rec =
33113660 [ { name: reflectSymbol (Proxy :: Proxy name)
3312− , value: unsafeToForeign (Record.get (Proxy :: Proxy name) rec)
3661+ , value: unsafeCoerce (fieldToPGValue (Record.get (Proxy :: Proxy name) rec))
33133662 }
33143663 ]
33153664 <> paramsToArray (Proxy :: Proxy tail) rec
33163665
33173666namedParamRegex :: Regex.Regex
3318−namedParamRegex = case Regex.regex "\\$[a-zA-Z_][a-zA-Z0-9_]*" Regex.global of
3667+namedParamRegex = case Regex.regex "\\$[a-zA-Z_][a-zA-Z0-9_]*(::[a-zA-Z_]+)?" Regex.global of
33193668 Right r -> r
33203669 Left _ -> unsafeCoerce unit
33213670
3671+stripCast :: String -> String
3672+stripCast s = case SCU.indexOf (Pattern "::") s of
3673+ Nothing -> s
3674+ Just i -> SCU.take i s
3675+
33223676replaceNamedParams :: Int -> Array { name :: String, value :: Foreign } -> String -> { sql :: String, values :: Array PG.PGValue }
33233677replaceNamedParams offset entries sql = do
33243678 let indexed = entries # mapWithIndex \i e -> { idx: offset + i + 1, name: e.name, value: e.value }
33253679 let replacements = indexed # foldl (\m e -> Map.insert ("$" <> e.name) ("$" <> show e.idx) m) Map.empty
33263680 let
33273681 sql' = Regex.replace' namedParamRegex
3328− ( \match _ -> case Map.lookup match replacements of
3682+ ( \match _ -> case Map.lookup (stripCast match) replacements of
33293683 Nothing -> match
33303684 Just v -> v
33313685 )
@@ -3346,7 +3700,9 @@ runQuery conn params (Q q) = do
33463700 let { sql, values } = replaceNamedParams (Array.length q.values) entries q.sql
33473701 let allValues = q.values <> values
33483702 result <- PG.query (PG.SQL sql) allValues conn
3349− pure (unsafeDecodeRows result.rows)
3703+ case decodeRows result.rows of
3704+ Left errs -> throwError (Exception.error ("Row decode failed: " <> show errs))
3705+ Right rows -> pure rows
33503706
33513707runQueryOne
33523708 :: forall tables result params paramsRL stage
@@ -3362,7 +3718,11 @@ runQueryOne conn params (Q q) = do
33623718 let { sql, values } = replaceNamedParams (Array.length q.values) entries q.sql
33633719 let allValues = q.values <> values
33643720 result <- PG.queryOne (PG.SQL sql) allValues conn
3365− pure (result <#> unsafeDecodeRow)
3721+ case result of
3722+ Nothing -> pure Nothing
3723+ Just row -> case decodeRow row of
3724+ Left errs -> throwError (Exception.error ("Row decode failed: " <> show errs))
3725+ Right a -> pure (Just a)
33663726
33673727runExecute
33683728 :: forall tables params paramsRL stage
@@ -3394,7 +3754,9 @@ runQueryTx txn params (Q q) = do
33943754 let { sql, values } = replaceNamedParams (Array.length q.values) entries q.sql
33953755 let allValues = q.values <> values
33963756 result <- PG.txQuery (PG.SQL sql) allValues txn
3397− pure (unsafeDecodeRows result.rows)
3757+ case decodeRows result.rows of
3758+ Left errs -> throwError (Exception.error ("Row decode failed: " <> show errs))
3759+ Right rows -> pure rows
33983760
33993761runExecuteTx
34003762 :: forall tables params paramsRL stage
@@ -3410,10 +3772,9 @@ runExecuteTx txn params (Q q) = do
34103772 let allValues = q.values <> values
34113773 PG.txExecute (PG.SQL sql) allValues txn
34123774
3413−unsafeDecodeRows :: forall a. ReadForeign a => Array Foreign -> Array a
3414−unsafeDecodeRows = map unsafeDecodeRow
34153775
3416−unsafeDecodeRow :: forall a. ReadForeign a => Foreign -> a
3417−unsafeDecodeRow f = case runExcept (readImpl f) of
3418− Left _ -> unsafeCoerce unit
3419− Right a -> a
3776+decodeRows :: forall a. ReadForeign a => Array Foreign -> Either (NonEmptyList ForeignError) (Array a)
3777+decodeRows = traverse (readImpl >>> runExcept)
3778+
3779+decodeRow :: forall a. ReadForeign a => Foreign -> Either (NonEmptyList ForeignError) a
3780+decodeRow = readImpl >>> runExcept