From e98d87cb18d9d2273d60617b6b10e8b06d9f6eee Mon Sep 17 00:00:00 2001 From: Mark Date: Sat, 11 Apr 2026 10:12:36 +0200 Subject: [PATCH] Fix Json column ReadForeign instance to parse JSON strings --- src/Yoga/SQLite/Schema.purs | 13 +++++++--- test/Main.purs | 49 ++++++++++++++++++++++++++++++++++++- 2 files changed, 57 insertions(+), 5 deletions(-) diff --git a/src/Yoga/SQLite/Schema.purs b/src/Yoga/SQLite/Schema.purs index 06f6676..1ad77a5 100644 --- a/src/Yoga/SQLite/Schema.purs +++ b/src/Yoga/SQLite/Schema.purs @@ -10,7 +10,7 @@ import Data.DateTime (DateTime(..), date, time) import Data.JSDate as JSDate import Data.Maybe (Maybe(..), fromMaybe, maybe) import Data.Time (Time(..), hour, minute, second) -import Data.Newtype (class Newtype, un) +import Data.Newtype (class Newtype) import Data.Nullable (toNullable) import Data.UUID (UUID) import JS.BigInt (BigInt) @@ -43,7 +43,7 @@ import Prim.TypeError (class Fail, Beside, Text, Quote) import Record (get) as Record import Type.Proxy (Proxy(..)) import Type.RowList (class ListToRow) -import Yoga.JSON (class ReadForeign, readImpl, unsafeStringify) +import Yoga.JSON (class ReadForeign, readImpl, unsafeStringify, parseJSON) import Yoga.SQLite.SQLite as SQLite -- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ @@ -94,7 +94,9 @@ newtype Json = Json Foreign derive instance Newtype Json _ instance ReadForeign Json where - readImpl = pure <<< Json + readImpl f = do + s :: String <- readImpl f + Json <$> parseJSON s -- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ -- SQLUUID: newtype over Data.UUID.UUID (stored as TEXT in SQLite) @@ -318,7 +320,10 @@ instance IsSymbol dim => SQLiteTypeName (F32Vector dim) where instance IsSymbol dim => SQLiteTypeName (F64Vector dim) where sqliteTypeName _ = "F64_BLOB(" <> reflectSymbol (Proxy :: Proxy dim) <> ")" -instance SQLiteTypeName a => SQLiteTypeName (Maybe a) where +else instance SQLiteTypeName a => SQLiteTypeName (Maybe a) where + sqliteTypeName _ = sqliteTypeName (Proxy :: Proxy a) + +else instance SQLiteTypeName a => SQLiteTypeName (ForeignKey table references col a) where sqliteTypeName _ = sqliteTypeName (Proxy :: Proxy a) -- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ diff --git a/test/Main.purs b/test/Main.purs index c822030..d7e969b 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -8,7 +8,7 @@ import Data.Enum (toEnum) import Data.UUID as UUID import JS.BigInt as JS.BigInt import Data.Maybe (Maybe(..), fromJust, isNothing) -import Data.Newtype (un) +import Data.Newtype (class Newtype, un) import Data.Array as Array import Data.Tuple.Nested ((/\)) import Data.Time (Time(..)) @@ -27,6 +27,7 @@ import Test.Spec.Runner (runSpec) import Type.Function (type (#)) import Type.Proxy (Proxy(..)) import Test.Sqlite.TempDb (mkTempDbUrl) +import Yoga.JSON (class ReadForeign, readImpl, unsafeStringify) import Yoga.Test.Docker as Docker import Yoga.SQLite.SQLite as SQLite import Yoga.SQLite.Schema @@ -134,6 +135,34 @@ type NullableEverythingTable = Table "nullable_everything" , active :: Maybe SQLiteBool ) +newtype Code = Code String + +derive instance Newtype Code _ +derive newtype instance Eq Code +derive newtype instance Show Code + +instance SQLiteTypeName Code where + sqliteTypeName _ = "TEXT" + +instance ReadForeign Code where + readImpl = map Code <<< readImpl + +type CodesTable = Table "codes" + ( code :: Code # PrimaryKey + ) + +type LinkedCodesTable = Table "linked_codes" + ( id :: Int # PrimaryKey # AutoIncrement + , code :: ForeignKey "codes" References "code" Code + ) + +typedForeignKeyNewtypeSelectAll + :: Q _ + (code :: Code, id :: Int) + () + _ +typedForeignKeyNewtypeSelectAll = from (Proxy :: Proxy LinkedCodesTable) # selectAll + -- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ -- Type annotations prove correctness at compile time -- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ @@ -413,6 +442,10 @@ spec = before setupConn do let result = createTableDDL @ConfigTable result `shouldEqual` "CREATE TABLE config (active INTEGER NOT NULL DEFAULT 1, id INTEGER PRIMARY KEY AUTOINCREMENT, role TEXT NOT NULL DEFAULT 'user', score INTEGER NOT NULL DEFAULT 0)" + it "uses wrapped SQLite type names inside ForeignKey" \_ -> do + let result = createTableDDL @LinkedCodesTable + result `shouldEqual` "CREATE TABLE linked_codes (code TEXT NOT NULL REFERENCES codes(code), id INTEGER PRIMARY KEY AUTOINCREMENT)" + describe "SQL builder output" do it "SELECT *" \_ -> do toSQL typedSelectAll `shouldEqual` "SELECT * FROM users" @@ -793,6 +826,9 @@ spec = before setupConn do it "RandomRowId insert excludes id" \_ -> do toSQL typedRandomRowIdInsert `shouldEqual` "INSERT INTO things (name) VALUES (?1)" + it "ForeignKey wrapped newtype survives selectAll typing" \_ -> do + toSQL typedForeignKeyNewtypeSelectAll `shouldEqual` "SELECT * FROM linked_codes" + describe "Edge cases" do it "Maybe Just as SQLiteValue passes the inner value" \conn -> do SQLite.executeSimple (SQLite.SQL (createTableDDL @UsersTable)) conn # void @@ -1202,12 +1238,23 @@ spec = before setupConn do let dts = map (_.created_at) (rows :: Array { created_at :: DateTime }) dts `shouldEqual` [dt] + it "ForeignKey newtype round-trips without wrapper workaround" \conn -> do + SQLite.executeSimple (SQLite.SQL (createTableDDL @CodesTable)) conn # void + SQLite.executeSimple (SQLite.SQL (createTableDDL @LinkedCodesTable)) conn # void + runExecute conn {} (from (Proxy :: Proxy CodesTable) # insert { code: Code "alpha" }) # void + runExecute conn {} (from (Proxy :: Proxy LinkedCodesTable) # insert { code: Code "alpha" }) # void + rows <- runQuery conn {} (from (Proxy :: Proxy LinkedCodesTable) # select @"code") + let codes = map (_.code) (rows :: Array { code :: Code }) + codes `shouldEqual` [Code "alpha"] + it "Json round-trip with nested object" \conn -> do SQLite.executeSimple (SQLite.SQL (createTableDDL @EventsTable)) conn # void let obj = unsafeToForeign { key: "value", nested: { a: 1 } } runExecute conn {} (from eventsTable # insert { title: "test", metadata: Json obj, created_at: mkDateTime 2024 1 1 0 0 0 }) # void rows <- runQuery conn {} (from eventsTable # select @"metadata") Array.length (rows :: Array { metadata :: Json }) `shouldEqual` 1 + let Json f = unsafePartial $ fromJust $ Array.head (map _.metadata rows) + unsafeStringify f `shouldEqual` unsafeStringify obj it "onConflictDoNothing does not insert duplicate" \conn -> do SQLite.executeSimple (SQLite.SQL (createTableDDL @UsersTable)) conn # void