@@ -2,42 +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.List.Types (NonEmptyList)
24−import Data.Traversable (traverse)
25−import Effect.Exception (error) as Exception
26−import Data.Map as Map
2726import Data.Symbol (class IsSymbol, reflectSymbol)
28−import Type.Function (type (#))
27+import Data.Time (Time(..))
28+import Data.Traversable (traverse)
29+import Data.UUID (UUID)
30+import Data.UUID as UUID
2931import Effect.Aff (Aff, throwError)
30−import Foreign (Foreign, ForeignError(..), unsafeToForeign)
32+import Effect.Exception (error) as Exception
33+import Foreign (Foreign, ForeignError(..))
34+import JS.BigInt (BigInt)
3135import Prim.Boolean (True, False)
3236import Prim.Row (class Cons, class Lacks, class Union, class Nub) as Row
33−import Prim.RowList as RL
3437import Prim.RowList (class RowToList)
38+import Prim.RowList as RL
3539import Prim.Symbol (class Cons, class Append) as Symbol
3640import Prim.TypeError (class Fail, Beside, Text, Quote)
3741import Record (get) as Record
3842import Type.Proxy (Proxy(..))
3943import Type.RowList (class ListToRow)
40−import Yoga.JSON (class ReadForeign, readImpl)
44+import Unsafe.Coerce (unsafeCoerce)
45+import Yoga.JSON (class ReadForeign, class WriteForeign, readImpl, writeImpl)
4146import Yoga.Postgres as PG
4247
4348-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -63,15 +68,15 @@ data Unique a
6368
6469data Default :: forall k. k -> Type -> Type
6570data Default val a
71+data DefaultExpr :: Symbol -> Type -> Type
72+data DefaultExpr expression a
73+
6674
6775data References
6876
6977data ForeignKey :: Symbol -> Type -> Symbol -> Type -> Type
7078data ForeignKey table references col a
7179
72−data DefaultExpr :: Symbol -> Type -> Type
73−data DefaultExpr expr a
74−
7580-- Internal: used by LEFT JOIN to mark columns as nullable
7681data Nullable :: Type -> Type
7782data Nullable a
@@ -87,6 +92,9 @@ derive instance Newtype Jsonb _
8792instance ReadForeign Jsonb where
8893 readImpl = pure <<< Jsonb
8994
95+instance WriteForeign Jsonb where
96+ writeImpl (Jsonb value) = value
97+
9098-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
9199-- PGUUID: newtype over Data.UUID.UUID for Postgres integration
92100-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -103,6 +111,9 @@ instance ReadForeign PGUUID where
103111 s :: String <- readImpl f
104112 pure (unsafeCoerce s)
105113
114+instance WriteForeign PGUUID where
115+ writeImpl (PGUUID uuid) = writeImpl (UUID.toString uuid)
116+
106117-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
107118-- PGDate / PGTime: newtypes for DATE and TIME columns
108119-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -116,11 +127,38 @@ instance Show PGDate where
116127 show (PGDate d) = "(PGDate " <> show d <> ")"
117128
118129instance ReadForeign PGDate where
119− readImpl = readImpl >=>
120− JSDate.toDate
121− >>> note (pure (ForeignError "Invalid date"))
122− >>> except
123− >>> 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
124162
125163newtype PGTime = PGTime Time
126164
@@ -132,8 +170,44 @@ instance Show PGTime where
132170
133171instance ReadForeign PGTime where
134172 readImpl f = do
135− dt :: DateTime <- readImpl f
136− 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
137211
138212-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
139213-- Point: geometric point "(x,y)"
@@ -149,8 +223,18 @@ instance Show Point where
149223
150224instance ReadForeign Point where
151225 readImpl f = do
152− { x, y } :: { x :: Number, y :: Number } <- readImpl f
153− 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
154238
155239-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
156240-- TSVector / TSQuery: full-text search types
@@ -203,7 +287,7 @@ instance ExtractType a typ => ExtractType (PrimaryKey a) typ
203287else instance ExtractType a typ => ExtractType (AutoIncrement a) typ
204288else instance ExtractType a typ => ExtractType (Unique a) typ
205289else instance ExtractType a typ => ExtractType (Default val a) typ
206−else instance ExtractType a typ => ExtractType (DefaultExpr expr a) typ
290+else instance ExtractType a typ => ExtractType (DefaultExpr expression a) typ
207291else instance ExtractType a typ => ExtractType (ForeignKey t r c a) typ
208292else instance ExtractType a typ => ExtractType (Nullable a) (Maybe typ)
209293else instance ExtractType a a
@@ -236,6 +320,9 @@ instance PGTypeName BigInt where
236320instance PGTypeName PGUUID where
237321 pgTypeName _ = "UUID"
238322
323+instance PGTypeName TimestampTZ where
324+ pgTypeName _ = "TIMESTAMPTZ"
325+
239326instance PGTypeName PGDate where
240327 pgTypeName _ = "DATE"
241328
@@ -273,8 +360,24 @@ instance Reflectable sym String => RenderDefaultValue sym String where
273360instance Reflectable val Int => RenderDefaultValue val Int where
274361 renderDefaultValue _ _ = "DEFAULT " <> show (reflectType (Proxy :: Proxy val))
275362
276−instance Reflectable val Boolean => RenderDefaultValue val Boolean where
277− 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+
278381
279382class RenderConstraint a where
280383 renderConstraint :: Proxy a -> String
@@ -291,11 +394,10 @@ else instance RenderConstraint a => RenderConstraint (Unique a) where
291394else instance (RenderDefaultValue val a, RenderConstraint a) => RenderConstraint (Default val a) where
292395 renderConstraint _ = joinConstraints (renderDefaultValue (Proxy :: Proxy val) (Proxy :: Proxy a)) (renderConstraint (Proxy :: Proxy a))
293396
294−else instance (IsSymbol expr, RenderConstraint a) => RenderConstraint (DefaultExpr expr a) where
397+else instance (IsSymbol expression, RenderConstraint a) => RenderConstraint (DefaultExpr expression a) where
295398 renderConstraint _ = joinConstraints
296− ("DEFAULT " <> reflectSymbol (Proxy :: Proxy expr))
399+ ("DEFAULT " <> reflectSymbol (Proxy :: Proxy expression))
297400 (renderConstraint (Proxy :: Proxy a))
298−
299401else instance (IsSymbol table, IsSymbol col, RenderConstraint a) => RenderConstraint (ForeignKey table References col a) where
300402 renderConstraint _ = joinConstraints
301403 ("REFERENCES " <> reflectSymbol (Proxy :: Proxy table) <> "(" <> reflectSymbol (Proxy :: Proxy col) <> ")")
@@ -356,6 +458,11 @@ instance
356458 let columns = renderColumnsRL (Proxy :: Proxy rl)
357459 "CREATE TABLE " <> tableName <> " (" <> intercalate ", " columns <> ")"
358460
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+
359466-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
360467-- INSERT SQL generation
361468-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -367,7 +474,7 @@ instance IsAutoGenerated (AutoIncrement a) where
367474 isAutoGenerated _ = true
368475else instance IsAutoGenerated (Default v a) where
369476 isAutoGenerated _ = true
370−else instance IsAutoGenerated (DefaultExpr expr a) where
477+else instance IsAutoGenerated (DefaultExpr expression a) where
371478 isAutoGenerated _ = true
372479else instance IsAutoGenerated a => IsAutoGenerated (PrimaryKey a) where
373480 isAutoGenerated _ = isAutoGenerated (Proxy :: Proxy a)
@@ -412,15 +519,18 @@ instance
412519 insertSQLFor = do
413520 let tableName = reflectSymbol (Proxy :: Proxy name)
414521 let cols = insertColumnsRL (Proxy :: Proxy rl)
415− let placeholders = cols # mapWithIndex \i _ -> "$" <> show (i + 1)
416− "INSERT INTO " <> tableName
417− <> " ("
418− <> intercalate ", " cols
419− <> ")"
420− <> " VALUES ("
421− <> intercalate ", " placeholders
422− <> ")"
423− <> " 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 *"
424534
425535-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
426536-- SELECT SQL generation
@@ -875,6 +985,15 @@ else instance
875985 ) =>
876986 ParseSelectHandleAS "as" afterKeyword colRef tables accRL outRL
877987
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+
878997class ParseSelectExpectEnd :: Symbol -> Row (Row Type) -> RL.RowList Type -> RL.RowList Type -> Constraint
879998class ParseSelectExpectEnd sym tables accRL outRL | sym tables accRL -> outRL
880999
@@ -973,11 +1092,66 @@ instance ResolveAggregateArg "*" tables Star
9731092else instance ResolveAggregateArg "" tables Star
9741093else instance
9751094 ( SkipSpaces args trimmedFront
976− , ExtractWord trimmedFront col _rest
977− , ResolveAggregateArgCol col tables argType
1095+ , ExtractIdent trimmedFront col rest
1096+ , ResolveAggregateArgDispatch col rest tables argType
9781097 ) =>
9791098 ResolveAggregateArg args tables argType
9801099
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+
9811155class ResolveAggregateArgCol :: Symbol -> Row (Row Type) -> Type -> Constraint
9821156class ResolveAggregateArgCol col tables argType | col tables -> argType
9831157
@@ -1062,8 +1236,8 @@ else instance
10621236class AggregateReturnTypeC :: Symbol -> Type -> Type -> Constraint
10631237class AggregateReturnTypeC funcName argType returnType | funcName argType -> returnType
10641238
1065−instance AggregateReturnTypeC "COUNT" argType Int
1066−else instance AggregateReturnTypeC "count" argType Int
1239+instance AggregateReturnTypeC "COUNT" argType BigInt
1240+else instance AggregateReturnTypeC "count" argType BigInt
10671241else instance AggregateReturnTypeC "COALESCE" argType argType
10681242else instance AggregateReturnTypeC "coalesce" argType argType
10691243else instance
@@ -2483,13 +2657,85 @@ else instance
24832657 , SkipSpaces rest1 rest2
24842658 , ExpectChar rest2 "=" rest3
24852659 , SkipSpaces rest3 rest4
2486− , ExtractWord rest4 excRef rest5
2487− , ValidateExcludedRef excRef colName
2488− , SkipSpaces rest5 rest6
2489− , ParseAssignmentsContinue rest6 cols
2660+ , SkipExpression rest4 rest5
2661+ , ParseAssignmentsContinue rest5 cols
24902662 ) =>
24912663 ParseAssignments sym cols
24922664
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+
24932739class ParseAssignmentsContinue :: Symbol -> Row Type -> Constraint
24942740class ParseAssignmentsContinue sym cols
24952741
@@ -2552,7 +2798,7 @@ class IsAutoGeneratedTC constraints result | constraints -> result
25522798
25532799instance IsAutoGeneratedTC (AutoIncrement a) True
25542800else instance IsAutoGeneratedTC (Default s a) True
2555−else instance IsAutoGeneratedTC (DefaultExpr expr a) True
2801+else instance IsAutoGeneratedTC (DefaultExpr expression a) True
25562802else instance IsAutoGeneratedTC a result => IsAutoGeneratedTC (PrimaryKey a) result
25572803else instance IsAutoGeneratedTC a result => IsAutoGeneratedTC (Unique a) result
25582804else instance IsAutoGeneratedTC a result => IsAutoGeneratedTC (ForeignKey t r c a) result
@@ -2608,13 +2854,19 @@ class FieldToPGValue a where
26082854 fieldToPGValue :: a -> PG.PGValue
26092855
26102856instance FieldToPGValue a => FieldToPGValue (Maybe a) where
2611− fieldToPGValue = toNullable >>> unsafeCoerce
2857+ fieldToPGValue = case _ of
2858+ Nothing -> unsafeCoerce (toNullable Nothing)
2859+ Just value -> fieldToPGValue value
26122860else instance FieldToPGValue DateTime where
26132861 fieldToPGValue = JSDate.fromDateTime >>> unsafeCoerce
2862+else instance FieldToPGValue TimestampTZ where
2863+ fieldToPGValue (TimestampTZ dt) = JSDate.fromDateTime dt # unsafeCoerce
26142864else instance FieldToPGValue PGDate where
2615− fieldToPGValue (PGDate d) = JSDate.fromDateTime (DateTime d bottom) # unsafeCoerce
2616−else instance FieldToPGValue a where
2865+ fieldToPGValue = writeImpl >>> unsafeCoerce
2866+else instance FieldToPGValue PGUUID where
26172867 fieldToPGValue = unsafeCoerce
2868+else instance WriteForeign a => FieldToPGValue a where
2869+ fieldToPGValue = writeImpl >>> unsafeCoerce
26182870
26192871class RecordValuesRL :: RL.RowList Type -> Row Type -> Constraint
26202872class RecordValuesRL rl row where
@@ -2682,6 +2934,20 @@ else instance HasAnyDMLRL (RL.Cons "delete" Unit rest)
26822934else instance HasAnyDMLRL rest => HasAnyDMLRL (RL.Cons label typ rest)
26832935else instance Fail (Text "WHERE requires a preceding SELECT, UPDATE (set), or DELETE") => HasAnyDMLRL RL.Nil
26842936
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+
26852951toSQL :: forall tables result params stage. Q tables result params stage -> String
26862952toSQL (Q q) = q.sql
26872953
@@ -2691,6 +2957,12 @@ from _ = Q { sql: reflectSymbol (Proxy :: Proxy name), values: [] }
26912957fromAs :: forall @alias name cols tables. IsSymbol name => IsSymbol alias => Row.Cons alias cols () tables => Proxy (Table name cols) -> Q tables () () ()
26922958fromAs _ = Q { sql: reflectSymbol (Proxy :: Proxy name) <> " " <> reflectSymbol (Proxy :: Proxy alias), values: [] }
26932959
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+
26942966selectAll
26952967 :: forall tables name cols result r p stage stage'
26962968 . SingleTable tables name cols
@@ -2698,6 +2970,7 @@ selectAll
26982970 => StripColumns cols result
26992971 => Row.Lacks "select" stage
27002972 => Row.Lacks "insert" stage
2973+ => Row.Lacks "into" stage
27012974 => Row.Lacks "set" stage
27022975 => Row.Lacks "delete" stage
27032976 => Row.Lacks "where" stage
@@ -2715,6 +2988,7 @@ select
27152988 => ParseSelect sel tables result
27162989 => Row.Lacks "select" stage
27172990 => Row.Lacks "insert" stage
2991+ => Row.Lacks "into" stage
27182992 => Row.Lacks "set" stage
27192993 => Row.Lacks "delete" stage
27202994 => Row.Lacks "where" stage
@@ -2732,6 +3006,7 @@ selectDistinct
27323006 => ParseSelect sel tables result
27333007 => Row.Lacks "select" stage
27343008 => Row.Lacks "insert" stage
3009+ => Row.Lacks "into" stage
27353010 => Row.Lacks "set" stage
27363011 => Row.Lacks "delete" stage
27373012 => Row.Lacks "where" stage
@@ -2752,6 +3027,7 @@ selectDistinctOn
27523027 => ParseSelect sel tables result
27533028 => Row.Lacks "select" stage
27543029 => Row.Lacks "insert" stage
3030+ => Row.Lacks "into" stage
27553031 => Row.Lacks "set" stage
27563032 => Row.Lacks "delete" stage
27573033 => Row.Lacks "where" stage
@@ -2956,13 +3232,17 @@ insert rec _ = Q { sql, values }
29563232 tableName = reflectSymbol (Proxy :: Proxy name)
29573233 colNames = columnNamesRL (Proxy :: Proxy userRowRL)
29583234 placeholders = colNames # mapWithIndex \i _ -> "$" <> show (i + 1)
2959− sql = "INSERT INTO " <> tableName
2960− <> " ("
2961− <> intercalate ", " colNames
2962− <> ")"
2963− <> " VALUES ("
2964− <> intercalate ", " placeholders
2965− <> ")"
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+ <> ")"
29663246 values = recordValuesRL (Proxy :: Proxy userRowRL) rec
29673247
29683248-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -2974,6 +3254,7 @@ returning
29743254 . SingleTable tables name cols
29753255 => IsSymbol sel
29763256 => ParseSelect sel tables result
3257+ => HasMutation stage
29773258 => Row.Lacks "returning" stage
29783259 => Row.Lacks "select" stage
29793260 => Row.Cons "returning" Unit stage stage'
@@ -2985,6 +3266,7 @@ returningAll
29853266 :: forall tables name cols result p stage stage'
29863267 . SingleTable tables name cols
29873268 => StripColumns cols result
3269+ => HasMutation stage
29883270 => Row.Lacks "returning" stage
29893271 => Row.Lacks "select" stage
29903272 => Row.Cons "returning" Unit stage stage'
@@ -3027,8 +3309,10 @@ set
30273309 => ValidateSetColumnsRL setRL cols
30283310 => SetClauseRL setRL
30293311 => RecordValuesRL setRL setRow
3312+ => HasClause "update" stage
30303313 => Row.Lacks "select" stage
30313314 => Row.Lacks "insert" stage
3315+ => Row.Lacks "into" stage
30323316 => Row.Lacks "set" stage
30333317 => Row.Lacks "delete" stage
30343318 => Row.Cons "set" Unit stage stage'
@@ -3052,6 +3336,7 @@ delete
30523336 => IsSymbol name
30533337 => Row.Lacks "select" stage
30543338 => Row.Lacks "insert" stage
3339+ => Row.Lacks "into" stage
30553340 => Row.Lacks "set" stage
30563341 => Row.Lacks "delete" stage
30573342 => Row.Cons "delete" Unit stage stage'
@@ -3292,6 +3577,66 @@ exceptAll
32923577 -> Q tables1 result params SetOpStage
32933578exceptAll (Q q1) (Q q2) = Q { sql: "(" <> q1.sql <> ") EXCEPT ALL (" <> q2.sql <> ")", values: q1.values <> q2.values }
32943579
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+
32953640-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
32963641-- Query execution
32973642-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
@@ -3307,28 +3652,34 @@ instance
33073652 ( IsSymbol name
33083653 , Row.Cons name typ rest row
33093654 , Row.Lacks name rest
3655+ , FieldToPGValue typ
33103656 , ParamsToArray tail row
33113657 ) =>
33123658 ParamsToArray (RL.Cons name typ tail) row where
33133659 paramsToArray _ rec =
33143660 [ { name: reflectSymbol (Proxy :: Proxy name)
3315− , value: unsafeToForeign (Record.get (Proxy :: Proxy name) rec)
3661+ , value: unsafeCoerce (fieldToPGValue (Record.get (Proxy :: Proxy name) rec))
33163662 }
33173663 ]
33183664 <> paramsToArray (Proxy :: Proxy tail) rec
33193665
33203666namedParamRegex :: Regex.Regex
3321−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
33223668 Right r -> r
33233669 Left _ -> unsafeCoerce unit
33243670
3671+stripCast :: String -> String
3672+stripCast s = case SCU.indexOf (Pattern "::") s of
3673+ Nothing -> s
3674+ Just i -> SCU.take i s
3675+
33253676replaceNamedParams :: Int -> Array { name :: String, value :: Foreign } -> String -> { sql :: String, values :: Array PG.PGValue }
33263677replaceNamedParams offset entries sql = do
33273678 let indexed = entries # mapWithIndex \i e -> { idx: offset + i + 1, name: e.name, value: e.value }
33283679 let replacements = indexed # foldl (\m e -> Map.insert ("$" <> e.name) ("$" <> show e.idx) m) Map.empty
33293680 let
33303681 sql' = Regex.replace' namedParamRegex
3331− ( \match _ -> case Map.lookup match replacements of
3682+ ( \match _ -> case Map.lookup (stripCast match) replacements of
33323683 Nothing -> match
33333684 Just v -> v
33343685 )
@@ -3421,6 +3772,7 @@ runExecuteTx txn params (Q q) = do
34213772 let allValues = q.values <> values
34223773 PG.txExecute (PG.SQL sql) allValues txn
34233774
3775+
34243776decodeRows :: forall a. ReadForeign a => Array Foreign -> Either (NonEmptyList ForeignError) (Array a)
34253777decodeRows = traverse (readImpl >>> runExcept)
34263778