@@ -0,0 +1,364 @@
1+module Yoga.SQL.PostgresTypes where
2+
3+import Prelude
4+
5+import Control.Monad.Except.Trans (ExceptT, runExceptT)
6+import Data.Array as Array
7+import Data.Array.NonEmpty.Internal (NonEmptyArray)
8+import Data.Bifunctor (lmap)
9+import Data.Either (Either(..))
10+import Data.Foldable (intercalate)
11+import Data.FoldableWithIndex (foldMapWithIndex)
12+import Data.FunctorWithIndex (mapWithIndex)
13+import Data.Identity (Identity(..))
14+import Data.List.Types (NonEmptyList)
15+import Data.Map (Map)
16+import Data.Map as Map
17+import Data.Maybe (Maybe, fromJust)
18+import Data.Newtype (class Newtype, un)
19+import Data.Nullable (toNullable)
20+import Data.Reflectable (reflectType)
21+import Data.Semigroup.Foldable (intercalateMap)
22+import Data.Symbol (class IsSymbol, reflectSymbol)
23+import Data.Traversable (traverse)
24+import Data.Tuple.Nested (type (/\))
25+import Foreign (Foreign, ForeignError, readArray, readBoolean, readInt, readNull, readNumber, readString, renderForeignError, unsafeToForeign)
26+import Foreign.Object as Object
27+import Heterogeneous.Folding (class Folding, class FoldingWithIndex, class HFoldl, class HFoldlWithIndex, hfoldl, hfoldlWithIndex)
28+import Partial.Unsafe (unsafePartial)
29+import Prim.Coerce (class Coercible)
30+import Prim.Row as Row
31+import Prim.RowList (class RowToList)
32+import Prim.RowList as RowList
33+import Record.Builder (Builder)
34+import Record.Builder as Builder
35+import Safe.Coerce (coerce)
36+import Type.Proxy (Proxy(..))
37+import Type.Row.Homogeneous (class Homogeneous)
38+import Unsafe.Coerce (unsafeCoerce)
39+import Yoga.JSON (unsafeStringify)
40+import Yoga.JSON.Error (renderHumanError)
41+
42+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
43+-- Core SQL Query with Row Type Tracking
44+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
45+
46+-- | A SQL query that tracks its parameters at the type level
47+-- | The row type `r` represents { paramName :: paramType, ... }
48+data SQLQuery :: Row Type -> Type
49+data SQLQuery rows = SQLQuery (Array String) String
50+
51+sqlQueryToString :: forall r. SQLQuery r -> String
52+sqlQueryToString (SQLQuery _ q) = q
53+
54+-- | Opaque SQL parameter type (database-specific)
55+foreign import data SQLParameter :: Type
56+
57+-- | Opaque SQL result type (database-specific)
58+foreign import data SQLResult :: Type
59+
60+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
61+-- Converting PureScript Values to SQL Parameters
62+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
63+
64+class ToSQLParam a where
65+ toSQLParam :: a -> SQLParameter
66+
67+instance ToSQLParam Int where
68+ toSQLParam = unsafeCoerce
69+
70+else instance ToSQLParam String where
71+ toSQLParam = unsafeCoerce
72+
73+else instance ToSQLParam Number where
74+ toSQLParam = unsafeCoerce
75+
76+else instance ToSQLParam Boolean where
77+ toSQLParam = unsafeCoerce
78+
79+else instance (ToSQLParam a) => ToSQLParam (Array a) where
80+ toSQLParam = unsafeCoerce
81+
82+else instance (ToSQLParam a) => ToSQLParam (NonEmptyArray a) where
83+ toSQLParam = unsafeCoerce
84+
85+else instance (ToSQLParam a) => ToSQLParam (Maybe a) where
86+ toSQLParam = map toSQLParam >>> toNullable >>> unsafeCoerce
87+
88+else instance (ToSQLParam b, Newtype a b) => ToSQLParam a where
89+ toSQLParam = unsafeCoerce
90+
91+else instance (Coercible a b, ToSQLParam b) => ToSQLParam b where
92+ toSQLParam = unsafeCoerce
93+
94+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
95+-- Converting SQL Results to PureScript Values
96+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
97+
98+fromSQLValue :: forall @a. SQLFromForeign a => SQLResult -> Either String a
99+fromSQLValue param =
100+ (un Identity $ runExceptT $ fromSQLResultImpl (unsafeToForeign param))
101+ # lmap (intercalateMap ", " renderHumanError)
102+
103+class SQLFromForeign a where
104+ fromSQLResultImpl :: Foreign -> ExceptT (NonEmptyList ForeignError) Identity a
105+
106+instance SQLFromForeign Boolean where
107+ fromSQLResultImpl = readBoolean
108+
109+instance SQLFromForeign Int where
110+ fromSQLResultImpl = readInt
111+
112+instance SQLFromForeign String where
113+ fromSQLResultImpl = readString
114+
115+instance SQLFromForeign Number where
116+ fromSQLResultImpl = readNumber
117+
118+instance (SQLFromForeign a) => SQLFromForeign (Array a) where
119+ fromSQLResultImpl = readArray >=> traverse fromSQLResultImpl
120+
121+instance (SQLFromForeign a) => SQLFromForeign (Maybe a) where
122+ fromSQLResultImpl = readNull >=> traverse fromSQLResultImpl
123+
124+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
125+-- Result Array Parsing (for multiple return values)
126+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
127+
128+singleResult :: forall @a b. SQLFromForeign a => (a -> b) -> Array SQLResult -> Either String b
129+singleResult mk = case _ of
130+ [ x ] -> fromSQLValue @a x <#> mk
131+ x | len <- Array.length x -> Left $ "Expected exactly one result, got " <> show len
132+
133+twoResults :: forall @a @b c. SQLFromForeign a => SQLFromForeign b => (a -> b -> c) -> Array SQLResult -> Either String c
134+twoResults mk = case _ of
135+ [ _1, _2 ] -> mk <$> fromSQLValue @a _1 <*> fromSQLValue @b _2
136+ x | len <- Array.length x -> Left $ "Expected exactly two results, got " <> show len
137+
138+threeResults :: forall @a @b @c d. SQLFromForeign a => SQLFromForeign b => SQLFromForeign c => (a -> b -> c -> d) -> Array SQLResult -> Either String d
139+threeResults mk = case _ of
140+ [ _1, _2, _3 ] -> mk <$> fromSQLValue @a _1 <*> fromSQLValue @b _2 <*> fromSQLValue @c _3
141+ x | len <- Array.length x -> Left $ "Expected exactly three results, got " <> show len
142+
143+fourResults :: forall @a @b @c @d e. SQLFromForeign a => SQLFromForeign b => SQLFromForeign c => SQLFromForeign d => (a -> b -> c -> d -> e) -> Array SQLResult -> Either String e
144+fourResults mk = case _ of
145+ [ _1, _2, _3, _4 ] -> mk <$> fromSQLValue @a _1 <*> fromSQLValue @b _2 <*> fromSQLValue @c _3 <*> fromSQLValue @d _4
146+ x | len <- Array.length x -> Left $ "Expected exactly four results, got " <> show len
147+
148+fiveResults :: forall @a @b @c @d @e f. SQLFromForeign a => SQLFromForeign b => SQLFromForeign c => SQLFromForeign d => SQLFromForeign e => (a -> b -> c -> d -> e -> f) -> Array SQLResult -> Either String f
149+fiveResults mk = case _ of
150+ [ _1, _2, _3, _4, _5 ] -> mk <$> fromSQLValue @a _1 <*> fromSQLValue @b _2 <*> fromSQLValue @c _3 <*> fromSQLValue @d _4 <*> fromSQLValue @e _5
151+ x | len <- Array.length x -> Left $ "Expected exactly five results, got " <> show len
152+
153+class FromResultArray fn a | fn -> a where
154+ fromResultArray :: fn -> Array SQLResult -> Either String a
155+
156+instance (SQLFromForeign a, SQLFromForeign b, SQLFromForeign c, SQLFromForeign d, SQLFromForeign e) => FromResultArray (a -> b -> c -> d -> e -> f) f where
157+ fromResultArray = fiveResults
158+
159+else instance (SQLFromForeign a, SQLFromForeign b, SQLFromForeign c, SQLFromForeign d) => FromResultArray (a -> b -> c -> d -> e) e where
160+ fromResultArray = fourResults
161+
162+else instance (SQLFromForeign a, SQLFromForeign b, SQLFromForeign c) => FromResultArray (a -> b -> c -> d) d where
163+ fromResultArray = threeResults
164+
165+else instance (SQLFromForeign a, SQLFromForeign b) => FromResultArray (a -> b -> c) c where
166+ fromResultArray = twoResults
167+
168+else instance SQLFromForeign a => FromResultArray (a -> b) b where
169+ fromResultArray = singleResult
170+
171+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
172+-- Heterogeneous Folding for Parameter Extraction
173+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
174+
175+data TurnIntoSQLParam = TurnIntoSQLParam
176+
177+instance (ToSQLParam n) => Folding TurnIntoSQLParam (Array SQLParameter) n (Array SQLParameter) where
178+ folding TurnIntoSQLParam acc a = Array.snoc acc (toSQLParam a)
179+
180+instance
181+ ( ToSQLParam n
182+ , IsSymbol sym
183+ ) =>
184+ FoldingWithIndex TurnIntoSQLParam (Proxy sym) (Map String SQLParameter) n (Map String SQLParameter) where
185+ foldingWithIndex TurnIntoSQLParam sym acc a = Map.insert (reflectSymbol sym) (toSQLParam a) acc
186+
187+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
188+-- SQL Query Builder with Type-Level Parameter Tracking
189+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
190+
191+newtype SQLBuilder r1 r2 = SQLBuilder (SQLQuery r1 -> SQLQuery r2)
192+
193+class ToBuilder s r1 r2 | r1 -> r2, r2 -> r1 where
194+ toBuilder :: s -> SQLBuilder r1 r2
195+
196+instance ToBuilder (SQLBuilder r1 r2) r1 r2 where
197+ toBuilder = identity
198+
199+else instance ToBuilder String r r where
200+ toBuilder = nonArg
201+
202+-- | Compose two builders
203+combineBuilders :: forall a b r1 r2 r3. ToBuilder a r2 r3 => ToBuilder b r1 r2 => a -> b -> SQLBuilder r1 r3
204+combineBuilders a b = SQLBuilder (f <<< g)
205+ where
206+ SQLBuilder f = toBuilder a
207+ SQLBuilder g = toBuilder b
208+
209+infixl 8 combineBuilders as ^
210+
211+-- | Create a SQL query from a builder
212+sql :: forall r. SQLBuilder () r -> SQLQuery r
213+sql (SQLBuilder builder) = builder (SQLQuery [] "")
214+
215+-- | Add a typed parameter to the query (PostgreSQL $N format)
216+arg :: forall @a @sym r1 r2. IsSymbol sym => ToSQLParam a => Row.Cons sym a r1 r2 => SQLBuilder r1 r2
217+arg = SQLBuilder \(SQLQuery oldKeys oldQuery) ->
218+ let
219+ paramNum = Array.length oldKeys + 1
220+ in
221+ SQLQuery (Array.cons (reflectSymbol (Proxy :: Proxy sym)) oldKeys) ("$" <> show paramNum <> oldQuery)
222+
223+-- | Add an Int parameter
224+int :: forall @sym r1 r2. IsSymbol sym => Row.Cons sym Int r1 r2 => SQLBuilder r1 r2
225+int = arg @Int @sym
226+
227+-- | Add a String parameter
228+str :: forall @sym r1 r2. IsSymbol sym => Row.Cons sym String r1 r2 => SQLBuilder r1 r2
229+str = arg @String @sym
230+
231+-- | Add a Boolean parameter
232+bool :: forall @sym r1 r2. IsSymbol sym => Row.Cons sym Boolean r1 r2 => SQLBuilder r1 r2
233+bool = arg @Boolean @sym
234+
235+-- | Add a Number parameter
236+num :: forall @sym r1 r2. IsSymbol sym => Row.Cons sym Number r1 r2 => SQLBuilder r1 r2
237+num = arg @Number @sym
238+
239+-- | Add a literal SQL string (no parameter)
240+nonArg :: forall r. String -> SQLBuilder r r
241+nonArg newQuery = SQLBuilder \(SQLQuery keys oldQuery) -> SQLQuery keys (newQuery <> oldQuery)
242+
243+-- | Extract parameters from a record in the correct order
244+argsFor :: forall @params. HFoldlWithIndex TurnIntoSQLParam (Map String SQLParameter) { | params } (Map String SQLParameter) => SQLQuery params -> { | params } -> Array SQLParameter
245+argsFor (SQLQuery args _) params = do
246+ let theMap = hfoldlWithIndex TurnIntoSQLParam (Map.empty :: Map String SQLParameter) params
247+ -- Reverse the args array since we build it with cons (prepend)
248+ Array.reverse args <#> \positionedArg -> (unsafePartial $ fromJust $ Map.lookup positionedArg theMap)
249+
250+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
251+-- Table Schema Definition
252+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
253+
254+newtype DatabaseColumns row = DatabaseColumns row
255+
256+data SQLiteBaseType
257+ = TextColumn
258+ | IntColumn
259+ | RealColumn
260+ | BooleanColumn
261+ | BlobColumn
262+ | JsonBColumn
263+ | IntegerColumn
264+ | NumericColumn
265+ | NullColumn
266+
267+renderBaseType :: SQLiteBaseType -> String
268+renderBaseType = case _ of
269+ TextColumn -> "TEXT"
270+ IntColumn -> "INT"
271+ RealColumn -> "REAL"
272+ BooleanColumn -> "BOOLEAN"
273+ BlobColumn -> "BLOB"
274+ JsonBColumn -> "JSONB"
275+ IntegerColumn -> "INTEGER"
276+ NumericColumn -> "NUMERIC"
277+ NullColumn -> "NULL"
278+
279+data Constraint
280+ = Unique
281+ | PrimaryKey
282+ | NotNull
283+ | ForeignKey String
284+ | Check String
285+ | Default SQLParameter
286+
287+renderConstraint :: Constraint -> String
288+renderConstraint = case _ of
289+ Unique -> "UNIQUE"
290+ PrimaryKey -> "PRIMARY KEY"
291+ NotNull -> "NOT NULL"
292+ ForeignKey ref -> "FOREIGN KEY (" <> ref <> ")"
293+ Check condition -> "CHECK (" <> condition <> ")"
294+ Default value -> "DEFAULT " <> unsafeStringify value
295+
296+data SQLColumn = SQLColumn SQLiteBaseType (Array Constraint)
297+
298+newtype TableName = TableName String
299+
300+derive instance Newtype TableName _
301+
302+newtype ColumnName = ColumnName String
303+
304+derive instance Newtype ColumnName _
305+
306+-- | A table with typed columns
307+data Table columns = Table TableName { | columns }
308+
309+-- Helper for type inference
310+data MapRecord a b = MapRecord (String -> a -> b)
311+
312+instance
313+ ( IsSymbol sym
314+ , Row.Lacks sym rb
315+ , Row.Cons sym b rb rc
316+ ) =>
317+ FoldingWithIndex
318+ (MapRecord a b)
319+ (Proxy sym)
320+ (Builder { | ra } { | rb })
321+ a
322+ (Builder { | ra } { | rc }) where
323+ foldingWithIndex (MapRecord f) prop rin a = (rin >>> Builder.insert prop (f (reflectSymbol prop) a))
324+
325+mapRecordWithIndex
326+ :: forall @a @b @rin @rout
327+ . HFoldlWithIndex (MapRecord a b) (Builder {} {}) { | rin } (Builder {} { | rout })
328+ => (String -> a -> b)
329+ -> { | rin }
330+ -> { | rout }
331+mapRecordWithIndex f =
332+ Builder.buildFromScratch
333+ <<< hfoldlWithIndex
334+ (MapRecord f :: MapRecord a b)
335+ (identity :: Builder {} {})
336+
337+-- | Create a table schema
338+table :: forall @cols. Homogeneous cols SQLColumn => TableName -> { | cols } -> Table cols
339+table = Table
340+
341+-- | Extract column names from table schema
342+columnNamesOf
343+ :: forall cols colsRL out
344+ . RowToList cols colsRL
345+ => HFoldlWithIndex (MapRecord SQLColumn ColumnName)
346+ (Builder {} {})
347+ { | cols }
348+ (Builder {} { | out })
349+ => Table cols
350+ -> { | out }
351+columnNamesOf (Table _ cols) = cols # mapRecordWithIndex \key (_ :: SQLColumn) -> ColumnName key
352+
353+newtype CreateTableStatement = CreateTableStatement String
354+
355+derive instance Newtype CreateTableStatement _
356+
357+-- | Generate CREATE TABLE statement from schema
358+createTable :: forall cols. Homogeneous cols SQLColumn => Table cols -> CreateTableStatement
359+createTable (Table (TableName tableName) tab) = CreateTableStatement $ "CREATE TABLE " <> tableName <> " (" <> cols <> ")"
360+ where
361+ toConstraint :: String -> SQLColumn -> String
362+ toConstraint key (SQLColumn baseType constraints) =
363+ key <> " " <> renderBaseType baseType <> " " <> (constraints <#> renderConstraint # intercalate " ")
364+ cols = (Object.fromHomogeneous tab) # mapWithIndex toConstraint # intercalate ", "