From 2431d6a5b54df6a8339b46be9bd0224455ee1dd6 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Tue, 13 Aug 2024 21:22:04 +0300 Subject: [PATCH 01/65] Implement `inherits` for Schema.sql --- ihp-ide/IHP/IDE/SchemaDesigner/Parser.hs | 8 ++++++++ ihp-ide/IHP/IDE/SchemaDesigner/Types.hs | 1 + 2 files changed, 9 insertions(+) diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/Parser.hs b/ihp-ide/IHP/IDE/SchemaDesigner/Parser.hs index 753e0c21c..cb2ea0e7d 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/Parser.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/Parser.hs @@ -98,6 +98,8 @@ createTable = do columnsAndConstraints <- ((Right <$> parseTableConstraint) <|> (Left <$> parseColumn)) `sepBy` (char ',' >> space) pure (lefts columnsAndConstraints, rights columnsAndConstraints) + inherits <- optional parseInheritsClause + char ';' -- Check that either there is a single column with a PRIMARY KEY constraint, @@ -222,6 +224,12 @@ parseOnDelete = choice , (lexeme "CASCADE" >> pure Cascade) ] +parseInheritsClause :: Parser Text +parseInheritsClause = do + lexeme "INHERITS" + parentTable <- between (char '(' >> space) (char ')' >> space) qualifiedIdentifier + pure parentTable + parseColumn :: Parser (Bool, Column) parseColumn = do name <- identifier diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/Types.hs b/ihp-ide/IHP/IDE/SchemaDesigner/Types.hs index 1d9fbf465..ca6f5f774 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/Types.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/Types.hs @@ -85,6 +85,7 @@ data CreateTable , primaryKeyConstraint :: PrimaryKeyConstraint , constraints :: [Constraint] , unlogged :: !Bool + , inherits :: Maybe Text } deriving (Eq, Show) From 9bee88cea3e4c81308e5b41717cdf472d298c9ad Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Tue, 13 Aug 2024 21:24:01 +0300 Subject: [PATCH 02/65] Adapt `compileStatement` --- ihp-ide/IHP/IDE/SchemaDesigner/Compiler.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/Compiler.hs b/ihp-ide/IHP/IDE/SchemaDesigner/Compiler.hs index b05af3c59..5aace692a 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/Compiler.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/Compiler.hs @@ -22,7 +22,7 @@ compileSql statements = statements |> unlines compileStatement :: Statement -> Text -compileStatement (StatementCreateTable CreateTable { name, columns, primaryKeyConstraint, constraints, unlogged }) = "CREATE" <> (if unlogged then " UNLOGGED" else "") <> " TABLE " <> compileIdentifier name <> " (\n" <> intercalate ",\n" (map (\col -> " " <> compileColumn primaryKeyConstraint col) columns <> maybe [] ((:[]) . indent) (compilePrimaryKeyConstraint primaryKeyConstraint) <> map (indent . compileConstraint) constraints) <> "\n);" +compileStatement (StatementCreateTable CreateTable { name, columns, primaryKeyConstraint, constraints, unlogged, inherits }) = "CREATE" <> (if unlogged then " UNLOGGED" else "") <> " TABLE " <> compileIdentifier name <> " (\n" <> intercalate ",\n" (map (\col -> " " <> compileColumn primaryKeyConstraint col) columns <> maybe [] ((:[]) . indent) (compilePrimaryKeyConstraint primaryKeyConstraint) <> map (indent . compileConstraint) constraints) <> "\n)" <> maybe "" (\parentTable -> " INHERITS (" <> compileIdentifier parentTable <> ")") inherits <> ";" compileStatement CreateEnumType { name, values } = "CREATE TYPE " <> compileIdentifier name <> " AS ENUM (" <> intercalate ", " (values |> map TextExpression |> map compileExpression) <> ");" compileStatement CreateExtension { name, ifNotExists } = "CREATE EXTENSION " <> (if ifNotExists then "IF NOT EXISTS " else "") <> compileIdentifier name <> ";" compileStatement AddConstraint { tableName, constraint = UniqueConstraint { name = Nothing, columnNames } } = "ALTER TABLE " <> compileIdentifier tableName <> " ADD UNIQUE (" <> intercalate ", " columnNames <> ")" <> ";" From 2b71e5e046db1b6aaa0b34aa78717272c27a4597 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Tue, 13 Aug 2024 21:25:46 +0300 Subject: [PATCH 03/65] Add tests --- Test/IDE/SchemaDesigner/CompilerSpec.hs | 27 +++++++++++++++++++++---- 1 file changed, 23 insertions(+), 4 deletions(-) diff --git a/Test/IDE/SchemaDesigner/CompilerSpec.hs b/Test/IDE/SchemaDesigner/CompilerSpec.hs index 22a2f3bc4..137e01bf2 100644 --- a/Test/IDE/SchemaDesigner/CompilerSpec.hs +++ b/Test/IDE/SchemaDesigner/CompilerSpec.hs @@ -628,7 +628,7 @@ tests = do , indexType = Nothing } compileSql [statement] `shouldBe` sql - + it "should escape an index name inside a 'CREATE INDEX' statement" do let sql = cs [plain|CREATE INDEX "Some Index" ON "Some Table" ("Some Col");\n|] let statement = CreateIndex @@ -841,7 +841,7 @@ tests = do ) } compileSql [policy] `shouldBe` sql - + it "should compile 'CREATE POLICY' statements with a 'ihp_user_id() IS NOT NULL' expression" do -- https://github.com/digitallyinduced/ihp/issues/1412 let sql = "CREATE POLICY \"Users can manage tasks if logged in\" ON tasks USING (ihp_user_id() IS NOT NULL) WITH CHECK (ihp_user_id() IS NOT NULL);\n" @@ -1040,7 +1040,7 @@ tests = do it "should compile 'CREATE UNLOGGED TABLE' statements" do let sql = [trimming| CREATE UNLOGGED TABLE pg_large_notifications ( - + ); |] <> "\n" let statements = [ @@ -1067,4 +1067,23 @@ tests = do , check = Just (VarExpression "false") } ] - compileSql statements `shouldBe` sql \ No newline at end of file + compileSql statements `shouldBe` sql + + it "should compile a CREATE TABLE statement with INHERITS" do + let sql = "CREATE TABLE child_table (\n id UUID PRIMARY KEY\n) INHERITS (parent_table);\n" + let statement = StatementCreateTable CreateTable + { name = "child_table" + , columns = [Column + { name = "id" + , columnType = PUUID + , defaultValue = Nothing + , notNull = False + , isUnique = False + , generator = Nothing + }] + , primaryKeyConstraint = PrimaryKeyConstraint ["id"] + , constraints = [] + , unlogged = False + , inherits = Just "parent_table" + } + compileSql [statement] `shouldBe` sql From c1844ac19fb006e7d493f72fc38c53cc56f5c8f6 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Tue, 13 Aug 2024 21:35:40 +0300 Subject: [PATCH 04/65] Fix missing field --- ihp-ide/IHP/IDE/SchemaDesigner/Parser.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/Parser.hs b/ihp-ide/IHP/IDE/SchemaDesigner/Parser.hs index cb2ea0e7d..2fc9a439d 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/Parser.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/Parser.hs @@ -118,7 +118,7 @@ createTable = do _ -> Prelude.fail ("Primary key defined in both column and table constraints on table " <> cs name) _ -> Prelude.fail "Multiple columns with PRIMARY KEY constraint" - pure CreateTable { name, columns, primaryKeyConstraint, constraints, unlogged } + pure CreateTable { name, columns, primaryKeyConstraint, constraints, unlogged, inherits } createEnumType = do lexeme "CREATE" From 0578ae10245dca5fe2a141b3aef80575c24b7246 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Tue, 13 Aug 2024 21:41:02 +0300 Subject: [PATCH 05/65] Try to fix Running the development server --- CONTRIBUTING.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 37ac4d6a7..2a5ad6311 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -82,7 +82,7 @@ use `make console` to load your application together with the framework located ``` ghci -:l IHP/exe/IHP/IDE/DevServer.hs +:l IHP/ihp-ide/exe/IHP/IDE/DevServer.hs main ``` From bd1220dcc499ff48d8180a6678f7872a625c4cfb Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Tue, 13 Aug 2024 21:48:23 +0300 Subject: [PATCH 06/65] Test fixes --- Test/IDE/SchemaDesigner/ParserSpec.hs | 36 +++++++++++++++++++-------- 1 file changed, 26 insertions(+), 10 deletions(-) diff --git a/Test/IDE/SchemaDesigner/ParserSpec.hs b/Test/IDE/SchemaDesigner/ParserSpec.hs index e7b558022..0da6b9ae5 100644 --- a/Test/IDE/SchemaDesigner/ParserSpec.hs +++ b/Test/IDE/SchemaDesigner/ParserSpec.hs @@ -15,7 +15,7 @@ import GHC.IO (evaluate) tests = do describe "The Schema.sql Parser" do it "should parse an empty CREATE TABLE statement" do - parseSql "CREATE TABLE users ();" `shouldBe` StatementCreateTable CreateTable { name = "users", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False } + parseSql "CREATE TABLE users ();" `shouldBe` StatementCreateTable CreateTable { name = "users", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False, inherits = Nothing } it "should parse an CREATE EXTENSION for the UUID extension" do parseSql "CREATE EXTENSION IF NOT EXISTS \"uuid-ossp\";" `shouldBe` CreateExtension { name = "uuid-ossp", ifNotExists = True } @@ -114,6 +114,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } it "should parse a CREATE TABLE with a generated column" do @@ -146,13 +147,14 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } it "should parse a CREATE TABLE with quoted identifiers" do - parseSql "CREATE TABLE \"quoted name\" ();" `shouldBe` StatementCreateTable CreateTable { name = "quoted name", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False } + parseSql "CREATE TABLE \"quoted name\" ();" `shouldBe` StatementCreateTable CreateTable { name = "quoted name", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False, inherits = Nothing } it "should parse a CREATE TABLE with public schema prefix" do - parseSql "CREATE TABLE public.users ();" `shouldBe` StatementCreateTable CreateTable { name = "users", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False } + parseSql "CREATE TABLE public.users ();" `shouldBe` StatementCreateTable CreateTable { name = "users", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False, inherits = Nothing } it "should parse ALTER TABLE .. ADD FOREIGN KEY .. ON DELETE CASCADE" do parseSql "ALTER TABLE users ADD CONSTRAINT users_ref_company_id FOREIGN KEY (company_id) REFERENCES companies (id) ON DELETE CASCADE;" `shouldBe` AddConstraint @@ -513,6 +515,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } it "should parse a CREATE TABLE with TIMESTAMP WITH TIMEZONE / TIMESTAMPZ columns" do @@ -525,6 +528,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } it "should parse a CREATE TABLE with BOOLEAN / BOOL columns" do @@ -537,6 +541,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } it "should parse a CREATE TABLE with REAL, FLOAT4, DOUBLE, FLOAT8 columns" do @@ -551,6 +556,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } it "should parse a CREATE TABLE with (deprecated) NUMERIC, NUMERIC(x), NUMERIC (x,y), VARYING(n) columns" do @@ -565,6 +571,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } it "should parse a CREATE TABLE statement with a multi-column UNIQUE (a, b) constraint" do @@ -578,6 +585,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [ UniqueConstraint { name = Nothing, columnNames = [ "user_id", "follower_id" ] } ] , unlogged = False + , inherits = Nothing } it "should fail to parse a CREATE TABLE statement with an empty UNIQUE () constraint" do @@ -594,6 +602,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [ "user_id", "follower_id" ] , constraints = [] , unlogged = False + , inherits = Nothing } it "should fail to parse a CREATE TABLE statement with PRIMARY KEY column and table constraints" do @@ -611,6 +620,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } it "should parse a CREATE TABLE statement with a bigserial id" do @@ -620,6 +630,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } it "should parse a CREATE TABLE statement with an array column" do @@ -629,6 +640,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } it "should parse a CREATE TABLE statement with a point column" do @@ -638,6 +650,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } it "should parse a CREATE TABLE statement with a polygon column" do @@ -647,6 +660,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } it "should parse a CREATE INDEX statement" do @@ -805,14 +819,14 @@ $$; it "should parse a decimal default value with a type-cast" do let sql = "CREATE TABLE a(electricity_unit_price DOUBLE PRECISION DEFAULT 0.17::double precision NOT NULL);" let statements = - [ StatementCreateTable CreateTable { name = "a", columns = [Column {name = "electricity_unit_price", columnType = PDouble, defaultValue = Just (TypeCastExpression (DoubleExpression 0.17) PDouble), notNull = True, isUnique = False, generator = Nothing}], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False } + [ StatementCreateTable CreateTable { name = "a", columns = [Column {name = "electricity_unit_price", columnType = PDouble, defaultValue = Just (TypeCastExpression (DoubleExpression 0.17) PDouble), notNull = True, isUnique = False, generator = Nothing}], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False, inherits = Nothing } ] parseSqlStatements sql `shouldBe` statements it "should parse a integer default value" do let sql = "CREATE TABLE a(electricity_unit_price INT DEFAULT 0 NOT NULL);" let statements = - [ StatementCreateTable CreateTable { name = "a", columns = [Column {name = "electricity_unit_price", columnType = PInt, defaultValue = Just (IntExpression 0), notNull = True, isUnique = False, generator = Nothing}], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False } + [ StatementCreateTable CreateTable { name = "a", columns = [Column {name = "electricity_unit_price", columnType = PInt, defaultValue = Just (IntExpression 0), notNull = True, isUnique = False, generator = Nothing}], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False, inherits = Nothing } ] parseSqlStatements sql `shouldBe` statements @@ -900,7 +914,7 @@ $$; let sql = cs [plain| CREATE TABLE a(id UUID DEFAULT public.uuid_generate_v4() NOT NULL); |] - let statement = StatementCreateTable CreateTable { name = "a", columns = [Column {name = "id", columnType = PUUID, defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True, isUnique = False, generator = Nothing}], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False } + let statement = StatementCreateTable CreateTable { name = "a", columns = [Column {name = "id", columnType = PUUID, defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True, isUnique = False, generator = Nothing}], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False, inherits = Nothing } parseSql sql `shouldBe` statement @@ -924,6 +938,7 @@ $$; , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } parseSql sql `shouldBe` statement @@ -947,6 +962,7 @@ $$; , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } parseSql sql `shouldBe` statement it "should parse a pg_dump header" do @@ -1127,17 +1143,17 @@ COMMENT ON EXTENSION "uuid-ossp" IS 'generate universally unique identifiers (UU it "should parse 'COMMIT' statements" do let sql = cs [plain|COMMIT;|] parseSql sql `shouldBe` Commit - + it "should parse 'DROP FUNCTION ..' statements" do let sql = cs [plain|DROP FUNCTION my_function;|] parseSql sql `shouldBe` DropFunction { functionName = "my_function" } - + it "should parse 'CREATE TABLE ..' statements when the table name starts with public" do let sql = cs [plain|CREATE TABLE public_variables (id UUID);|] - parseSql sql `shouldBe` StatementCreateTable {unsafeGetCreateTable = CreateTable {name = "public_variables", columns = [Column {name = "id", columnType = PUUID, defaultValue = Nothing, notNull = False, isUnique = False, generator = Nothing}], primaryKeyConstraint = PrimaryKeyConstraint {primaryKeyColumnNames = []}, constraints = [], unlogged = False}} + parseSql sql `shouldBe` StatementCreateTable {unsafeGetCreateTable = CreateTable {name = "public_variables", columns = [Column {name = "id", columnType = PUUID, defaultValue = Nothing, notNull = False, isUnique = False, generator = Nothing}], primaryKeyConstraint = PrimaryKeyConstraint {primaryKeyColumnNames = []}, constraints = [], unlogged = False, inherits = Nothing}} it "should parse an 'CREATE UNLOGGED TABLE' statement" do - parseSql "CREATE UNLOGGED TABLE pg_large_notifications ();" `shouldBe` StatementCreateTable CreateTable { name = "pg_large_notifications", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = True } + parseSql "CREATE UNLOGGED TABLE pg_large_notifications ();" `shouldBe` StatementCreateTable CreateTable { name = "pg_large_notifications", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = True, inherits = Nothing } col :: Column From dc248f743a617780bae414809d69780664efbd5e Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Tue, 13 Aug 2024 22:30:14 +0300 Subject: [PATCH 07/65] Adjust docs --- CONTRIBUTING.md | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 2a5ad6311..6b667121a 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -78,10 +78,13 @@ Note that it takes around 30 minutes for the IHP GitHub actions to prepare a bin When making changes to the development tooling, we have to start the server differently, without `devenv up`. We have to -use `make console` to load your application together with the framework located in `IHP`. +use `ghci` to load your application together with the framework located in `IHP`. ``` ghci +-- Add the IHP/ihp-ide directory to the load path +:set -iIHP/ihp-ide +-- Load the development server :l IHP/ihp-ide/exe/IHP/IDE/DevServer.hs main ``` From 480d8f317e3c4b95473db3f3782d85810f1c9519 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Tue, 13 Aug 2024 22:33:27 +0300 Subject: [PATCH 08/65] Another missing field --- ihp-ide/IHP/IDE/SchemaDesigner/SchemaOperations.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/SchemaOperations.hs b/ihp-ide/IHP/IDE/SchemaDesigner/SchemaOperations.hs index c6ca53286..cf9be1403 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/SchemaOperations.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/SchemaOperations.hs @@ -30,6 +30,7 @@ addTable tableName list = list <> [StatementCreateTable CreateTable , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing }] @@ -472,11 +473,11 @@ updateTable tableId tableName statements = |> map \case (StatementCreateTable table@(CreateTable { name })) | name == oldTableName -> StatementCreateTable (table { name = tableName }) constraint@(AddConstraint { tableName = constraintTable, constraint = c }) | constraintTable == oldTableName -> (constraint :: Statement) { tableName, constraint = c { name = Text.replace oldTableName tableName <$> (c.name) } } - index@(CreateIndex { tableName = indexTable, indexName }) | indexTable == oldTableName -> (index :: Statement) { tableName, indexName = Text.replace oldTableName tableName indexName } + index@(CreateIndex { tableName = indexTable, indexName }) | indexTable == oldTableName -> (index :: Statement) { tableName, indexName = Text.replace oldTableName tableName indexName } rls@(EnableRowLevelSecurity { tableName = rlsTable }) | rlsTable == oldTableName -> (rls :: Statement) { tableName } policy@(CreatePolicy { tableName = policyTable, name }) | policyTable == oldTableName -> (policy :: Statement) { tableName, name = Text.replace oldTableName tableName name } trigger@(CreateTrigger { tableName = triggerTable, name }) | triggerTable == oldTableName -> (trigger :: Statement) { tableName, name = Text.replace oldTableName tableName name } - otherwise -> otherwise + otherwise -> otherwise updatedAtTriggerName :: Text -> Text @@ -512,7 +513,7 @@ addUpdatedAtTrigger tableName schema = |> isJust setUpdatedAtToNowTrigger :: Statement - setUpdatedAtToNowTrigger = + setUpdatedAtToNowTrigger = CreateFunction { functionName = "set_updated_at_to_now" , functionBody = "\n" <> [trimming| @@ -560,7 +561,7 @@ deleteColumn DeleteColumnOptions { .. } schema = deleteColumnInTable statement = statement deletePolicyReferencingPolicy :: Statement -> Bool - deletePolicyReferencingPolicy CreatePolicy { tableName = policyTable, using, check } | policyTable == tableName = + deletePolicyReferencingPolicy CreatePolicy { tableName = policyTable, using, check } | policyTable == tableName = case (using, check) of (Just using, Nothing) -> not (isRef using) (Nothing, Just check) -> not (isRef check) @@ -652,7 +653,7 @@ deleteIndex :: Text -> Schema -> Schema deleteIndex indexName statements = statements |> filter \case - CreateIndex { indexName = name } | name == indexName -> False + CreateIndex { indexName = name } | name == indexName -> False otherwise -> True From 3b9df347bc946ee2fe0f67ffaaf2ac15e0d2752e Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Wed, 14 Aug 2024 12:32:57 +0300 Subject: [PATCH 09/65] More test fixes --- .../SchemaDesigner/SchemaOperationsSpec.hs | 65 ++++++++++++------- Test/SchemaCompilerSpec.hs | 59 +++++++++-------- 2 files changed, 75 insertions(+), 49 deletions(-) diff --git a/Test/IDE/SchemaDesigner/SchemaOperationsSpec.hs b/Test/IDE/SchemaDesigner/SchemaOperationsSpec.hs index b4eff8b7b..8216bc1f8 100644 --- a/Test/IDE/SchemaDesigner/SchemaOperationsSpec.hs +++ b/Test/IDE/SchemaDesigner/SchemaOperationsSpec.hs @@ -9,8 +9,8 @@ import qualified Text.Megaparsec as Megaparsec tests = do describe "IHP.IDE.SchemaDesigner.SchemaOperations" do - let tableA = StatementCreateTable CreateTable { name = "a", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False } - let tableB = StatementCreateTable CreateTable { name = "b", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False } + let tableA = StatementCreateTable CreateTable { name = "a", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False, inherits = Nothing } + let tableB = StatementCreateTable CreateTable { name = "b", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False, inherits = Nothing } let enumA = CreateEnumType { name = "enumA", values = [] } let enumB = CreateEnumType { name = "enumB", values = [] } let comment = Comment { content = "comment" } @@ -27,7 +27,7 @@ tests = do let expectedSchema = [enumA, enumB, tableA] (SchemaOperations.addEnum "enumB" inputSchema) `shouldBe` expectedSchema - + it "should deal with the empty case" do let inputSchema = [] let expectedSchema = [enumA] @@ -46,38 +46,38 @@ tests = do let expectedSchema = [tableA, EnableRowLevelSecurity { tableName = "a"} ] (SchemaOperations.enableRowLevelSecurity "a" inputSchema) `shouldBe` expectedSchema - + it "should not do anything if already enabled" do let inputSchema = [tableA, EnableRowLevelSecurity { tableName = "a"} ] let expectedSchema = [tableA, EnableRowLevelSecurity { tableName = "a"} ] (SchemaOperations.enableRowLevelSecurity "a" inputSchema) `shouldBe` expectedSchema - + describe "disableRowLevelSecurity" do it "should disable row level security if enabled" do let inputSchema = [tableA, EnableRowLevelSecurity { tableName = "a"}] let expectedSchema = [tableA] (SchemaOperations.disableRowLevelSecurity "a" inputSchema) `shouldBe` expectedSchema - + it "should not do anything if the row level security is not enabled" do let inputSchema = [tableA] let expectedSchema = [tableA] (SchemaOperations.disableRowLevelSecurity "a" inputSchema) `shouldBe` expectedSchema - + describe "disableRowLevelSecurityIfNoPolicies" do it "should disable row level security if there's no policy" do let inputSchema = [tableA, EnableRowLevelSecurity { tableName = "a"}] let expectedSchema = [tableA] (SchemaOperations.disableRowLevelSecurityIfNoPolicies "a" inputSchema) `shouldBe` expectedSchema - + it "should not do anything if the row level security is not enabled" do let inputSchema = [tableA] (SchemaOperations.disableRowLevelSecurityIfNoPolicies "a" inputSchema) `shouldBe` inputSchema - + it "should not do anything if there's a policy" do let policy = CreatePolicy { tableName = "a", action = Nothing, name = "p", check = Nothing, using = Nothing } let inputSchema = [tableA, EnableRowLevelSecurity { tableName = "a"}, policy] @@ -112,6 +112,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let schema = [table] let expectedPolicy = CreatePolicy @@ -134,6 +135,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let schema = [table] let expectedPolicy = CreatePolicy @@ -155,6 +157,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let taskListsTable = StatementCreateTable CreateTable { name = "task_lists" @@ -164,6 +167,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let schema = [ tasksTable @@ -198,11 +202,12 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let index = CreateIndex { indexName = "a_created_at_index", unique = False, tableName = "a", columns = [IndexColumn { column = VarExpression "created_at", columnOrder = [] }], whereClause = Nothing, indexType = Nothing } let expectedSchema = [tableAWithCreatedAt, index] - + let options = SchemaOperations.AddColumnOptions { tableName = "a" , columnName = "created_at" @@ -219,7 +224,7 @@ tests = do } (SchemaOperations.addColumn options inputSchema) `shouldBe` expectedSchema - + it "should add a trigger to updated_at columns" do let inputSchema = [tableA] @@ -238,6 +243,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let function = CreateFunction @@ -260,7 +266,7 @@ tests = do } let expectedSchema = [function, tableAWithCreatedAt, trigger] - + let options = SchemaOperations.AddColumnOptions { tableName = "a" , columnName = "updated_at" @@ -277,7 +283,7 @@ tests = do } (SchemaOperations.addColumn options inputSchema) `shouldBe` expectedSchema - + it "should add a policy if autoPolicy = true" do let inputSchema = [tableA] @@ -296,6 +302,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let index = CreateIndex @@ -322,7 +329,7 @@ tests = do } let expectedSchema = [tableAWithCreatedAt, index, constraint, enableRLS, policy] - + let options = SchemaOperations.AddColumnOptions { tableName = "a" , columnName = "user_id" @@ -357,12 +364,13 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let index = CreateIndex { indexName = "a_created_at_index", unique = False, tableName = "a", columns = [IndexColumn { column = VarExpression "created_at", columnOrder = [] }], whereClause = Nothing, indexType = Nothing } let inputSchema = [tableAWithCreatedAt, index] let expectedSchema = [tableA] - + let options = SchemaOperations.DeleteColumnOptions { tableName = "a" , columnName = "created_at" @@ -370,7 +378,7 @@ tests = do } (SchemaOperations.deleteColumn options inputSchema) `shouldBe` expectedSchema - + it "should delete a updated_at trigger" do let tableAWithCreatedAt = StatementCreateTable CreateTable { name = "a" @@ -387,6 +395,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let function = CreateFunction @@ -410,7 +419,7 @@ tests = do let inputSchema = [function, tableAWithCreatedAt, trigger] let expectedSchema = [function, tableA] - + let options = SchemaOperations.DeleteColumnOptions { tableName = "a" , columnName = "updated_at" @@ -418,7 +427,7 @@ tests = do } (SchemaOperations.deleteColumn options inputSchema) `shouldBe` expectedSchema - + it "should delete an referenced policy" do let tableAWithUserId = StatementCreateTable CreateTable { name = "a" @@ -435,12 +444,13 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let policy = CreatePolicy { name = "a_policy", tableName = "a", action = Nothing, using = Just (EqExpression (VarExpression "user_id") (CallExpression "ihp_user_id" [])), check = Nothing } let inputSchema = [tableAWithUserId, policy] let expectedSchema = [tableA] - + let options = SchemaOperations.DeleteColumnOptions { tableName = "a" , columnName = "user_id" @@ -465,6 +475,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let tableAWithUpdatedColumn = StatementCreateTable CreateTable @@ -482,11 +493,12 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let inputSchema = [tableAWithCreatedAt] let expectedSchema = [tableAWithUpdatedColumn] - + let options = SchemaOperations.UpdateColumnOptions { tableName = "a" , columnName = "created_at2" @@ -516,6 +528,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } let tableWithoutPK = StatementCreateTable CreateTable @@ -533,11 +546,12 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let inputSchema = [tableWithoutPK] let expectedSchema = [tableWithPK] - + let options = SchemaOperations.UpdateColumnOptions { tableName = "a" , columnName = "id2" @@ -560,6 +574,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let taskListsTable = StatementCreateTable CreateTable { name = "task_lists" @@ -569,6 +584,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let inputSchema = [ tasksTable @@ -584,13 +600,14 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let expectedSchema = [ tasksTable' , taskListsTable , AddConstraint { tableName = "tasks", constraint = ForeignKeyConstraint { name = "tasks_ref_task_lists", columnName = "list_id", referenceTable = "task_lists", referenceColumn = Nothing, onDelete = Nothing }, deferrable = Nothing, deferrableType = Nothing } ] - + let options = SchemaOperations.UpdateColumnOptions { tableName = "tasks" , columnName = "list_id" @@ -620,6 +637,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let index = CreateIndex { indexName = "a_updated_at_index", unique = False, tableName = "a", columns = [IndexColumn { column = VarExpression "updated_at", columnOrder = [] }], whereClause = Nothing, indexType = Nothing } @@ -638,12 +656,13 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } let indexUpdated = CreateIndex { indexName = "a_created_at_index", unique = False, tableName = "a", columns = [IndexColumn { column = VarExpression "created_at", columnOrder = [] }], whereClause = Nothing, indexType = Nothing } let inputSchema = [tableAWithCreatedAt, index] let expectedSchema = [tableAWithUpdatedColumn, indexUpdated] - + let options = SchemaOperations.UpdateColumnOptions { tableName = "a" , columnName = "created_at" diff --git a/Test/SchemaCompilerSpec.hs b/Test/SchemaCompilerSpec.hs index 02c4d7ff5..0f6f86d3f 100644 --- a/Test/SchemaCompilerSpec.hs +++ b/Test/SchemaCompilerSpec.hs @@ -119,12 +119,13 @@ tests = do instance IHP.Controller.Param.ParamReader PropertyType where readParameter = IHP.Controller.Param.enumParamReader; readParameterJSON = IHP.Controller.Param.enumParamReaderJSON |] describe "compileCreate" do - let statement = StatementCreateTable $ CreateTable { - name = "users", - columns = [ Column "id" PUUID Nothing False False Nothing ], - primaryKeyConstraint = PrimaryKeyConstraint ["id"], - constraints = [], - unlogged = False + let statement = StatementCreateTable $ CreateTable + { name = "users", + , columns = [ Column "id" PUUID Nothing False False Nothing ] + , primaryKeyConstraint = PrimaryKeyConstraint ["id"] + , constraints = [] + , unlogged = False + , inherits = Nothing } let compileOutput = compileStatementPreview [statement] statement |> Text.strip @@ -151,13 +152,14 @@ tests = do |] it "should compile CanUpdate instance with an array type with an explicit cast" do - let statement = StatementCreateTable $ CreateTable { - name = "users", - columns = [ Column "id" PUUID Nothing True True Nothing, Column "ids" (PArray PUUID) Nothing False False Nothing], - primaryKeyConstraint = PrimaryKeyConstraint ["id"], - constraints = [] + let statement = StatementCreateTable $ CreateTable + { name = "users" + , columns = [ Column "id" PUUID Nothing True True Nothing, Column "ids" (PArray PUUID) Nothing False False Nothing] + , primaryKeyConstraint = PrimaryKeyConstraint ["id"] + , constraints = [] , unlogged = False - } + , inherits = Nothing + } let compileOutput = compileStatementPreview [statement] statement |> Text.strip getInstanceDecl "CanUpdate" compileOutput `shouldBe` [trimming| @@ -177,6 +179,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } let compileOutput = compileStatementPreview [statement] statement |> Text.strip @@ -185,7 +188,7 @@ tests = do type instance PrimaryKey "users" = UUID - type User = User' + type User = User' type instance GetTableName (User' ) = "users" type instance GetModelByTableName "users" = User @@ -252,6 +255,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } let compileOutput = compileStatementPreview [statement] statement |> Text.strip @@ -260,7 +264,7 @@ tests = do type instance PrimaryKey "users" = UUID - type User = User' + type User = User' type instance GetTableName (User' ) = "users" type instance GetModelByTableName "users" = User @@ -327,6 +331,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } let compileOutput = compileStatementPreview [statement] statement |> Text.strip @@ -335,7 +340,7 @@ tests = do type instance PrimaryKey "users" = UUID - type User = User' + type User = User' type instance GetTableName (User' ) = "users" type instance GetModelByTableName "users" = User @@ -415,7 +420,7 @@ tests = do data LandingPage' paragraphCtasLandingPages paragraphCtasToLandingPages = LandingPage {id :: (Id' "landing_pages"), paragraphCtasLandingPages :: paragraphCtasLandingPages, paragraphCtasToLandingPages :: paragraphCtasToLandingPages, meta :: MetaBag} deriving (Eq, Show) type instance PrimaryKey "landing_pages" = UUID - + type LandingPage = LandingPage' (QueryBuilder.QueryBuilder "paragraph_ctas") (QueryBuilder.QueryBuilder "paragraph_ctas") type instance GetTableName (LandingPage' _ _) = "landing_pages" @@ -481,6 +486,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } let compileOutput = compileStatementPreview [statement] statement |> Text.strip @@ -513,7 +519,7 @@ tests = do isTargetTable otherwise = False let (Just statement) = find isTargetTable statements let compileOutput = compileStatementPreview statements statement |> Text.strip - + it "should compile CanCreate instance with sqlQuery" $ \statement -> do getInstanceDecl "CanCreate" compileOutput `shouldBe` [trimming| instance CanCreate Thing where @@ -582,7 +588,7 @@ tests = do isNamedTable _ _ = False let (Just statement) = find (isNamedTable "bit_part_refs") statements let compileOutput = compileStatementPreview statements statement |> Text.strip - + it "should compile CanCreate instance with sqlQuery" $ \statement -> do getInstanceDecl "CanCreate" compileOutput `shouldBe` [trimming| instance CanCreate BitPartRef where @@ -642,15 +648,16 @@ tests = do |] describe "compileFilterPrimaryKeyInstance" do it "should compile FilterPrimaryKey instance when primary key is called id" do - let statement = StatementCreateTable $ CreateTable { - name = "things", - columns = [ Column "id" PUUID Nothing True True Nothing ], - primaryKeyConstraint = PrimaryKeyConstraint ["id"], - constraints = [], - unlogged = False - } + let statement = StatementCreateTable $ CreateTable + { name = "things", + , columns = [ Column "id" PUUID Nothing True True Nothing ] + , primaryKeyConstraint = PrimaryKeyConstraint ["id"] + , constraints = [] + , unlogged = False + , inherits = Nothing + } let compileOutput = compileStatementPreview [statement] statement |> Text.strip - + getInstanceDecl "QueryBuilder.FilterPrimaryKey" compileOutput `shouldBe` [trimming| instance QueryBuilder.FilterPrimaryKey "things" where filterWhereId id builder = From 518811aa548269b6d37af3f72aff4ea9a4d3ba9e Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Wed, 14 Aug 2024 12:34:34 +0300 Subject: [PATCH 10/65] More test fixes --- Test/IDE/SchemaDesigner/CompilerSpec.hs | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/Test/IDE/SchemaDesigner/CompilerSpec.hs b/Test/IDE/SchemaDesigner/CompilerSpec.hs index 137e01bf2..fa37d43e3 100644 --- a/Test/IDE/SchemaDesigner/CompilerSpec.hs +++ b/Test/IDE/SchemaDesigner/CompilerSpec.hs @@ -15,7 +15,7 @@ import Test.IDE.SchemaDesigner.ParserSpec (col, parseSql) tests = do describe "The Schema.sql Compiler" do it "should compile an empty CREATE TABLE statement" do - compileSql [StatementCreateTable CreateTable { name = "users", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False }] `shouldBe` "CREATE TABLE users (\n\n);\n" + compileSql [StatementCreateTable CreateTable { name = "users", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False, inherits = Nothing }] `shouldBe` "CREATE TABLE users (\n\n);\n" it "should compile a CREATE EXTENSION for the UUID extension" do compileSql [CreateExtension { name = "uuid-ossp", ifNotExists = True }] `shouldBe` "CREATE EXTENSION IF NOT EXISTS \"uuid-ossp\";\n" @@ -109,11 +109,12 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } compileSql [statement] `shouldBe` sql it "should compile a CREATE TABLE with quoted identifiers" do - compileSql [StatementCreateTable CreateTable { name = "quoted name", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False }] `shouldBe` "CREATE TABLE \"quoted name\" (\n\n);\n" + compileSql [StatementCreateTable CreateTable { name = "quoted name", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False, inherits = Nothing }] `shouldBe` "CREATE TABLE \"quoted name\" (\n\n);\n" it "should compile ALTER TABLE .. ADD FOREIGN KEY .. ON DELETE CASCADE" do let statement = AddConstraint @@ -478,6 +479,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } compileSql [statement] `shouldBe` sql @@ -530,6 +532,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } compileSql [statement] `shouldBe` sql @@ -545,6 +548,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [ UniqueConstraint { name = Nothing, columnNames = [ "user_id", "follower_id" ] } ] , unlogged = False + , inherits = Nothing } compileSql [statement] `shouldBe` sql @@ -556,6 +560,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } compileSql [statement] `shouldBe` sql @@ -567,6 +572,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } compileSql [statement] `shouldBe` sql @@ -581,6 +587,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["order_id", "truck_id"] , constraints = [] , unlogged = False + , inherits = Nothing } compileSql [statement] `shouldBe` sql @@ -592,6 +599,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } compileSql [statement] `shouldBe` sql @@ -603,6 +611,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } compileSql [statement] `shouldBe` sql @@ -614,6 +623,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } compileSql [statement] `shouldBe` sql @@ -787,12 +797,12 @@ tests = do it "should compile a decimal default value with a type-cast" do let sql = "CREATE TABLE a (\n electricity_unit_price DOUBLE PRECISION DEFAULT 0.17::DOUBLE PRECISION NOT NULL\n);\n" - let statement = StatementCreateTable CreateTable { name = "a", columns = [Column {name = "electricity_unit_price", columnType = PDouble, defaultValue = Just (TypeCastExpression (DoubleExpression 0.17) PDouble), notNull = True, isUnique = False, generator = Nothing}], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False } + let statement = StatementCreateTable CreateTable { name = "a", columns = [Column {name = "electricity_unit_price", columnType = PDouble, defaultValue = Just (TypeCastExpression (DoubleExpression 0.17) PDouble), notNull = True, isUnique = False, generator = Nothing}], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False, inherits = Nothing } compileSql [statement] `shouldBe` sql it "should compile a integer default value" do let sql = "CREATE TABLE a (\n electricity_unit_price INT DEFAULT 0 NOT NULL\n);\n" - let statement = StatementCreateTable CreateTable { name = "a", columns = [Column {name = "electricity_unit_price", columnType = PInt, defaultValue = Just (IntExpression 0), notNull = True, isUnique = False, generator = Nothing}], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False } + let statement = StatementCreateTable CreateTable { name = "a", columns = [Column {name = "electricity_unit_price", columnType = PInt, defaultValue = Just (IntExpression 0), notNull = True, isUnique = False, generator = Nothing}], primaryKeyConstraint = PrimaryKeyConstraint [], constraints = [], unlogged = False, inherits = Nothing } compileSql [statement] `shouldBe` sql it "should compile a partial index" do @@ -1030,6 +1040,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } ] compileSql statements `shouldBe` sql From 70c7e71a19d34f31bf91e3e1a3ade648fb5145f1 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Wed, 14 Aug 2024 12:37:16 +0300 Subject: [PATCH 11/65] More fixes --- Test/IDE/CodeGeneration/ControllerGenerator.hs | 2 ++ Test/IDE/CodeGeneration/MailGenerator.hs | 1 + Test/IDE/CodeGeneration/ViewGenerator.hs | 1 + Test/IDE/SchemaDesigner/Controller/HelperSpec.hs | 4 ++-- 4 files changed, 6 insertions(+), 2 deletions(-) diff --git a/Test/IDE/CodeGeneration/ControllerGenerator.hs b/Test/IDE/CodeGeneration/ControllerGenerator.hs index 910bf5278..d064afaac 100644 --- a/Test/IDE/CodeGeneration/ControllerGenerator.hs +++ b/Test/IDE/CodeGeneration/ControllerGenerator.hs @@ -31,6 +31,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing }, StatementCreateTable CreateTable { name = "people" @@ -65,6 +66,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } ] diff --git a/Test/IDE/CodeGeneration/MailGenerator.hs b/Test/IDE/CodeGeneration/MailGenerator.hs index cba2cd72d..a26a77423 100644 --- a/Test/IDE/CodeGeneration/MailGenerator.hs +++ b/Test/IDE/CodeGeneration/MailGenerator.hs @@ -32,6 +32,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } ] it "should build a mail with name \"PurchaseConfirmationMail\"" do diff --git a/Test/IDE/CodeGeneration/ViewGenerator.hs b/Test/IDE/CodeGeneration/ViewGenerator.hs index c229172f9..a2adbeabb 100644 --- a/Test/IDE/CodeGeneration/ViewGenerator.hs +++ b/Test/IDE/CodeGeneration/ViewGenerator.hs @@ -32,6 +32,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } ] it "should build a view with name \"EditView\"" do diff --git a/Test/IDE/SchemaDesigner/Controller/HelperSpec.hs b/Test/IDE/SchemaDesigner/Controller/HelperSpec.hs index f9d9c05d0..8b946977d 100644 --- a/Test/IDE/SchemaDesigner/Controller/HelperSpec.hs +++ b/Test/IDE/SchemaDesigner/Controller/HelperSpec.hs @@ -14,14 +14,14 @@ tests = do getAllObjectNames [ CreateExtension { name ="a", ifNotExists = True } ] `shouldBe` [] getAllObjectNames [ CreateEnumType { name = "first_enum", values=["a", "b", "c"] }] `shouldBe` ["first_enum"] getAllObjectNames [ StatementCreateTable CreateTable - { name = "table_name", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints=[], unlogged = False } + { name = "table_name", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints=[], unlogged = False, inherits = Nothing } ] `shouldBe` ["table_name"] getAllObjectNames [ CreateEnumType {name = "first_enum", values = ["a", "b"]} , CreateExtension {name = "extension", ifNotExists = True} , StatementCreateTable CreateTable - { name = "table_name", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints=[], unlogged = False } + { name = "table_name", columns = [], primaryKeyConstraint = PrimaryKeyConstraint [], constraints=[], unlogged = False, inherits = Nothing } , CreateEnumType {name = "second_enum", values = []} ] `shouldBe` ["first_enum","table_name","second_enum"] From 19c80b3d056add5e6aafb63d40f36752ab36011c Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Wed, 14 Aug 2024 12:54:32 +0300 Subject: [PATCH 12/65] CompilerSpec fixes --- Test/IDE/SchemaDesigner/CompilerSpec.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Test/IDE/SchemaDesigner/CompilerSpec.hs b/Test/IDE/SchemaDesigner/CompilerSpec.hs index fa37d43e3..962965fa3 100644 --- a/Test/IDE/SchemaDesigner/CompilerSpec.hs +++ b/Test/IDE/SchemaDesigner/CompilerSpec.hs @@ -1058,9 +1058,10 @@ tests = do StatementCreateTable CreateTable { name = "pg_large_notifications" , columns = [] + , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = True - , primaryKeyConstraint = PrimaryKeyConstraint [] + , inherits = Nothing } ] compileSql statements `shouldBe` sql From ec978c9224a4bc1fbc48a4430af113273ac00caf Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Wed, 14 Aug 2024 13:07:54 +0300 Subject: [PATCH 13/65] Fix typo --- Test/SchemaCompilerSpec.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/Test/SchemaCompilerSpec.hs b/Test/SchemaCompilerSpec.hs index 0f6f86d3f..8f1dfc8a5 100644 --- a/Test/SchemaCompilerSpec.hs +++ b/Test/SchemaCompilerSpec.hs @@ -120,13 +120,13 @@ tests = do |] describe "compileCreate" do let statement = StatementCreateTable $ CreateTable - { name = "users", - , columns = [ Column "id" PUUID Nothing False False Nothing ] - , primaryKeyConstraint = PrimaryKeyConstraint ["id"] - , constraints = [] - , unlogged = False - , inherits = Nothing - } + { name = "users" + , columns = [ Column "id" PUUID Nothing False False Nothing ] + , primaryKeyConstraint = PrimaryKeyConstraint ["id"] + , constraints = [] + , unlogged = False + , inherits = Nothing + } let compileOutput = compileStatementPreview [statement] statement |> Text.strip it "should compile CanCreate instance with sqlQuery" $ \statement -> do From 1fd95fec956d9d8d60640340a9567ebd82339a0d Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Wed, 14 Aug 2024 13:11:14 +0300 Subject: [PATCH 14/65] Fix tests --- Test/SchemaCompilerSpec.hs | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/Test/SchemaCompilerSpec.hs b/Test/SchemaCompilerSpec.hs index 8f1dfc8a5..c80884f53 100644 --- a/Test/SchemaCompilerSpec.hs +++ b/Test/SchemaCompilerSpec.hs @@ -152,14 +152,15 @@ tests = do |] it "should compile CanUpdate instance with an array type with an explicit cast" do - let statement = StatementCreateTable $ CreateTable - { name = "users" - , columns = [ Column "id" PUUID Nothing True True Nothing, Column "ids" (PArray PUUID) Nothing False False Nothing] - , primaryKeyConstraint = PrimaryKeyConstraint ["id"] - , constraints = [] + let statement = StatementCreateTable $ CreateTable { + name = "users", + columns = [ Column "id" PUUID Nothing True True Nothing, Column "ids" (PArray PUUID) Nothing False False Nothing], + primaryKeyConstraint = PrimaryKeyConstraint ["id"], + constraints = [] , unlogged = False , inherits = Nothing - } + } + let compileOutput = compileStatementPreview [statement] statement |> Text.strip getInstanceDecl "CanUpdate" compileOutput `shouldBe` [trimming| @@ -648,14 +649,14 @@ tests = do |] describe "compileFilterPrimaryKeyInstance" do it "should compile FilterPrimaryKey instance when primary key is called id" do - let statement = StatementCreateTable $ CreateTable - { name = "things", - , columns = [ Column "id" PUUID Nothing True True Nothing ] - , primaryKeyConstraint = PrimaryKeyConstraint ["id"] - , constraints = [] - , unlogged = False - , inherits = Nothing - } + let statement = StatementCreateTable $ CreateTable { + name = "things", + columns = [ Column "id" PUUID Nothing True True Nothing ], + primaryKeyConstraint = PrimaryKeyConstraint ["id"], + constraints = [], + unlogged = False, + inherits = Nothing + } let compileOutput = compileStatementPreview [statement] statement |> Text.strip getInstanceDecl "QueryBuilder.FilterPrimaryKey" compileOutput `shouldBe` [trimming| From 591c40f299dcb35211f764b83cd66d43de76eaf1 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Wed, 14 Aug 2024 13:36:29 +0300 Subject: [PATCH 15/65] Replace space in compilerSpec --- Test/SchemaCompilerSpec.hs | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/Test/SchemaCompilerSpec.hs b/Test/SchemaCompilerSpec.hs index c80884f53..48d2363f6 100644 --- a/Test/SchemaCompilerSpec.hs +++ b/Test/SchemaCompilerSpec.hs @@ -184,12 +184,12 @@ tests = do } let compileOutput = compileStatementPreview [statement] statement |> Text.strip - compileOutput `shouldBe` [trimming| + compileOutput `shouldBe` ([trimming| data User' = User {id :: (Id' "users"), ids :: (Maybe [UUID]), electricityUnitPrice :: Double, meta :: MetaBag} deriving (Eq, Show) type instance PrimaryKey "users" = UUID - type User = User' + type User = User'U+0020 type instance GetTableName (User' ) = "users" type instance GetModelByTableName "users" = User @@ -246,6 +246,10 @@ tests = do builder |> QueryBuilder.filterWhere (#id, id) {-# INLINE filterWhereId #-} |] + -- Replace `U+0020` with a space. + |> Text.replace "U+0020" " ") + + it "should deal with integer default values for double columns" do let statement = StatementCreateTable CreateTable { name = "users" @@ -336,12 +340,12 @@ tests = do } let compileOutput = compileStatementPreview [statement] statement |> Text.strip - compileOutput `shouldBe` [trimming| + compileOutput `shouldBe` ([trimming| data User' = User {id :: (Id' "users"), ts :: (Maybe TSVector), meta :: MetaBag} deriving (Eq, Show) type instance PrimaryKey "users" = UUID - type User = User' + type User = User'U+0020 type instance GetTableName (User' ) = "users" type instance GetModelByTableName "users" = User @@ -397,6 +401,9 @@ tests = do builder |> QueryBuilder.filterWhere (#id, id) {-# INLINE filterWhereId #-} |] + -- Replace `U+0020` with a space. + |> Text.replace "U+0020" " ") + it "should deal with multiple has many relationships to the same table" do let statements = parseSqlStatements [trimming| CREATE TABLE landing_pages ( From cbea5de35e534a2ae41dcf958b88297ed4e7f4b3 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Wed, 14 Aug 2024 13:38:12 +0300 Subject: [PATCH 16/65] Another fix --- Test/SchemaCompilerSpec.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/Test/SchemaCompilerSpec.hs b/Test/SchemaCompilerSpec.hs index 48d2363f6..c60bf92b6 100644 --- a/Test/SchemaCompilerSpec.hs +++ b/Test/SchemaCompilerSpec.hs @@ -264,12 +264,12 @@ tests = do } let compileOutput = compileStatementPreview [statement] statement |> Text.strip - compileOutput `shouldBe` [trimming| + compileOutput `shouldBe` ([trimming| data User' = User {id :: (Id' "users"), ids :: (Maybe [UUID]), electricityUnitPrice :: Double, meta :: MetaBag} deriving (Eq, Show) type instance PrimaryKey "users" = UUID - type User = User' + type User = User'U+0020 type instance GetTableName (User' ) = "users" type instance GetModelByTableName "users" = User @@ -326,6 +326,9 @@ tests = do builder |> QueryBuilder.filterWhere (#id, id) {-# INLINE filterWhereId #-} |] + -- Replace `U+0020` with a space. + |> Text.replace "U+0020" " ") + it "should not touch GENERATED columns" do let statement = StatementCreateTable CreateTable { name = "users" From 53e7085fbd2bdabc9ea2a62371b8682705880461 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Wed, 14 Aug 2024 19:58:53 +0300 Subject: [PATCH 17/65] Update SchemaCompiler --- ihp-ide/IHP/SchemaCompiler.hs | 112 ++++++++++++++++++++-------------- 1 file changed, 66 insertions(+), 46 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 31237b3c8..02f6573a9 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -336,20 +336,39 @@ primaryKeyTypeName :: Text -> Text primaryKeyTypeName name = "Id' " <> tshow name <> "" compileData :: (?schema :: Schema) => CreateTable -> Text -compileData table@(CreateTable { name, columns }) = - "data " <> modelName <> "' " <> typeArguments - <> " = " <> modelName <> " {" +compileData table@(CreateTable { name, inherits }) = + "data " <> modelName <> "' " <> typeArguments <> " = " <> modelName <> " {" + <> + parentFields <> - table - |> dataFields - |> map (\(fieldName, fieldType) -> fieldName <> " :: " <> fieldType) - |> commaSep - <> "} deriving (Eq, Show)\n" + table + |> dataFields + |> map (\(fieldName, fieldType) -> fieldName <> " :: " <> fieldType) + |> commaSep + <> "} deriving (Eq, Show)\n" where modelName = tableNameToModelName name typeArguments :: Text typeArguments = dataTypeArguments table |> unwords + -- Include fields from parent tables + parentFields = inherits + |> maybe "" (\parentTable -> compileParentFields parentTable) + |> (<> ", ") + + compileParentFields parentTable = + let parentTableDef = findTableByName parentTable + in parentTableDef + |> maybe [] (dataFields . (.unsafeGetCreateTable)) + |> map (\(fieldName, fieldType) -> fieldName <> " :: " <> fieldType) + |> commaSep + + findTableByName tableName = ?schema.statements + |> find (\case + StatementCreateTable CreateTable { name } | name == tableName -> True + _ -> False) + + compileInputValueInstance :: CreateTable -> Text compileInputValueInstance table = "instance InputValue " <> modelName <> " where inputValue = IHP.ModelSupport.recordToInputValue\n" @@ -642,19 +661,54 @@ compileUpdate table@(CreateTable { name, columns }) = ) compileFromRowInstance :: (?schema :: Schema) => CreateTable -> Text -compileFromRowInstance table@(CreateTable { name, columns }) = cs [i| +compileFromRowInstance table@(CreateTable { name, columns, inherits }) = cs [i| instance FromRow #{modelName} where fromRow = do -#{unsafeInit . indent . indent . unlines $ map columnBinding columnNames} +#{unsafeInit . indent . indent . unlines $ map columnBinding allColumnNames} let theRecord = #{modelName} #{intercalate " " (map compileField (dataFields table))} pure theRecord |] where modelName = tableNameToModelName name - columnNames = map (columnNameToFieldName . (.name)) columns + allColumns = gatherColumns table + allColumnNames = map (columnNameToFieldName . (.name)) allColumns + + columnBinding :: Text -> Text columnBinding columnName = columnName <> " <- field" + -- Recursively gather columns from the current table and all parent tables + gatherColumns :: CreateTable -> [Column] + gatherColumns CreateTable { columns, inherits = Nothing } = columns + gatherColumns CreateTable { columns, inherits = Just parentTableName } = + let parentColumns = findParentColumns parentTableName + in parentColumns ++ columns + + -- Function to find the columns of a parent table by its name + findParentColumns :: Text -> [Column] + findParentColumns parentTableName = + case findTableByName parentTableName of + Just CreateTable {columns, primaryKeyConstraint} -> + gatherColumns (CreateTable + { name = parentTableName + , columns = columns + , primaryKeyConstraint = PrimaryKeyConstraint ["id"] + , constraints = [] + , unlogged = False + , inherits = Nothing + }) + Nothing -> error ("Parent table " <> cs parentTableName <> " not found.") + + -- Function to find a table by its name in the schema + findTableByName :: Text -> Maybe CreateTable + findTableByName tableName = ?schema.statements + |> mapMaybe (\case + StatementCreateTable table | table.name == tableName -> Just table + _ -> Nothing + ) + |> listToMaybe + + -- Original logic referencing = columnsReferencingTable table.name compileField (fieldName, _) @@ -664,7 +718,7 @@ instance FromRow #{modelName} where | otherwise = "def" isPrimaryKey name = name `elem` primaryKeyColumnNames table.primaryKeyConstraint - isColumn name = name `elem` columnNames + isColumn name = name `elem` allColumnNames isOneToManyField fieldName = fieldName `elem` (referencing |> map (columnNameToFieldName . fst)) compileSetQueryBuilder (refTableName, refFieldName) = "(QueryBuilder.filterWhere (#" <> columnNameToFieldName refFieldName <> ", " <> primaryKeyField <> ") (QueryBuilder.query @" <> tableNameToModelName refTableName <> "))" @@ -693,40 +747,6 @@ instance FromRow #{modelName} where Just refColumn -> refColumn Nothing -> error (cs $ "Could not find " <> refTable.name <> "." <> refFieldName <> " referenced by a foreign key constraint. Make sure that there is no typo in the foreign key constraint") - compileQuery column@(Column { name }) = columnNameToFieldName name <> " = (" <> toBinding modelName column <> ")" - -- compileQuery column@(Column { name }) | isReferenceColum column = columnNameToFieldName name <> " = (" <> toBinding modelName column <> ")" - --compileQuery (HasMany hasManyName inverseOf) = columnNameToFieldName hasManyName <> " = (QueryBuilder.filterWhere (Data.Proxy.Proxy @" <> tshow relatedFieldName <> ", " <> (fromJust $ toBinding' (tableNameToModelName name) relatedIdField) <> ") (QueryBuilder.query @" <> tableNameToModelName hasManyName <>"))" - -- where - -- compileInverseOf Nothing = (columnNameToFieldName (singularize name)) <> "Id" - -- compileInverseOf (Just name) = columnNameToFieldName (singularize name) - -- relatedFieldName = compileInverseOf inverseOf - -- relatedIdField = relatedField "id" - -- relatedForeignKeyField = relatedField relatedFieldName - -- relatedField :: Text -> Attribute - -- relatedField relatedFieldName = - -- let - -- isFieldName name (Field fieldName _) = (columnNameToFieldName fieldName) == name - -- (Table _ attributes) = relatedTable - -- in case find (isFieldName relatedFieldName) (fieldsOnly attributes) of - -- Just a -> a - -- Nothing -> - -- let (Table tableName _) = relatedTable - -- in error ( - -- "Could not find field " - -- <> show relatedFieldName - -- <> " in table" - -- <> cs tableName - -- <> " " - -- <> (show $ fieldsOnly attributes) - -- <> ".\n\nThis is caused by `+ hasMany " <> show hasManyName <> "`" - -- ) - -- relatedTable = case find (\(Table tableName _) -> tableName == hasManyName) database of - -- Just t -> t - -- Nothing -> error ("Could not find table " <> show hasManyName) - -- toBinding' modelName attributes = - -- case relatedForeignKeyField of - -- Field _ fieldType | allowNull fieldType -> Just $ "Just (" <> fromJust (toBinding modelName attributes) <> ")" - -- otherwise -> toBinding modelName attributes compileBuild :: (?schema :: Schema) => CreateTable -> Text compileBuild table@(CreateTable { name, columns }) = From d8e7f288f8fd5832c26e273ffb83b2ae4274858f Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Wed, 14 Aug 2024 19:59:58 +0300 Subject: [PATCH 18/65] Update docs --- CONTRIBUTING.md | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 6b667121a..51325af12 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -82,11 +82,12 @@ use `ghci` to load your application together with the framework located in `IHP` ``` ghci --- Add the IHP/ihp-ide directory to the load path -:set -iIHP/ihp-ide + -- Load the development server -:l IHP/ihp-ide/exe/IHP/IDE/DevServer.hs -main + :l ihp-ide/exe/IHP/IDE/DevServer.hs + +-- Run the IHP project in the parent project directory +mainInParentDirectory ``` We don't need to start postgres as the IDE starts it automatically. From bebd467285fad0936bac43c6ee65ace420fecc03 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Wed, 14 Aug 2024 21:58:35 +0300 Subject: [PATCH 19/65] Revert "Added inline annotations for getQueryBuilder" This reverts commit 4fe8b56e5a8c5dcb394a16b0dfb5eb2d6f77b18f. --- IHP/QueryBuilder.hs | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/IHP/QueryBuilder.hs b/IHP/QueryBuilder.hs index fd3c8d093..e91d6b6b8 100644 --- a/IHP/QueryBuilder.hs +++ b/IHP/QueryBuilder.hs @@ -164,8 +164,7 @@ class HasQueryBuilder queryBuilderProvider joinRegister | queryBuilderProvider - getQueryBuilder :: queryBuilderProvider table -> QueryBuilder table injectQueryBuilder :: QueryBuilder table -> queryBuilderProvider table getQueryIndex :: queryBuilderProvider table -> Maybe ByteString - getQueryIndex _ = Nothing - {-# INLINE getQueryIndex #-} + getQueryIndex _ = Nothing -- Wrapper for QueryBuilders resulting from joins. Associates a joinRegister type. newtype JoinQueryBuilderWrapper joinRegister table = JoinQueryBuilderWrapper (QueryBuilder table) @@ -179,31 +178,22 @@ newtype LabeledQueryBuilderWrapper foreignTable indexColumn indexValue table = L -- QueryBuilders have query builders and the join register is empty. instance HasQueryBuilder QueryBuilder EmptyModelList where getQueryBuilder = id - {-# INLINE getQueryBuilder #-} injectQueryBuilder = id - {-# INLINE injectQueryBuilder #-} -- JoinQueryBuilderWrappers have query builders instance HasQueryBuilder (JoinQueryBuilderWrapper joinRegister) joinRegister where getQueryBuilder (JoinQueryBuilderWrapper queryBuilder) = queryBuilder - {-# INLINE getQueryBuilder #-} injectQueryBuilder = JoinQueryBuilderWrapper - {-# INLINE injectQueryBuilder #-} -- NoJoinQueryBuilderWrapper have query builders and the join register does not allow any joins instance HasQueryBuilder NoJoinQueryBuilderWrapper NoJoins where getQueryBuilder (NoJoinQueryBuilderWrapper queryBuilder) = queryBuilder - {-# INLINE getQueryBuilder #-} injectQueryBuilder = NoJoinQueryBuilderWrapper - {-# INLINE injectQueryBuilder #-} instance (KnownSymbol foreignTable, foreignModel ~ GetModelByTableName foreignTable , KnownSymbol indexColumn, HasField indexColumn foreignModel indexValue) => HasQueryBuilder (LabeledQueryBuilderWrapper foreignTable indexColumn indexValue) NoJoins where getQueryBuilder (LabeledQueryBuilderWrapper queryBuilder) = queryBuilder - {-# INLINE getQueryBuilder #-} injectQueryBuilder = LabeledQueryBuilderWrapper - {-# INLINE injectQueryBuilder #-} getQueryIndex _ = Just $ symbolToByteString @foreignTable <> "." <> (Text.encodeUtf8 . fieldNameToColumnName) (symbolToText @indexColumn) - {-# INLINE getQueryIndex #-} data QueryBuilder (table :: Symbol) = From 765a969d137fc9f266930744b326a81ff4f28cc9 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Thu, 15 Aug 2024 18:33:31 +0300 Subject: [PATCH 20/65] Fix wrong comma when no parent table --- ihp-ide/IHP/SchemaCompiler.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 02f6573a9..e5369c05b 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -351,10 +351,11 @@ compileData table@(CreateTable { name, inherits }) = typeArguments :: Text typeArguments = dataTypeArguments table |> unwords - -- Include fields from parent tables + -- Include fields from parent table, if any. parentFields = inherits |> maybe "" (\parentTable -> compileParentFields parentTable) - |> (<> ", ") + -- Add comma, if there are fields from parent tables + |> (\parentFields -> if null parentFields then "" else parentFields <> ", ") compileParentFields parentTable = let parentTableDef = findTableByName parentTable From 389df3387230256902bb980b3b88b63e222d4021 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Thu, 15 Aug 2024 18:39:53 +0300 Subject: [PATCH 21/65] Remove duplicate MetaBag --- ihp-ide/IHP/SchemaCompiler.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index e5369c05b..855c948a8 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -351,9 +351,10 @@ compileData table@(CreateTable { name, inherits }) = typeArguments :: Text typeArguments = dataTypeArguments table |> unwords - -- Include fields from parent table, if any. + -- If the table inherits from another table, include the fields from the parent table. parentFields = inherits |> maybe "" (\parentTable -> compileParentFields parentTable) + -- Add comma, if there are fields from parent tables |> (\parentFields -> if null parentFields then "" else parentFields <> ", ") @@ -361,6 +362,8 @@ compileData table@(CreateTable { name, inherits }) = let parentTableDef = findTableByName parentTable in parentTableDef |> maybe [] (dataFields . (.unsafeGetCreateTable)) + -- Remove the MetaBag field from the parent table + |> filter (\(fieldName, _) -> fieldName /= "meta") |> map (\(fieldName, fieldType) -> fieldName <> " :: " <> fieldType) |> commaSep From 6abdbf16bf27f4130157a5567313ae1d4aa2bca1 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Thu, 15 Aug 2024 20:49:47 +0300 Subject: [PATCH 22/65] Add comment --- ihp-ide/IHP/SchemaCompiler.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 855c948a8..a456d6c89 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -362,7 +362,8 @@ compileData table@(CreateTable { name, inherits }) = let parentTableDef = findTableByName parentTable in parentTableDef |> maybe [] (dataFields . (.unsafeGetCreateTable)) - -- Remove the MetaBag field from the parent table + -- Remove the MetaBag field from the parent table. + -- @todo: Avoid clashing of field names. |> filter (\(fieldName, _) -> fieldName /= "meta") |> map (\(fieldName, fieldType) -> fieldName <> " :: " <> fieldType) |> commaSep From 83f652e9b29b9e516afadbad9ede794bf114fb63 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Sun, 25 Aug 2024 18:37:39 +0300 Subject: [PATCH 23/65] Try fix typeArguments --- ihp-ide/IHP/SchemaCompiler.hs | 37 ++++++++++++++++++++++++----------- 1 file changed, 26 insertions(+), 11 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index a456d6c89..847cb677e 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -348,25 +348,41 @@ compileData table@(CreateTable { name, inherits }) = <> "} deriving (Eq, Show)\n" where modelName = tableNameToModelName name + typeArguments :: Text - typeArguments = dataTypeArguments table |> unwords + typeArguments = + if null parentTypeArguments + then currentTypeArguments + else currentTypeArguments <> " " <> parentTypeArguments + where + currentTypeArguments = dataTypeArguments table |> unwords + + parentTypeArguments :: Text + parentTypeArguments = + case inherits of + Nothing -> "" + Just parentTable -> + let parentTableDef = findTableByName parentTable + in parentTableDef + |> maybe [] (dataTypeArguments . (.unsafeGetCreateTable)) + |> unwords -- If the table inherits from another table, include the fields from the parent table. parentFields = inherits |> maybe "" (\parentTable -> compileParentFields parentTable) - -- Add comma, if there are fields from parent tables |> (\parentFields -> if null parentFields then "" else parentFields <> ", ") compileParentFields parentTable = - let parentTableDef = findTableByName parentTable - in parentTableDef - |> maybe [] (dataFields . (.unsafeGetCreateTable)) - -- Remove the MetaBag field from the parent table. - -- @todo: Avoid clashing of field names. - |> filter (\(fieldName, _) -> fieldName /= "meta") - |> map (\(fieldName, fieldType) -> fieldName <> " :: " <> fieldType) - |> commaSep + let parentTableDef = findTableByName parentTable + in parentTableDef + |> maybe [] (dataFields . (.unsafeGetCreateTable)) + -- Remove the MetaBag field from the parent table. + -- @todo: Avoid clashing of field names. + |> filter (\(fieldName, _) -> fieldName /= "meta") + |> map (\(fieldName, fieldType) -> fieldName <> " :: " <> fieldType) + |> commaSep + -- |> \e -> error (show parentTable ++ show e ++ show parentTableDef) findTableByName tableName = ?schema.statements |> find (\case @@ -713,7 +729,6 @@ instance FromRow #{modelName} where ) |> listToMaybe - -- Original logic referencing = columnsReferencingTable table.name compileField (fieldName, _) From c0ec985a894598ed0ba951d63a85e70b3d9900ad Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Sun, 25 Aug 2024 18:39:20 +0300 Subject: [PATCH 24/65] Add todo --- ihp-ide/IHP/SchemaCompiler.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 847cb677e..c1909283b 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -364,6 +364,7 @@ compileData table@(CreateTable { name, inherits }) = Just parentTable -> let parentTableDef = findTableByName parentTable in parentTableDef + -- @todo: We should remove ref to own table (e.g. `post_revisions` table should not have postRevisions) |> maybe [] (dataTypeArguments . (.unsafeGetCreateTable)) |> unwords From 1a0dc74b826fd8e71fe9cdd659cb7a9b4846c1e7 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Sun, 25 Aug 2024 20:47:01 +0300 Subject: [PATCH 25/65] Fix docs typo --- ihp-ide/IHP/SchemaCompiler.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index c1909283b..4ed643988 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -442,7 +442,7 @@ compileQueryBuilderFields columns = map compileQueryBuilderField columns -- Of course having two fields in the same record does not work, so we have to -- detect these duplicate query builder fields and use a more qualified name. -- - -- In the example this will lead to two fileds called @referralsUsers@ and @referralsReferredUsers@ + -- In the example this will lead to two fields called @referralsUsers@ and @referralsReferredUsers@ -- being added to the data structure. hasDuplicateQueryBuilder = columns From b09599693e1a000cbeeb9a3b2eed34c8b9a3133b Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Sun, 25 Aug 2024 21:09:03 +0300 Subject: [PATCH 26/65] Try to filter wrong vars --- ihp-ide/IHP/SchemaCompiler.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 4ed643988..a4f439a18 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -349,6 +349,9 @@ compileData table@(CreateTable { name, inherits }) = where modelName = tableNameToModelName name + -- @todo: Find a better way. + colName = modelName |> pluralize |> Text.toLower + typeArguments :: Text typeArguments = if null parentTypeArguments @@ -366,6 +369,7 @@ compileData table@(CreateTable { name, inherits }) = in parentTableDef -- @todo: We should remove ref to own table (e.g. `post_revisions` table should not have postRevisions) |> maybe [] (dataTypeArguments . (.unsafeGetCreateTable)) + |> filter (\fieldName -> Text.toLower fieldName /= colName) |> unwords -- If the table inherits from another table, include the fields from the parent table. @@ -380,7 +384,7 @@ compileData table@(CreateTable { name, inherits }) = |> maybe [] (dataFields . (.unsafeGetCreateTable)) -- Remove the MetaBag field from the parent table. -- @todo: Avoid clashing of field names. - |> filter (\(fieldName, _) -> fieldName /= "meta") + |> filter (\(fieldName, _) -> fieldName /= "meta" && Text.toLower fieldName /= colName) |> map (\(fieldName, fieldType) -> fieldName <> " :: " <> fieldType) |> commaSep -- |> \e -> error (show parentTable ++ show e ++ show parentTableDef) From d8c66629c05ee454a7df4ef0dac08c8000062856 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Sun, 25 Aug 2024 21:14:54 +0300 Subject: [PATCH 27/65] filter out the ID --- ihp-ide/IHP/SchemaCompiler.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index a4f439a18..94dfa2bc8 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -384,7 +384,8 @@ compileData table@(CreateTable { name, inherits }) = |> maybe [] (dataFields . (.unsafeGetCreateTable)) -- Remove the MetaBag field from the parent table. -- @todo: Avoid clashing of field names. - |> filter (\(fieldName, _) -> fieldName /= "meta" && Text.toLower fieldName /= colName) + -- @todo: Check name of `id` column. + |> filter (\(fieldName, _) -> fieldName /= "meta" && Text.toLower fieldName /= colName && fieldName /= "id") |> map (\(fieldName, fieldType) -> fieldName <> " :: " <> fieldType) |> commaSep -- |> \e -> error (show parentTable ++ show e ++ show parentTableDef) From 48a3bdaa46829efb74eab98ac61adc94e37e7c5b Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Sun, 25 Aug 2024 21:18:16 +0300 Subject: [PATCH 28/65] Apply columnNames --- ihp-ide/IHP/SchemaCompiler.hs | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 94dfa2bc8..1fcf19ac4 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -390,11 +390,6 @@ compileData table@(CreateTable { name, inherits }) = |> commaSep -- |> \e -> error (show parentTable ++ show e ++ show parentTableDef) - findTableByName tableName = ?schema.statements - |> find (\case - StatementCreateTable CreateTable { name } | name == tableName -> True - _ -> False) - compileInputValueInstance :: CreateTable -> Text compileInputValueInstance table = @@ -892,9 +887,16 @@ instance #{instanceHead} where primaryKeyToCondition :: Column -> Text primaryKeyToCondition column = "toField " <> columnNameToFieldName column.name - columnNames = columns + currentColumnNames = columns |> map (.name) - |> tshow + + parentColumnNames = case table.inherits of + Just parentTableName -> findTableByName parentTableName + |> maybe [] (dataFields . (.unsafeGetCreateTable)) + |> map fst + Nothing -> [] + + columnNames = tshow $ currentColumnNames <> parentColumnNames compileGetModelName :: (?schema :: Schema) => CreateTable -> Text compileGetModelName table@(CreateTable { name }) = "type instance GetModelName (" <> tableNameToModelName name <> "' " <> unwords (map (const "_") (dataTypeArguments table)) <> ") = " <> tshow (tableNameToModelName name) <> "\n" @@ -1013,3 +1015,9 @@ hasExplicitOrImplicitDefault column = case column of Column { columnType = PSerial } -> True Column { columnType = PBigserial } -> True _ -> False + + +findTableByName tableName = ?schema.statements + |> find (\case + StatementCreateTable CreateTable { name } | name == tableName -> True + _ -> False) \ No newline at end of file From 97047b05ef7ecad3a2cc2aedbb1dc4f994e6348b Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Sun, 25 Aug 2024 21:21:59 +0300 Subject: [PATCH 29/65] compileTypePattern --- ihp-ide/IHP/SchemaCompiler.hs | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 1fcf19ac4..1e190e830 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -905,7 +905,30 @@ compileDataTypePattern :: (?schema :: Schema) => CreateTable -> Text compileDataTypePattern table@(CreateTable { name }) = tableNameToModelName name <> " " <> unwords (table |> dataFields |> map fst) compileTypePattern :: (?schema :: Schema) => CreateTable -> Text -compileTypePattern table@(CreateTable { name }) = tableNameToModelName name <> "' " <> unwords (dataTypeArguments table) +compileTypePattern table@(CreateTable { name, inherits }) = tableNameToModelName name <> "' " <> dataTypeCompiled + where + dataTypeCompiled = if null parentTypeArguments + then currentTypeArguments + else currentTypeArguments <> " " <> parentTypeArguments + + currentTypeArguments = dataTypeArguments table |> unwords + + modelName = tableNameToModelName name + + -- @todo: Find a better way. + colName = modelName |> pluralize |> Text.toLower + + parentTypeArguments :: Text + parentTypeArguments = + case inherits of + Nothing -> "" + Just parentTable -> + let parentTableDef = findTableByName parentTable + in parentTableDef + -- @todo: We should remove ref to own table (e.g. `post_revisions` table should not have postRevisions) + |> maybe [] (dataTypeArguments . (.unsafeGetCreateTable)) + |> filter (\fieldName -> Text.toLower fieldName /= colName) + |> unwords compileInclude :: (?schema :: Schema) => CreateTable -> Text compileInclude table@(CreateTable { name, columns }) = (belongsToIncludes <> hasManyIncludes) |> unlines From 339374bbc4bdfad57680b18a483c01ce59a0316b Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Sun, 25 Aug 2024 21:23:53 +0300 Subject: [PATCH 30/65] fix columnNames --- ihp-ide/IHP/SchemaCompiler.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 1e190e830..d28da1ef2 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -893,6 +893,7 @@ instance #{instanceHead} where parentColumnNames = case table.inherits of Just parentTableName -> findTableByName parentTableName |> maybe [] (dataFields . (.unsafeGetCreateTable)) + |> filter (\(fieldName, _) -> fieldName /= "meta") |> map fst Nothing -> [] From 781417cc6639760f82ca819ac2f40a40d1084565 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Sun, 25 Aug 2024 21:27:14 +0300 Subject: [PATCH 31/65] Add comment --- ihp-ide/IHP/SchemaCompiler.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index d28da1ef2..de9004b58 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -367,8 +367,8 @@ compileData table@(CreateTable { name, inherits }) = Just parentTable -> let parentTableDef = findTableByName parentTable in parentTableDef - -- @todo: We should remove ref to own table (e.g. `post_revisions` table should not have postRevisions) |> maybe [] (dataTypeArguments . (.unsafeGetCreateTable)) + -- We remove ref to own table (e.g. `post_revisions` table should not have postRevisions) |> filter (\fieldName -> Text.toLower fieldName /= colName) |> unwords @@ -926,8 +926,8 @@ compileTypePattern table@(CreateTable { name, inherits }) = tableNameToModelName Just parentTable -> let parentTableDef = findTableByName parentTable in parentTableDef - -- @todo: We should remove ref to own table (e.g. `post_revisions` table should not have postRevisions) |> maybe [] (dataTypeArguments . (.unsafeGetCreateTable)) + -- We remove ref to own table (e.g. `post_revisions` table should not have postRevisions) |> filter (\fieldName -> Text.toLower fieldName /= colName) |> unwords From 8f38d7af323cbae3faba9279ec8dfa55d1a85604 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Sun, 25 Aug 2024 22:48:31 +0300 Subject: [PATCH 32/65] Fix compileTypeAlias --- ihp-ide/IHP/SchemaCompiler.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index de9004b58..2d12f7951 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -317,13 +317,15 @@ tableHasPrimaryKey :: CreateTable -> Bool tableHasPrimaryKey table = table.primaryKeyConstraint /= (PrimaryKeyConstraint []) compileTypeAlias :: (?schema :: Schema) => CreateTable -> Text -compileTypeAlias table@(CreateTable { name, columns }) = +compileTypeAlias table@(CreateTable { name, columns, inherits }) = "type " <> modelName <> " = " <> modelName <> "' " <> unwords (map (haskellType table) (variableAttributes table)) + <> " " + <> unwords parentVariables <> hasManyDefaults <> "\n" where @@ -332,6 +334,17 @@ compileTypeAlias table@(CreateTable { name, columns }) = |> map (\(tableName, columnName) -> "(QueryBuilder.QueryBuilder \"" <> tableName <> "\")") |> unwords + parentVariables = case inherits of + Nothing -> [] + Just parentTableName -> + case findTableByName parentTableName of + Just parentTable -> + let parentCreateTable = parentTable.unsafeGetCreateTable + in map (haskellType parentCreateTable) (variableAttributes parentCreateTable) + -- Satisfy the compiler. + Nothing -> error $ "Parent table " <> cs parentTableName <> " not found for table " <> cs name + + primaryKeyTypeName :: Text -> Text primaryKeyTypeName name = "Id' " <> tshow name <> "" From cb3a7d2f021006500f64111285709a073a4033af Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Sun, 25 Aug 2024 22:54:10 +0300 Subject: [PATCH 33/65] compileHasTableNameInstance --- ihp-ide/IHP/SchemaCompiler.hs | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 2d12f7951..4d7140047 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -823,9 +823,25 @@ toDefaultValueExpr Column { columnType, notNull, defaultValue = Just theDefaultV toDefaultValueExpr _ = "def" compileHasTableNameInstance :: (?schema :: Schema) => CreateTable -> Text -compileHasTableNameInstance table@(CreateTable { name }) = - "type instance GetTableName (" <> tableNameToModelName name <> "' " <> unwords (map (const "_") (dataTypeArguments table)) <> ") = " <> tshow name <> "\n" - <> "type instance GetModelByTableName " <> tshow name <> " = " <> tableNameToModelName name <> "\n" +compileHasTableNameInstance table@(CreateTable { name, inherits }) = + let + -- Convert the model name to its plural, lowercase form to match the column name. + colName = tableNameToModelName name |> pluralize |> Text.toLower + + -- Determine the type arguments considering inheritance. + typeArguments = case inherits of + Nothing -> map (const "_") (dataTypeArguments table) + Just parentTableName -> + let parentTableDef = findTableByName parentTableName + in case parentTableDef of + Just parentTable -> + let parentTypeArgs = dataTypeArguments parentTable.unsafeGetCreateTable + in map (const "_") (dataTypeArguments table) + <> filter (\fieldName -> Text.toLower fieldName /= colName) parentTypeArgs + Nothing -> error $ "Parent table " <> cs parentTableName <> " not found for table " <> cs name <> "." + in + "type instance GetTableName (" <> tableNameToModelName name <> "' " <> unwords typeArguments <> ") = " <> tshow name <> "\n" + <> "type instance GetModelByTableName " <> tshow name <> " = " <> tableNameToModelName name <> "\n" compilePrimaryKeyInstance :: (?schema :: Schema) => CreateTable -> Text compilePrimaryKeyInstance table@(CreateTable { name, columns, constraints }) = [trimming|type instance PrimaryKey $symbol = $idType|] <> "\n" From 22d71b0d8b726e5cd81d17ecc62efef000252ef7 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Sun, 25 Aug 2024 22:56:19 +0300 Subject: [PATCH 34/65] compileUpdateFieldInstances --- ihp-ide/IHP/SchemaCompiler.hs | 28 ++++++++++++++++++++++++---- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 4d7140047..fb6c90334 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -1004,11 +1004,28 @@ compileSetFieldInstances table@(CreateTable { name, columns }) = unlines (map co | otherwise = name' compileUpdateFieldInstances :: (?schema :: Schema) => CreateTable -> Text -compileUpdateFieldInstances table@(CreateTable { name, columns }) = unlines (map compileSetField (dataFields table)) +compileUpdateFieldInstances table@(CreateTable { name, columns, inherits }) = + unlines (map compileSetField (dataFields table)) where modelName = tableNameToModelName name - typeArgs = dataTypeArguments table - compileSetField (name, fieldType) = "instance UpdateField " <> tshow name <> " (" <> compileTypePattern table <> ") (" <> compileTypePattern' name <> ") " <> valueTypeA <> " " <> valueTypeB <> " where\n {-# INLINE updateField #-}\n updateField newValue (" <> compileDataTypePattern table <> ") = " <> modelName <> " " <> (unwords (map compileAttribute (table |> dataFields |> map fst))) + + -- Convert the model name to its plural, lowercase form to match the column name. + colName = modelName |> pluralize |> Text.toLower + + -- Determine the type arguments considering inheritance. + typeArgs = case inherits of + Nothing -> dataTypeArguments table + Just parentTableName -> + let parentTableDef = findTableByName parentTableName + in case parentTableDef of + Just parentTable -> + let parentTypeArgs = dataTypeArguments parentTable.unsafeGetCreateTable + in dataTypeArguments table + <> filter (\fieldName -> Text.toLower fieldName /= colName) parentTypeArgs + Nothing -> error $ "Parent table " <> cs parentTableName <> " not found for table " <> cs name <> "." + + compileSetField (name, fieldType) = + "instance UpdateField " <> tshow name <> " (" <> compileTypePattern table <> ") (" <> compileTypePattern' name <> ") " <> valueTypeA <> " " <> valueTypeB <> " where\n {-# INLINE updateField #-}\n updateField newValue (" <> compileDataTypePattern table <> ") = " <> modelName <> " " <> (unwords (map compileAttribute (table |> dataFields |> map fst))) where (valueTypeA, valueTypeB) = if name `elem` typeArgs @@ -1021,7 +1038,10 @@ compileUpdateFieldInstances table@(CreateTable { name, columns }) = unlines (map | otherwise = name' compileTypePattern' :: Text -> Text - compileTypePattern' name = tableNameToModelName table.name <> "' " <> unwords (map (\f -> if f == name then name <> "'" else f) (dataTypeArguments table)) + compileTypePattern' name = + let filteredArgs = map (\f -> if f == name then name <> "'" else f) typeArgs + in tableNameToModelName table.name <> "' " <> unwords filteredArgs + compileHasFieldId :: (?schema :: Schema) => CreateTable -> Text compileHasFieldId table@CreateTable { name, primaryKeyConstraint } = cs [i| From 29395ae1bc1267158124b58d2c92cda4f133c50d Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Sun, 25 Aug 2024 23:05:00 +0300 Subject: [PATCH 35/65] compileGetModelName --- ihp-ide/IHP/SchemaCompiler.hs | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index fb6c90334..a218c2a85 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -929,7 +929,25 @@ instance #{instanceHead} where columnNames = tshow $ currentColumnNames <> parentColumnNames compileGetModelName :: (?schema :: Schema) => CreateTable -> Text -compileGetModelName table@(CreateTable { name }) = "type instance GetModelName (" <> tableNameToModelName name <> "' " <> unwords (map (const "_") (dataTypeArguments table)) <> ") = " <> tshow (tableNameToModelName name) <> "\n" +compileGetModelName table@(CreateTable { name, inherits }) = + let + -- Convert the model name to its plural, lowercase form to match the column name. + colName = tableNameToModelName name |> pluralize |> Text.toLower + + -- Determine the type arguments considering inheritance. + typeArguments = case inherits of + Nothing -> map (const "_") (dataTypeArguments table) + Just parentTableName -> + let parentTableDef = findTableByName parentTableName + in case parentTableDef of + Just parentTable -> + let parentTypeArgs = dataTypeArguments parentTable.unsafeGetCreateTable + in map (const "_") (dataTypeArguments table) + <> filter (\fieldName -> Text.toLower fieldName /= colName) parentTypeArgs + Nothing -> error $ "Parent table " <> cs parentTableName <> " not found for table " <> cs name <> "." + in + "type instance GetModelName (" <> tableNameToModelName name <> "' " <> unwords typeArguments <> ") = " <> tshow (tableNameToModelName name) <> "\n" + compileDataTypePattern :: (?schema :: Schema) => CreateTable -> Text compileDataTypePattern table@(CreateTable { name }) = tableNameToModelName name <> " " <> unwords (table |> dataFields |> map fst) From 1d046dba265388b25ef6b8e81f264b2c34b322e0 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Sun, 25 Aug 2024 23:06:41 +0300 Subject: [PATCH 36/65] compileUpdateFieldInstances --- ihp-ide/IHP/SchemaCompiler.hs | 33 ++++++++++++++++++++++++++------- 1 file changed, 26 insertions(+), 7 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index a218c2a85..53580f50f 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -1023,7 +1023,7 @@ compileSetFieldInstances table@(CreateTable { name, columns }) = unlines (map co compileUpdateFieldInstances :: (?schema :: Schema) => CreateTable -> Text compileUpdateFieldInstances table@(CreateTable { name, columns, inherits }) = - unlines (map compileSetField (dataFields table)) + unlines (map compileSetField (dataFieldsIncludingParents table)) where modelName = tableNameToModelName name @@ -1042,25 +1042,44 @@ compileUpdateFieldInstances table@(CreateTable { name, columns, inherits }) = <> filter (\fieldName -> Text.toLower fieldName /= colName) parentTypeArgs Nothing -> error $ "Parent table " <> cs parentTableName <> " not found for table " <> cs name <> "." + -- Gather data fields including those from parent tables. + dataFieldsIncludingParents :: (?schema :: Schema) => CreateTable -> [(Text, Text)] + dataFieldsIncludingParents table@(CreateTable { inherits }) = + let currentFields = dataFields table + parentFields = case inherits of + Nothing -> [] + Just parentTableName -> + let parentTableDef = findTableByName parentTableName + in parentTableDef + |> maybe [] (dataFieldsIncludingParents . (.unsafeGetCreateTable)) + -- Filter out `meta`, fields with the same name as current table, and `id` field from parent. + |> filter (\(fieldName, _) -> fieldName /= "meta" && Text.toLower fieldName /= colName && fieldName /= "id") + in parentFields <> currentFields + compileSetField (name, fieldType) = - "instance UpdateField " <> tshow name <> " (" <> compileTypePattern table <> ") (" <> compileTypePattern' name <> ") " <> valueTypeA <> " " <> valueTypeB <> " where\n {-# INLINE updateField #-}\n updateField newValue (" <> compileDataTypePattern table <> ") = " <> modelName <> " " <> (unwords (map compileAttribute (table |> dataFields |> map fst))) + "instance UpdateField " <> tshow name <> " (" <> compileTypePattern table <> ") (" <> compileTypePattern' name <> ") " <> valueTypeA <> " " <> valueTypeB <> " where\n {-# INLINE updateField #-}\n updateField newValue (" <> patternMatch <> ") = " <> modelName <> " " <> fieldReconstruction where (valueTypeA, valueTypeB) = if name `elem` typeArgs then (name, name <> "'") else (fieldType, fieldType) - compileAttribute name' - | name' == name = "newValue" - | name' == "meta" = "(meta { touchedFields = \"" <> name <> "\" : touchedFields meta })" - | otherwise = name' + -- Pattern matching with the correct order of fields + patternMatch = unwords (map (\field -> columnNameToFieldName field) allFieldNames) + + -- Field reconstruction in the correct order, replacing the updated field with `newValue` + fieldReconstruction = unwords (map (\field -> if field == name then "newValue" else columnNameToFieldName field) allFieldNames) - compileTypePattern' :: Text -> Text + -- Collect all field names in the correct order, including parent fields + allFieldNames = dataFieldsIncludingParents table |> map fst + + compileTypePattern' :: Text -> Text compileTypePattern' name = let filteredArgs = map (\f -> if f == name then name <> "'" else f) typeArgs in tableNameToModelName table.name <> "' " <> unwords filteredArgs + compileHasFieldId :: (?schema :: Schema) => CreateTable -> Text compileHasFieldId table@CreateTable { name, primaryKeyConstraint } = cs [i| instance HasField "id" #{tableNameToModelName name} (Id' "#{name}") where From 354208d41ba96b7d16bb1c2a0e017715881abfb6 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 26 Aug 2024 09:35:37 +0300 Subject: [PATCH 37/65] More careful compileUpdateFieldInstances --- ihp-ide/IHP/SchemaCompiler.hs | 82 +++++++++++++++++------------------ 1 file changed, 39 insertions(+), 43 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 53580f50f..684fc6a55 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -1022,61 +1022,57 @@ compileSetFieldInstances table@(CreateTable { name, columns }) = unlines (map co | otherwise = name' compileUpdateFieldInstances :: (?schema :: Schema) => CreateTable -> Text -compileUpdateFieldInstances table@(CreateTable { name, columns, inherits }) = - unlines (map compileSetField (dataFieldsIncludingParents table)) +compileUpdateFieldInstances table@(CreateTable { name, columns, inherits }) = unlines (map compileSetField (dataFields table)) where modelName = tableNameToModelName name - - -- Convert the model name to its plural, lowercase form to match the column name. + -- @todo: Find a better way. colName = modelName |> pluralize |> Text.toLower - -- Determine the type arguments considering inheritance. - typeArgs = case inherits of - Nothing -> dataTypeArguments table - Just parentTableName -> - let parentTableDef = findTableByName parentTableName - in case parentTableDef of - Just parentTable -> - let parentTypeArgs = dataTypeArguments parentTable.unsafeGetCreateTable - in dataTypeArguments table - <> filter (\fieldName -> Text.toLower fieldName /= colName) parentTypeArgs - Nothing -> error $ "Parent table " <> cs parentTableName <> " not found for table " <> cs name <> "." + currentTypeArguments = dataTypeArguments table - -- Gather data fields including those from parent tables. - dataFieldsIncludingParents :: (?schema :: Schema) => CreateTable -> [(Text, Text)] - dataFieldsIncludingParents table@(CreateTable { inherits }) = - let currentFields = dataFields table - parentFields = case inherits of - Nothing -> [] - Just parentTableName -> - let parentTableDef = findTableByName parentTableName - in parentTableDef - |> maybe [] (dataFieldsIncludingParents . (.unsafeGetCreateTable)) - -- Filter out `meta`, fields with the same name as current table, and `id` field from parent. - |> filter (\(fieldName, _) -> fieldName /= "meta" && Text.toLower fieldName /= colName && fieldName /= "id") - in parentFields <> currentFields - compileSetField (name, fieldType) = - "instance UpdateField " <> tshow name <> " (" <> compileTypePattern table <> ") (" <> compileTypePattern' name <> ") " <> valueTypeA <> " " <> valueTypeB <> " where\n {-# INLINE updateField #-}\n updateField newValue (" <> patternMatch <> ") = " <> modelName <> " " <> fieldReconstruction + parentTypeArguments :: [Text] + parentTypeArguments = + case inherits of + Nothing -> [] + Just parentTable -> + let parentTableDef = findTableByName parentTable + in parentTableDef + |> maybe [] (dataTypeArguments . (.unsafeGetCreateTable)) + -- We remove ref to own table (e.g. `post_revisions` table should not have postRevisions) + |> filter (\fieldName -> Text.toLower fieldName /= colName) + + + allTypeArguments = currentTypeArguments <> parentTypeArguments + + currentDataFields = dataFields table + + parentDataFields = case inherits of + Nothing -> [] + Just parentTable -> + let parentTableDef = findTableByName parentTable + in parentTableDef + |> maybe [] (dataFields . (.unsafeGetCreateTable)) + -- We remove ref to own table (e.g. `post_revisions` table should not have postRevisions) + |> filter (\(fieldName, _) -> fieldName /= "meta") + + + allDateFields = currentDataFields <> parentDataFields + + compileSetField (name, fieldType) = "instance UpdateField " <> tshow name <> " (" <> compileTypePattern table <> ") (" <> compileTypePattern' name <> ") " <> valueTypeA <> " " <> valueTypeB <> " where\n {-# INLINE updateField #-}\n updateField newValue (" <> compileDataTypePattern table <> ") = " <> modelName <> " " <> (unwords (map compileAttribute (allDateFields |> map fst))) where (valueTypeA, valueTypeB) = - if name `elem` typeArgs + if name `elem` allTypeArguments then (name, name <> "'") else (fieldType, fieldType) - -- Pattern matching with the correct order of fields - patternMatch = unwords (map (\field -> columnNameToFieldName field) allFieldNames) - - -- Field reconstruction in the correct order, replacing the updated field with `newValue` - fieldReconstruction = unwords (map (\field -> if field == name then "newValue" else columnNameToFieldName field) allFieldNames) - - -- Collect all field names in the correct order, including parent fields - allFieldNames = dataFieldsIncludingParents table |> map fst + compileAttribute name' + | name' == name = "newValue" + | name' == "meta" = "(meta { touchedFields = \"" <> name <> "\" : touchedFields meta })" + | otherwise = name' - compileTypePattern' :: Text -> Text - compileTypePattern' name = - let filteredArgs = map (\f -> if f == name then name <> "'" else f) typeArgs - in tableNameToModelName table.name <> "' " <> unwords filteredArgs + compileTypePattern' :: Text -> Text + compileTypePattern' name = tableNameToModelName table.name <> "' " <> unwords (map (\f -> if f == name then name <> "'" else f) allTypeArguments) From bd2f5449fdea01dfa763d2304f5db0f9bda308ff Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 26 Aug 2024 09:44:46 +0300 Subject: [PATCH 38/65] compileDataTypePattern --- ihp-ide/IHP/SchemaCompiler.hs | 25 +++++++++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 684fc6a55..e4ebb7c9f 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -950,7 +950,27 @@ compileGetModelName table@(CreateTable { name, inherits }) = compileDataTypePattern :: (?schema :: Schema) => CreateTable -> Text -compileDataTypePattern table@(CreateTable { name }) = tableNameToModelName name <> " " <> unwords (table |> dataFields |> map fst) +compileDataTypePattern table@(CreateTable { name, inherits }) = tableNameToModelName name <> " " <> unwords (allDateFields |> map fst) + where + modelName = tableNameToModelName name + + -- @todo: Find a better way. + colName = modelName |> pluralize |> Text.toLower + + currentDataFields = dataFields table + + parentDataFields = case inherits of + Nothing -> [] + Just parentTable -> + let parentTableDef = findTableByName parentTable + in parentTableDef + |> maybe [] (dataFields . (.unsafeGetCreateTable)) + -- We remove ref to own table (e.g. `post_revisions` table should not have postRevisions) + -- @todo: Check name of `id` column. + |> filter (\(fieldName, _) -> fieldName /= "meta" && Text.toLower fieldName /= colName && fieldName /= "id") + + + allDateFields = currentDataFields <> parentDataFields compileTypePattern :: (?schema :: Schema) => CreateTable -> Text compileTypePattern table@(CreateTable { name, inherits }) = tableNameToModelName name <> "' " <> dataTypeCompiled @@ -1054,7 +1074,8 @@ compileUpdateFieldInstances table@(CreateTable { name, columns, inherits }) = un in parentTableDef |> maybe [] (dataFields . (.unsafeGetCreateTable)) -- We remove ref to own table (e.g. `post_revisions` table should not have postRevisions) - |> filter (\(fieldName, _) -> fieldName /= "meta") + -- @todo: Check name of `id` column. + |> filter (\(fieldName, _) -> fieldName /= "meta" && Text.toLower fieldName /= colName && fieldName /= "id") allDateFields = currentDataFields <> parentDataFields From 05fe2f2d615deb39ed645c40b2a393b2815abae5 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 26 Aug 2024 09:56:55 +0300 Subject: [PATCH 39/65] Remove `meta` from compileUpdateFieldInstances --- ihp-ide/IHP/SchemaCompiler.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index e4ebb7c9f..52b1cec2d 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -1075,7 +1075,7 @@ compileUpdateFieldInstances table@(CreateTable { name, columns, inherits }) = un |> maybe [] (dataFields . (.unsafeGetCreateTable)) -- We remove ref to own table (e.g. `post_revisions` table should not have postRevisions) -- @todo: Check name of `id` column. - |> filter (\(fieldName, _) -> fieldName /= "meta" && Text.toLower fieldName /= colName && fieldName /= "id") + |> filter (\(fieldName, _) -> Text.toLower fieldName /= colName && fieldName /= "id") allDateFields = currentDataFields <> parentDataFields From 2dc6e5d2490936911c185c0de4245a848a4e55d8 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 26 Aug 2024 10:02:18 +0300 Subject: [PATCH 40/65] Place the `meta` as the last value. --- ihp-ide/IHP/SchemaCompiler.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 52b1cec2d..f0e90f9f4 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -970,7 +970,10 @@ compileDataTypePattern table@(CreateTable { name, inherits }) = tableNameToModel |> filter (\(fieldName, _) -> fieldName /= "meta" && Text.toLower fieldName /= colName && fieldName /= "id") + -- Place the `meta` as the last value. allDateFields = currentDataFields <> parentDataFields + |> filter (\(fieldName, _) -> fieldName /= "meta") + |> \fields -> fields <> [("meta", "MetaBag")] compileTypePattern :: (?schema :: Schema) => CreateTable -> Text compileTypePattern table@(CreateTable { name, inherits }) = tableNameToModelName name <> "' " <> dataTypeCompiled From b4d00016b700af1c17b8f6e85c6fef609cd44c2f Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 26 Aug 2024 10:03:56 +0300 Subject: [PATCH 41/65] Fix meta --- ihp-ide/IHP/SchemaCompiler.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index f0e90f9f4..9e5243b97 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -957,7 +957,7 @@ compileDataTypePattern table@(CreateTable { name, inherits }) = tableNameToModel -- @todo: Find a better way. colName = modelName |> pluralize |> Text.toLower - currentDataFields = dataFields table + currentDataFields = dataFields table |> filter (\(fieldName, _) -> fieldName /= "meta") parentDataFields = case inherits of Nothing -> [] @@ -972,7 +972,6 @@ compileDataTypePattern table@(CreateTable { name, inherits }) = tableNameToModel -- Place the `meta` as the last value. allDateFields = currentDataFields <> parentDataFields - |> filter (\(fieldName, _) -> fieldName /= "meta") |> \fields -> fields <> [("meta", "MetaBag")] compileTypePattern :: (?schema :: Schema) => CreateTable -> Text From 78da6fa01aa5219cf7763c2af2dc2bacd08b0214 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 26 Aug 2024 10:13:38 +0300 Subject: [PATCH 42/65] more work --- ihp-ide/IHP/SchemaCompiler.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 9e5243b97..8c11fe61a 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -401,7 +401,6 @@ compileData table@(CreateTable { name, inherits }) = |> filter (\(fieldName, _) -> fieldName /= "meta" && Text.toLower fieldName /= colName && fieldName /= "id") |> map (\(fieldName, fieldType) -> fieldName <> " :: " <> fieldType) |> commaSep - -- |> \e -> error (show parentTable ++ show e ++ show parentTableDef) compileInputValueInstance :: CreateTable -> Text @@ -1067,7 +1066,7 @@ compileUpdateFieldInstances table@(CreateTable { name, columns, inherits }) = un allTypeArguments = currentTypeArguments <> parentTypeArguments - currentDataFields = dataFields table + currentDataFields = dataFields table |> filter (\(fieldName, _) -> fieldName /= "meta") parentDataFields = case inherits of Nothing -> [] @@ -1077,10 +1076,10 @@ compileUpdateFieldInstances table@(CreateTable { name, columns, inherits }) = un |> maybe [] (dataFields . (.unsafeGetCreateTable)) -- We remove ref to own table (e.g. `post_revisions` table should not have postRevisions) -- @todo: Check name of `id` column. - |> filter (\(fieldName, _) -> Text.toLower fieldName /= colName && fieldName /= "id") + |> filter (\(fieldName, _) -> fieldName /= "meta" && Text.toLower fieldName /= colName && fieldName /= "id") - allDateFields = currentDataFields <> parentDataFields + allDateFields = currentDataFields <> parentDataFields <> [("meta", "MetaBag")] compileSetField (name, fieldType) = "instance UpdateField " <> tshow name <> " (" <> compileTypePattern table <> ") (" <> compileTypePattern' name <> ") " <> valueTypeA <> " " <> valueTypeB <> " where\n {-# INLINE updateField #-}\n updateField newValue (" <> compileDataTypePattern table <> ") = " <> modelName <> " " <> (unwords (map compileAttribute (allDateFields |> map fst))) where From 8ea918b2f246b67a623b129d92399188cd239961 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 26 Aug 2024 14:15:24 +0300 Subject: [PATCH 43/65] More consistent code --- ihp-ide/IHP/SchemaCompiler.hs | 43 ++++++++++++++++------------------- 1 file changed, 20 insertions(+), 23 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 8c11fe61a..c85c7afae 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -352,12 +352,9 @@ compileData :: (?schema :: Schema) => CreateTable -> Text compileData table@(CreateTable { name, inherits }) = "data " <> modelName <> "' " <> typeArguments <> " = " <> modelName <> " {" <> - parentFields - <> - table - |> dataFields - |> map (\(fieldName, fieldType) -> fieldName <> " :: " <> fieldType) - |> commaSep + allDataFields + |> map (\(fieldName, fieldType) -> fieldName <> " :: " <> fieldType) + |> commaSep <> "} deriving (Eq, Show)\n" where modelName = tableNameToModelName name @@ -385,22 +382,22 @@ compileData table@(CreateTable { name, inherits }) = |> filter (\fieldName -> Text.toLower fieldName /= colName) |> unwords - -- If the table inherits from another table, include the fields from the parent table. - parentFields = inherits - |> maybe "" (\parentTable -> compileParentFields parentTable) - -- Add comma, if there are fields from parent tables - |> (\parentFields -> if null parentFields then "" else parentFields <> ", ") + currentDataFields = dataFields table |> filter (\(fieldName, _) -> fieldName /= "meta") - compileParentFields parentTable = + parentDataFields = case inherits of + Nothing -> [] + Just parentTable -> let parentTableDef = findTableByName parentTable in parentTableDef - |> maybe [] (dataFields . (.unsafeGetCreateTable)) - -- Remove the MetaBag field from the parent table. - -- @todo: Avoid clashing of field names. - -- @todo: Check name of `id` column. - |> filter (\(fieldName, _) -> fieldName /= "meta" && Text.toLower fieldName /= colName && fieldName /= "id") - |> map (\(fieldName, fieldType) -> fieldName <> " :: " <> fieldType) - |> commaSep + |> maybe [] (dataFields . (.unsafeGetCreateTable)) + -- We remove ref to own table (e.g. `post_revisions` table should not have postRevisions) + -- @todo: Check name of `id` column. + |> filter (\(fieldName, _) -> fieldName /= "meta" && Text.toLower fieldName /= colName && fieldName /= "id") + + + -- Place the `meta` as the last value. + allDataFields = currentDataFields <> parentDataFields + |> \fields -> fields <> [("meta", "MetaBag")] compileInputValueInstance :: CreateTable -> Text @@ -949,7 +946,7 @@ compileGetModelName table@(CreateTable { name, inherits }) = compileDataTypePattern :: (?schema :: Schema) => CreateTable -> Text -compileDataTypePattern table@(CreateTable { name, inherits }) = tableNameToModelName name <> " " <> unwords (allDateFields |> map fst) +compileDataTypePattern table@(CreateTable { name, inherits }) = tableNameToModelName name <> " " <> unwords (allDataFields |> map fst) where modelName = tableNameToModelName name @@ -970,7 +967,7 @@ compileDataTypePattern table@(CreateTable { name, inherits }) = tableNameToModel -- Place the `meta` as the last value. - allDateFields = currentDataFields <> parentDataFields + allDataFields = currentDataFields <> parentDataFields |> \fields -> fields <> [("meta", "MetaBag")] compileTypePattern :: (?schema :: Schema) => CreateTable -> Text @@ -1079,9 +1076,9 @@ compileUpdateFieldInstances table@(CreateTable { name, columns, inherits }) = un |> filter (\(fieldName, _) -> fieldName /= "meta" && Text.toLower fieldName /= colName && fieldName /= "id") - allDateFields = currentDataFields <> parentDataFields <> [("meta", "MetaBag")] + allDataFields = currentDataFields <> parentDataFields <> [("meta", "MetaBag")] - compileSetField (name, fieldType) = "instance UpdateField " <> tshow name <> " (" <> compileTypePattern table <> ") (" <> compileTypePattern' name <> ") " <> valueTypeA <> " " <> valueTypeB <> " where\n {-# INLINE updateField #-}\n updateField newValue (" <> compileDataTypePattern table <> ") = " <> modelName <> " " <> (unwords (map compileAttribute (allDateFields |> map fst))) + compileSetField (name, fieldType) = "instance UpdateField " <> tshow name <> " (" <> compileTypePattern table <> ") (" <> compileTypePattern' name <> ") " <> valueTypeA <> " " <> valueTypeB <> " where\n {-# INLINE updateField #-}\n updateField newValue (" <> compileDataTypePattern table <> ") = " <> modelName <> " " <> (unwords (map compileAttribute (allDataFields |> map fst))) where (valueTypeA, valueTypeB) = if name `elem` allTypeArguments From 97ede646f6162a82786789e2f77c36f19450af84 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 26 Aug 2024 14:20:14 +0300 Subject: [PATCH 44/65] More Set and Update --- ihp-ide/IHP/SchemaCompiler.hs | 28 +++++++++++++++++++++++----- 1 file changed, 23 insertions(+), 5 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index c85c7afae..a3c8d4c5d 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -1023,16 +1023,35 @@ compileInclude table@(CreateTable { name, columns }) = (belongsToIncludes <> has compileSetFieldInstances :: (?schema :: Schema) => CreateTable -> Text -compileSetFieldInstances table@(CreateTable { name, columns }) = unlines (map compileSetField (dataFields table)) +compileSetFieldInstances table@(CreateTable { name, columns, inherits }) = unlines (map compileSetField (dataFields table)) where setMetaField = "instance SetField \"meta\" (" <> compileTypePattern table <> ") MetaBag where\n {-# INLINE setField #-}\n setField newValue (" <> compileDataTypePattern table <> ") = " <> tableNameToModelName name <> " " <> (unwords (map (.name) columns)) <> " newValue" modelName = tableNameToModelName name - typeArgs = dataTypeArguments table + + -- @todo: Find a better way. + colName = modelName |> pluralize |> Text.toLower + + currentDataFields = dataFields table |> filter (\(fieldName, _) -> fieldName /= "meta") + + parentDataFields = case inherits of + Nothing -> [] + Just parentTable -> + let parentTableDef = findTableByName parentTable + in parentTableDef + |> maybe [] (dataFields . (.unsafeGetCreateTable)) + -- We remove ref to own table (e.g. `post_revisions` table should not have postRevisions) + -- @todo: Check name of `id` column. + |> filter (\(fieldName, _) -> fieldName /= "meta" && Text.toLower fieldName /= colName && fieldName /= "id") + + + allDataFields = currentDataFields <> parentDataFields <> [("meta", "MetaBag")] + + compileSetField (name, fieldType) = "instance SetField " <> tshow name <> " (" <> compileTypePattern table <> ") " <> fieldType <> " where\n" <> " {-# INLINE setField #-}\n" <> " setField newValue (" <> compileDataTypePattern table <> ") =\n" <> - " " <> modelName <> " " <> (unwords (map compileAttribute (table |> dataFields |> map fst))) + " " <> modelName <> " " <> (unwords (map compileAttribute (allDataFields |> map fst))) where compileAttribute name' | name' == name = "newValue" @@ -1040,7 +1059,7 @@ compileSetFieldInstances table@(CreateTable { name, columns }) = unlines (map co | otherwise = name' compileUpdateFieldInstances :: (?schema :: Schema) => CreateTable -> Text -compileUpdateFieldInstances table@(CreateTable { name, columns, inherits }) = unlines (map compileSetField (dataFields table)) +compileUpdateFieldInstances table@(CreateTable { name, columns, inherits }) = unlines (map compileSetField allDataFields) where modelName = tableNameToModelName name -- @todo: Find a better way. @@ -1048,7 +1067,6 @@ compileUpdateFieldInstances table@(CreateTable { name, columns, inherits }) = un currentTypeArguments = dataTypeArguments table - parentTypeArguments :: [Text] parentTypeArguments = case inherits of From 351f5b25ba10575d480919fced9174bd63af557c Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 26 Aug 2024 14:27:32 +0300 Subject: [PATCH 45/65] Adapt compileBuild --- ihp-ide/IHP/SchemaCompiler.hs | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index a3c8d4c5d..7e265c8c2 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -779,10 +779,28 @@ instance FromRow #{modelName} where compileBuild :: (?schema :: Schema) => CreateTable -> Text -compileBuild table@(CreateTable { name, columns }) = +compileBuild table@(CreateTable { name, columns, inherits }) = "instance Record " <> tableNameToModelName name <> " where\n" <> " {-# INLINE newRecord #-}\n" - <> " newRecord = " <> tableNameToModelName name <> " " <> unwords (map toDefaultValueExpr columns) <> " " <> (columnsReferencingTable name |> map (const "def") |> unwords) <> " def\n" + <> " newRecord = " <> tableNameToModelName name <> " " <> unwords (map toDefaultValueExpr allColumns) <> " " <> (allColumnsReferencingTable |> map (const "def") |> unwords) <> " def\n" + where + (parentColumns, parentColumnsReferencingTable) = case inherits of + Nothing -> ([], []) + Just parentTableName -> + let parentTableDef = findTableByName parentTableName + in case parentTableDef of + Just parentTable -> + (parentTable.unsafeGetCreateTable.columns, columnsReferencingTable parentTableName) + + Nothing -> error $ "Parent table " <> cs parentTableName <> " not found for table " <> cs name <> "." + + allColumns = columns <> parentColumns + + allColumnsReferencingTable = columnsReferencingTable name <> parentColumnsReferencingTable + + + + compileDefaultIdInstance :: CreateTable -> Text From b93791d34400b7754792acb61cfcc4999387052a Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 26 Aug 2024 14:35:17 +0300 Subject: [PATCH 46/65] More fixes to compileBuild --- ihp-ide/IHP/SchemaCompiler.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 7e265c8c2..b3a8dd60d 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -784,13 +784,17 @@ compileBuild table@(CreateTable { name, columns, inherits }) = <> " {-# INLINE newRecord #-}\n" <> " newRecord = " <> tableNameToModelName name <> " " <> unwords (map toDefaultValueExpr allColumns) <> " " <> (allColumnsReferencingTable |> map (const "def") |> unwords) <> " def\n" where + colName = tableNameToModelName name |> pluralize |> Text.toLower + (parentColumns, parentColumnsReferencingTable) = case inherits of Nothing -> ([], []) Just parentTableName -> let parentTableDef = findTableByName parentTableName in case parentTableDef of Just parentTable -> - (parentTable.unsafeGetCreateTable.columns, columnsReferencingTable parentTableName) + ( parentTable.unsafeGetCreateTable.columns |> filter (\column -> column.name /= "meta" && Text.toLower column.name /= colName && column.name /= "id") + , columnsReferencingTable parentTableName + ) Nothing -> error $ "Parent table " <> cs parentTableName <> " not found for table " <> cs name <> "." From 613bb0d65d8a17f03b2a7e4e5d69279cb68a908d Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 26 Aug 2024 14:37:21 +0300 Subject: [PATCH 47/65] Add todo question --- ihp-ide/IHP/SchemaCompiler.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index b3a8dd60d..4b0c9e29f 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -800,7 +800,8 @@ compileBuild table@(CreateTable { name, columns, inherits }) = allColumns = columns <> parentColumns - allColumnsReferencingTable = columnsReferencingTable name <> parentColumnsReferencingTable + -- @todo: Parent is not needed? + allColumnsReferencingTable = columnsReferencingTable name -- <> parentColumnsReferencingTable From 27897e94f7480a5332e0bc55279a9b7c3955ff37 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 26 Aug 2024 14:44:02 +0300 Subject: [PATCH 48/65] Revamp compileFromRowInstance --- ihp-ide/IHP/SchemaCompiler.hs | 114 +++++++++++++++++++++------------- 1 file changed, 71 insertions(+), 43 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 4b0c9e29f..2ca981992 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -695,49 +695,48 @@ compileFromRowInstance :: (?schema :: Schema) => CreateTable -> Text compileFromRowInstance table@(CreateTable { name, columns, inherits }) = cs [i| instance FromRow #{modelName} where fromRow = do -#{unsafeInit . indent . indent . unlines $ map columnBinding allColumnNames} - let theRecord = #{modelName} #{intercalate " " (map compileField (dataFields table))} +#{unsafeInit . indent . indent . unlines $ map columnBinding columnNames} + let theRecord = #{modelName} #{intercalate " " (map compileField allDataFields)} pure theRecord |] where modelName = tableNameToModelName name - allColumns = gatherColumns table - allColumnNames = map (columnNameToFieldName . (.name)) allColumns - columnBinding :: Text -> Text - columnBinding columnName = columnName <> " <- field" + -- @todo: Find a better way. + colName = modelName |> pluralize |> Text.toLower - -- Recursively gather columns from the current table and all parent tables - gatherColumns :: CreateTable -> [Column] - gatherColumns CreateTable { columns, inherits = Nothing } = columns - gatherColumns CreateTable { columns, inherits = Just parentTableName } = - let parentColumns = findParentColumns parentTableName - in parentColumns ++ columns - - -- Function to find the columns of a parent table by its name - findParentColumns :: Text -> [Column] - findParentColumns parentTableName = - case findTableByName parentTableName of - Just CreateTable {columns, primaryKeyConstraint} -> - gatherColumns (CreateTable - { name = parentTableName - , columns = columns - , primaryKeyConstraint = PrimaryKeyConstraint ["id"] - , constraints = [] - , unlogged = False - , inherits = Nothing - }) - Nothing -> error ("Parent table " <> cs parentTableName <> " not found.") - - -- Function to find a table by its name in the schema - findTableByName :: Text -> Maybe CreateTable - findTableByName tableName = ?schema.statements - |> mapMaybe (\case - StatementCreateTable table | table.name == tableName -> Just table - _ -> Nothing - ) - |> listToMaybe + currentDataFields = dataFields table |> filter (\(fieldName, _) -> fieldName /= "meta") + + parentDataFields = case inherits of + Nothing -> [] + Just parentTable -> + let parentTableDef = findTableByName parentTable + in parentTableDef + |> maybe [] (dataFields . (.unsafeGetCreateTable)) + -- We remove ref to own table (e.g. `post_revisions` table should not have postRevisions) + -- @todo: Check name of `id` column. + |> filter (\(fieldName, _) -> fieldName /= "meta" && Text.toLower fieldName /= colName && fieldName /= "id") + + + -- Place the `meta` as the last value. + allDataFields = currentDataFields <> parentDataFields + |> \fields -> fields <> [("meta", "MetaBag")] + + parentColumns = case inherits of + Nothing -> [] + Just parentTableName -> + let parentTableDef = findTableByName parentTableName + in case parentTableDef of + Just parentTable -> + parentTable.unsafeGetCreateTable.columns |> filter (\column -> column.name /= "meta" && Text.toLower column.name /= colName && column.name /= "id") + + Nothing -> error $ "Parent table " <> cs parentTableName <> " not found for table " <> cs name <> "." + + allColumns = columns <> parentColumns + + columnNames = map (columnNameToFieldName . (.name)) allColumns + columnBinding columnName = columnName <> " <- field" referencing = columnsReferencingTable table.name @@ -748,7 +747,7 @@ instance FromRow #{modelName} where | otherwise = "def" isPrimaryKey name = name `elem` primaryKeyColumnNames table.primaryKeyConstraint - isColumn name = name `elem` allColumnNames + isColumn name = name `elem` columnNames isOneToManyField fieldName = fieldName `elem` (referencing |> map (columnNameToFieldName . fst)) compileSetQueryBuilder (refTableName, refFieldName) = "(QueryBuilder.filterWhere (#" <> columnNameToFieldName refFieldName <> ", " <> primaryKeyField <> ") (QueryBuilder.query @" <> tableNameToModelName refTableName <> "))" @@ -777,6 +776,40 @@ instance FromRow #{modelName} where Just refColumn -> refColumn Nothing -> error (cs $ "Could not find " <> refTable.name <> "." <> refFieldName <> " referenced by a foreign key constraint. Make sure that there is no typo in the foreign key constraint") + compileQuery column@(Column { name }) = columnNameToFieldName name <> " = (" <> toBinding modelName column <> ")" + -- compileQuery column@(Column { name }) | isReferenceColum column = columnNameToFieldName name <> " = (" <> toBinding modelName column <> ")" + --compileQuery (HasMany hasManyName inverseOf) = columnNameToFieldName hasManyName <> " = (QueryBuilder.filterWhere (Data.Proxy.Proxy @" <> tshow relatedFieldName <> ", " <> (fromJust $ toBinding' (tableNameToModelName name) relatedIdField) <> ") (QueryBuilder.query @" <> tableNameToModelName hasManyName <>"))" + -- where + -- compileInverseOf Nothing = (columnNameToFieldName (singularize name)) <> "Id" + -- compileInverseOf (Just name) = columnNameToFieldName (singularize name) + -- relatedFieldName = compileInverseOf inverseOf + -- relatedIdField = relatedField "id" + -- relatedForeignKeyField = relatedField relatedFieldName + -- relatedField :: Text -> Attribute + -- relatedField relatedFieldName = + -- let + -- isFieldName name (Field fieldName _) = (columnNameToFieldName fieldName) == name + -- (Table _ attributes) = relatedTable + -- in case find (isFieldName relatedFieldName) (fieldsOnly attributes) of + -- Just a -> a + -- Nothing -> + -- let (Table tableName _) = relatedTable + -- in error ( + -- "Could not find field " + -- <> show relatedFieldName + -- <> " in table" + -- <> cs tableName + -- <> " " + -- <> (show $ fieldsOnly attributes) + -- <> ".\n\nThis is caused by `+ hasMany " <> show hasManyName <> "`" + -- ) + -- relatedTable = case find (\(Table tableName _) -> tableName == hasManyName) database of + -- Just t -> t + -- Nothing -> error ("Could not find table " <> show hasManyName) + -- toBinding' modelName attributes = + -- case relatedForeignKeyField of + -- Field _ fieldType | allowNull fieldType -> Just $ "Just (" <> fromJust (toBinding modelName attributes) <> ")" + -- otherwise -> toBinding modelName attributes compileBuild :: (?schema :: Schema) => CreateTable -> Text compileBuild table@(CreateTable { name, columns, inherits }) = @@ -803,11 +836,6 @@ compileBuild table@(CreateTable { name, columns, inherits }) = -- @todo: Parent is not needed? allColumnsReferencingTable = columnsReferencingTable name -- <> parentColumnsReferencingTable - - - - - compileDefaultIdInstance :: CreateTable -> Text compileDefaultIdInstance table = "instance Default (Id' \"" <> table.name <> "\") where def = Id def" @@ -950,7 +978,7 @@ instance #{instanceHead} where compileGetModelName :: (?schema :: Schema) => CreateTable -> Text compileGetModelName table@(CreateTable { name, inherits }) = let - -- Convert the model name to its plural, lowercase form to match the column name. + -- @todo: Improve: Convert the model name to its plural, lowercase form to match the column name. colName = tableNameToModelName name |> pluralize |> Text.toLower -- Determine the type arguments considering inheritance. From f70d902de6f5daf2d7ab9d3a41667bdddf4868e9 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 26 Aug 2024 14:47:35 +0300 Subject: [PATCH 49/65] Fix compileInclude --- ihp-ide/IHP/SchemaCompiler.hs | 43 +++++++++++++++++++++++++++++++---- 1 file changed, 38 insertions(+), 5 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 2ca981992..60cbb95c8 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -1048,21 +1048,54 @@ compileTypePattern table@(CreateTable { name, inherits }) = tableNameToModelName |> unwords compileInclude :: (?schema :: Schema) => CreateTable -> Text -compileInclude table@(CreateTable { name, columns }) = (belongsToIncludes <> hasManyIncludes) |> unlines +compileInclude table@(CreateTable { name, columns, inherits }) = (belongsToIncludes <> hasManyIncludes) |> unlines where - belongsToIncludes = map compileBelongsTo (filter (isRefCol table) columns) + -- @todo: Find a better way. + colName = modelName |> pluralize |> Text.toLower + + parentColumns = case inherits of + Nothing -> [] + Just parentTableName -> + let parentTableDef = findTableByName parentTableName + in case parentTableDef of + Just parentTable -> + parentTable.unsafeGetCreateTable.columns |> filter (\column -> column.name /= "meta" && Text.toLower column.name /= colName && column.name /= "id") + + Nothing -> error $ "Parent table " <> cs parentTableName <> " not found for table " <> cs name <> "." + + allColumns = columns <> parentColumns + + belongsToIncludes = map compileBelongsTo (filter (isRefCol table) allColumns) hasManyIncludes = columnsReferencingTable name |> (\refs -> zip (map fst refs) (map fst (compileQueryBuilderFields refs))) |> map compileHasMany - typeArgs = dataTypeArguments table + modelName = tableNameToModelName name modelConstructor = modelName <> "'" + + currentTypeArguments = dataTypeArguments table + + parentTypeArguments :: [Text] + parentTypeArguments = + case inherits of + Nothing -> [] + Just parentTable -> + let parentTableDef = findTableByName parentTable + in parentTableDef + |> maybe [] (dataTypeArguments . (.unsafeGetCreateTable)) + -- We remove ref to own table (e.g. `post_revisions` table should not have postRevisions) + |> filter (\fieldName -> Text.toLower fieldName /= colName) + + + allTypeArguments = currentTypeArguments <> parentTypeArguments + + includeType :: Text -> Text -> Text includeType fieldName includedType = "type instance Include " <> tshow fieldName <> " (" <> leftModelType <> ") = " <> rightModelType where - leftModelType = unwords (modelConstructor:typeArgs) - rightModelType = unwords (modelConstructor:(map compileTypeVariable' typeArgs)) + leftModelType = unwords (modelConstructor:allTypeArguments) + rightModelType = unwords (modelConstructor:(map compileTypeVariable' allTypeArguments)) compileTypeVariable' name | name == fieldName = includedType compileTypeVariable' name = name From 5a11fd349f046e95cd38fdeb573e5addd8f10924 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 26 Aug 2024 14:48:43 +0300 Subject: [PATCH 50/65] Allow set parent fields --- ihp-ide/IHP/SchemaCompiler.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 60cbb95c8..49ea02bc6 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -1107,7 +1107,7 @@ compileInclude table@(CreateTable { name, columns, inherits }) = (belongsToInclu compileSetFieldInstances :: (?schema :: Schema) => CreateTable -> Text -compileSetFieldInstances table@(CreateTable { name, columns, inherits }) = unlines (map compileSetField (dataFields table)) +compileSetFieldInstances table@(CreateTable { name, columns, inherits }) = unlines (map compileSetField allDataFields) where setMetaField = "instance SetField \"meta\" (" <> compileTypePattern table <> ") MetaBag where\n {-# INLINE setField #-}\n setField newValue (" <> compileDataTypePattern table <> ") = " <> tableNameToModelName name <> " " <> (unwords (map (.name) columns)) <> " newValue" modelName = tableNameToModelName name From fa31d5bdb475c9bc206d0fc025a5de81591a9872 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 26 Aug 2024 14:58:57 +0300 Subject: [PATCH 51/65] compileCreate --- ihp-ide/IHP/SchemaCompiler.hs | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 49ea02bc6..41a7a026f 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -592,11 +592,27 @@ columnPlaceholder column@Column { columnType } = if columnPlaceholderNeedsTypeca columnPlaceholderNeedsTypecast Column { columnType = PArray {} } = True columnPlaceholderNeedsTypecast _ = False -compileCreate :: CreateTable -> Text -compileCreate table@(CreateTable { name, columns }) = +compileCreate :: (?schema :: Schema) => CreateTable -> Text +compileCreate table@(CreateTable { name, columns, inherits }) = let - writableColumns = onlyWritableColumns columns modelName = tableNameToModelName name + + -- @todo: Find a better way. + colName = modelName |> pluralize |> Text.toLower + + parentColumns = case inherits of + Nothing -> [] + Just parentTableName -> + let parentTableDef = findTableByName parentTableName + in case parentTableDef of + Just parentTable -> + parentTable.unsafeGetCreateTable.columns |> filter (\column -> column.name /= "meta" && Text.toLower column.name /= colName && column.name /= "id") + + Nothing -> error $ "Parent table " <> cs parentTableName <> " not found for table " <> cs name <> "." + + allColumns = columns <> parentColumns + + writableColumns = onlyWritableColumns allColumns columnNames = commaSep (map (.name) writableColumns) values = commaSep (map columnPlaceholder writableColumns) From 95ea731705a80ad6b5794a98e717c02b364c6e8f Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 26 Aug 2024 15:00:16 +0300 Subject: [PATCH 52/65] compileUpdate --- ihp-ide/IHP/SchemaCompiler.hs | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 41a7a026f..8a93145df 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -663,11 +663,27 @@ toBinding modelName Column { name } = "let " <> modelName <> "{" <> columnNameTo onlyWritableColumns columns = columns |> filter (\Column { generator } -> isNothing generator) -compileUpdate :: CreateTable -> Text -compileUpdate table@(CreateTable { name, columns }) = +compileUpdate :: (?schema :: Schema) => CreateTable -> Text +compileUpdate table@(CreateTable { name, columns, inherits }) = let modelName = tableNameToModelName name - writableColumns = onlyWritableColumns columns + + -- @todo: Find a better way. + colName = modelName |> pluralize |> Text.toLower + + parentColumns = case inherits of + Nothing -> [] + Just parentTableName -> + let parentTableDef = findTableByName parentTableName + in case parentTableDef of + Just parentTable -> + parentTable.unsafeGetCreateTable.columns |> filter (\column -> column.name /= "meta" && Text.toLower column.name /= colName && column.name /= "id") + + Nothing -> error $ "Parent table " <> cs parentTableName <> " not found for table " <> cs name <> "." + + allColumns = columns <> parentColumns + + writableColumns = onlyWritableColumns allColumns toUpdateBinding Column { name } = "fieldWithUpdate #" <> columnNameToFieldName name <> " model" toPrimaryKeyBinding Column { name } = "model." <> columnNameToFieldName name From 2d1601dc65a727ba1fc1da305831dd8fc4b6f50a Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Sun, 1 Sep 2024 11:20:59 +0300 Subject: [PATCH 53/65] Start adding inherits info to renderColumnSelector --- ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs | 17 ++++++++++++++++- ihp-ide/IHP/SchemaCompiler.hs | 1 + 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs b/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs index 2105f17cc..5f955a134 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs @@ -222,6 +222,11 @@ renderColumnSelector tableName columns statements = [hsx| {forEach columns (\column -> renderColumn (snd column) (fst column) tableName statements)} + +
+ Inherits: {inherits} +
+ {suggestedColumnsSection tableName columns} {auth} @@ -251,6 +256,16 @@ renderColumnSelector tableName columns statements = [hsx| auth :: Html auth = renderPolicies tableName statements + inherits = statements + |> find (\case + StatementCreateTable CreateTable { name } | name == tableName -> True + _ -> False) + -- Get the table that this table inherits from + |> \case + Just (StatementCreateTable CreateTable { inherits }) -> inherits + _ -> Nothing + + suggestedColumnsSection :: Text -> [(Int, Column)] -> Html suggestedColumnsSection tableName indexAndColumns = unless isUsersTable [hsx|
@@ -411,7 +426,7 @@ renderColumn Column { name, columnType, defaultValue, notNull, isUnique } id tab [hsx|Edit Foreign Key Constraint Delete Foreign Key Constraint|] _ -> [hsx|Add Foreign Key Constraint|] - + addIndex :: Html addIndex = unless alreadyHasIndex [hsx|
diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 8a93145df..6ed84595e 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -1276,6 +1276,7 @@ hasExplicitOrImplicitDefault column = case column of _ -> False +findTableByName :: (?schema :: Schema) => Text -> Maybe Statement findTableByName tableName = ?schema.statements |> find (\case StatementCreateTable CreateTable { name } | name == tableName -> True From b59e4059984d1d465d20f34f8daf9be8c337b16f Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 2 Sep 2024 17:31:47 +0300 Subject: [PATCH 54/65] Show inherits on UI --- ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs | 26 ++++++++++--------- 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs b/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs index 5f955a134..6e743ee65 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs @@ -223,9 +223,7 @@ renderColumnSelector tableName columns statements = [hsx| -
- Inherits: {inherits} -
+ {maybeInherits} {suggestedColumnsSection tableName columns} @@ -251,19 +249,23 @@ renderColumnSelector tableName columns statements = [hsx| {renderColumnIndexes tableName statements} |] - Nothing -> [hsx||] + Nothing -> "" auth :: Html auth = renderPolicies tableName statements - inherits = statements - |> find (\case - StatementCreateTable CreateTable { name } | name == tableName -> True - _ -> False) - -- Get the table that this table inherits from - |> \case - Just (StatementCreateTable CreateTable { inherits }) -> inherits - _ -> Nothing + maybeInherits = + statements + |> find \case + StatementCreateTable CreateTable { name } | name == tableName -> True + _ -> False + |> \case + Just (StatementCreateTable CreateTable { inherits = Just parentTableName }) -> + [hsx|
+ This table inherits from table {parentTableName} +
|] + _ -> "" + suggestedColumnsSection :: Text -> [(Int, Column)] -> Html From 9d9c02cbbbec346e0f1304b3d349416b7b55764e Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 2 Sep 2024 17:36:36 +0300 Subject: [PATCH 55/65] Add padding --- ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs b/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs index 6e743ee65..1ff36e1a0 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs @@ -261,9 +261,10 @@ renderColumnSelector tableName columns statements = [hsx| _ -> False |> \case Just (StatementCreateTable CreateTable { inherits = Just parentTableName }) -> - [hsx|
- This table inherits from table {parentTableName} -
|] + [hsx|
+ This table inherits from table {parentTableName} +
+ |] _ -> "" From 9b9e9760c18102f4f9ad95d0a53347a696fa417f Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 2 Sep 2024 17:49:17 +0300 Subject: [PATCH 56/65] Fix tests --- ihp-ide/IHP/SchemaCompiler.hs | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 6ed84595e..bb9d84da7 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -324,7 +324,6 @@ compileTypeAlias table@(CreateTable { name, columns, inherits }) = <> modelName <> "' " <> unwords (map (haskellType table) (variableAttributes table)) - <> " " <> unwords parentVariables <> hasManyDefaults <> "\n" @@ -335,14 +334,19 @@ compileTypeAlias table@(CreateTable { name, columns, inherits }) = |> unwords parentVariables = case inherits of - Nothing -> [] - Just parentTableName -> - case findTableByName parentTableName of - Just parentTable -> - let parentCreateTable = parentTable.unsafeGetCreateTable - in map (haskellType parentCreateTable) (variableAttributes parentCreateTable) - -- Satisfy the compiler. - Nothing -> error $ "Parent table " <> cs parentTableName <> " not found for table " <> cs name + Nothing -> [] + Just parentTableName -> + case findTableByName parentTableName of + Just parentTable -> + let parentCreateTable = parentTable.unsafeGetCreateTable + parentTypes = map (haskellType parentCreateTable) (variableAttributes parentCreateTable) + in if null parentTypes + then [] + else " " : parentTypes + + -- Satisfy the compiler. + Nothing -> error $ "Parent table " <> cs parentTableName <> " not found for table " <> cs name + primaryKeyTypeName :: Text -> Text From d4d20c3608b05f2b22d058f4fe42371018df441d Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 2 Sep 2024 17:49:42 +0300 Subject: [PATCH 57/65] Add comment --- ihp-ide/IHP/SchemaCompiler.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index bb9d84da7..db07ffac0 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -342,6 +342,7 @@ compileTypeAlias table@(CreateTable { name, columns, inherits }) = parentTypes = map (haskellType parentCreateTable) (variableAttributes parentCreateTable) in if null parentTypes then [] + -- Add space if there are parent types. else " " : parentTypes -- Satisfy the compiler. From a231a502a4883f41dc0f1c0e5b5dfaa8b8c1c5f8 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Tue, 3 Sep 2024 15:07:07 +0300 Subject: [PATCH 58/65] Add docs --- Guide/database.markdown | 62 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 62 insertions(+) diff --git a/Guide/database.markdown b/Guide/database.markdown index ed1c145c6..0f02e110e 100644 --- a/Guide/database.markdown +++ b/Guide/database.markdown @@ -853,3 +853,65 @@ CREATE TABLE users ( UNIQUE (email, username) ); ``` + +## Inheritance + +### Introduction to Table Inheritance + +In PostgreSQL, tables can inherit the structure and data of other tables using the `INHERITS` keyword. This allows you to create a hierarchy of tables where a child table automatically has all the columns of its parent table, but can also have additional columns. In IHP, table inheritance can be utilized to create versions or revisions of records efficiently. + +### Using Inheritance with Triggers + +One common use case for inheritance is to create a history of changes made to a record. For example, you might want to create a history of revisions for a `Post` record. By using table inheritance and a trigger, you can automatically create a revision every time a `Post` is updated. + +Here’s how you can achieve this in your `Schema.sql`: + +```sql +CREATE TABLE post_revisions ( + id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL, + post_id UUID NOT NULL +) INHERITS (posts); + +CREATE OR REPLACE FUNCTION create_post_revision() RETURNS TRIGGER AS $$ +BEGIN + INSERT INTO post_revisions (id, post_id, title, body, user_id) + VALUES (uuid_generate_v4(), NEW.id, NEW.title, NEW.body, NEW.user_id); + RETURN NEW; +END; +$$ LANGUAGE plpgsql; + +CREATE TRIGGER post_revision_trigger +AFTER UPDATE ON posts +FOR EACH ROW +EXECUTE FUNCTION create_post_revision(); +``` + +- __`INHERITS`__: The `post_revisions` table inherits all columns from the posts table. It also has an additional `post_id` column to link the revision back to the original post. +- __Trigger Function__: The `create_post_revision` function is defined to insert a new record into the `post_revisions` table whenever a `Post` is updated. +- __Trigger__: The `post_revision_trigger` is created to automatically execute the `create_post_revision` function after every update on the posts table. + +This setup ensures that every time a `Post` is updated, a corresponding revision is saved in the `post_revisions` table, preserving the history of changes. + +### Using Inheritance with Actions + +Another approach to managing inheritance and revisions is to handle the creation of revisions within your IHP actions. This provides more control and can be useful if you want to manage the revision process explicitly in your application logic. + +Here’s an example of how you might do this in an action: + +```haskell +action CreatePostRevisionAction { postId } = do + post <- fetch postId + let revision = newRecord @PostRevision + |> set #postId post.id + |> set #title post.title + |> set #body post.body + + createRecord revision + + redirectTo ShowPostAction { .. } +``` + +- **Action Logic**: In this approach, you define an explicit action, `CreatePostRevisionAction`, to create a new revision. +- **Fetch and Set**: The action fetches the current post by its `postId`, then creates a new `PostRevision` record by setting its fields based on the current state of the post. +- **CreateRecord**: The new revision is inserted into the `post_revisions` table. +- **Redirect**: After creating the revision, the user is redirected to the appropriate page, such as showing the post. From 57621fa3444bfe559c9bda2249f9cbee2b2d8cf8 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Sat, 14 Sep 2024 18:57:01 +0300 Subject: [PATCH 59/65] Start adding tests --- Test/SchemaCompilerSpec.hs | 85 +++++++++++++++++++ ihp-ide/IHP/IDE/CodeGen/MigrationGenerator.hs | 3 +- 2 files changed, 87 insertions(+), 1 deletion(-) diff --git a/Test/SchemaCompilerSpec.hs b/Test/SchemaCompilerSpec.hs index c60bf92b6..8a9cc36c2 100644 --- a/Test/SchemaCompilerSpec.hs +++ b/Test/SchemaCompilerSpec.hs @@ -675,6 +675,86 @@ tests = do builder |> QueryBuilder.filterWhere (#id, id) {-# INLINE filterWhereId #-} |] + describe "compileCreate with INHERITS" do + it "should compile a table that inherits from another table" do + let statements = parseSqlStatements [trimming| + CREATE TABLE parent_table ( + id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL, + parent_column TEXT NOT NULL + ); + CREATE TABLE child_table ( + id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL, + child_column INT NOT NULL + ) INHERITS (parent_table); + |] + let (Just childTableStatement) = find isChildTable statements + let compileOutput = compileStatementPreview statements childTableStatement |> Text.strip + + compileOutput `shouldBe` ([trimming| + data ChildTable' = ChildTable {id :: (Id' "child_table"), childColumn :: Int, parentColumn :: Text, meta :: MetaBag} deriving (Eq, Show) + + type instance PrimaryKey "child_table" = UUID + + type ChildTable = ChildTable'U+0020 + + type instance GetTableName (ChildTable' ) = "child_table" + type instance GetModelByTableName "child_table" = ChildTable + + instance Default (Id' "child_table") where def = Id def + + instance () => Table (ChildTable' ) where + tableName = "child_table" + tableNameByteString = Data.Text.Encoding.encodeUtf8 "child_table" + columnNames = ["id","child_column","id","parentColumn"] + primaryKeyColumnNames = ["id"] + primaryKeyConditionForId (Id (id)) = toField id + {-# INLINABLE primaryKeyConditionForId #-} + + + instance InputValue ChildTable where inputValue = IHP.ModelSupport.recordToInputValue + + + instance FromRow ChildTable where + fromRow = do + id <- field + childColumn <- field + parentColumn <- field + let theRecord = ChildTable id childColumn parentColumn def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) } + pure theRecord + + + type instance GetModelName (ChildTable' ) = "ChildTable" + + instance CanCreate ChildTable where + create :: (?modelContext :: ModelContext) => ChildTable -> IO ChildTable + create model = do + sqlQuerySingleRow "INSERT INTO child_table (id, child_column, parent_column) VALUES (?, ?, ?) RETURNING id, child_column, parent_column" ((fieldWithDefault #id model, model.childColumn, model.parentColumn)) + createMany [] = pure [] + createMany models = do + sqlQuery (Query $ "INSERT INTO child_table (id, child_column, parent_column) VALUES " <> (ByteString.intercalate ", " (List.map (\_ -> "(?, ?, ?)") models)) <> " RETURNING id, child_column, parent_column") (List.concat $ List.map (\model -> [toField (fieldWithDefault #id model), toField (model.childColumn), toField (model.parentColumn)]) models) + createRecordDiscardResult :: (?modelContext :: ModelContext) => ChildTable -> IO () + createRecordDiscardResult model = do + sqlExecDiscardResult "INSERT INTO child_table (id, child_column, parent_column) VALUES (?, ?, ?)" ((fieldWithDefault #id model, model.childColumn, model.parentColumn)) + + instance CanUpdate ChildTable where + updateRecord model = do + sqlQuerySingleRow "UPDATE child_table SET id = ?, child_column = ?, parent_column = ? WHERE id = ? RETURNING id, child_column, parent_column" ((fieldWithUpdate #id model, fieldWithUpdate #childColumn model, fieldWithUpdate #parentColumn model, model.id)) + updateRecordDiscardResult model = do + sqlExecDiscardResult "UPDATE child_table SET id = ?, child_column = ?, parent_column = ? WHERE id = ?" ((fieldWithUpdate #id model, fieldWithUpdate #childColumn model, fieldWithUpdate #parentColumn model, model.id)) + + instance Record ChildTable where + {-# INLINE newRecord #-} + newRecord = ChildTable def def def def + + + instance QueryBuilder.FilterPrimaryKey "child_table" where + filterWhereId id builder = + builder |> QueryBuilder.filterWhere (#id, id) + {-# INLINE filterWhereId #-} + |] + -- Replace `U+0020` with a space. + |> Text.replace "U+0020" " ") + getInstanceDecl :: Text -> Text -> Text getInstanceDecl instanceName full = @@ -693,3 +773,8 @@ getInstanceDecl instanceName full = | isEmpty line = [] | otherwise = line : takeInstanceDecl rest takeInstanceDecl [] = [] -- EOF reached + +isChildTable :: Statement -> Bool +isChildTable (StatementCreateTable CreateTable { name = "child_table" }) = True +isChildTable _ = False + diff --git a/ihp-ide/IHP/IDE/CodeGen/MigrationGenerator.hs b/ihp-ide/IHP/IDE/CodeGen/MigrationGenerator.hs index 26d06faf9..a9449b56c 100644 --- a/ihp-ide/IHP/IDE/CodeGen/MigrationGenerator.hs +++ b/ihp-ide/IHP/IDE/CodeGen/MigrationGenerator.hs @@ -196,6 +196,7 @@ removeNoise = filter \case migrateTable :: Statement -> Statement -> [Statement] migrateTable StatementCreateTable { unsafeGetCreateTable = targetTable } StatementCreateTable { unsafeGetCreateTable = actualTable } = migrateTable' targetTable actualTable where + migrateTable' :: CreateTable -> CreateTable -> [Statement] migrateTable' CreateTable { name = tableName, columns = targetColumns } CreateTable { columns = actualColumns } = (map dropColumn dropColumns <> map createColumn createColumns) |> applyRenameColumn @@ -451,7 +452,7 @@ normalizeConstraint tableName constraint@(UniqueConstraint { name = Just uniqueN -- let defaultName = ([tableName] <> columnNames <> ["key"]) - |> Text.intercalate "_" + |> Text.intercalate "_" in if uniqueName == defaultName then constraint { name = Nothing } From a21354766383f67ec3ae64f40fc2817f4d2399fa Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Sun, 15 Sep 2024 17:28:12 +0300 Subject: [PATCH 60/65] Note on Constraints in Inherited Tables --- Guide/database.markdown | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/Guide/database.markdown b/Guide/database.markdown index 0f02e110e..03fd0752d 100644 --- a/Guide/database.markdown +++ b/Guide/database.markdown @@ -915,3 +915,11 @@ action CreatePostRevisionAction { postId } = do - **Fetch and Set**: The action fetches the current post by its `postId`, then creates a new `PostRevision` record by setting its fields based on the current state of the post. - **CreateRecord**: The new revision is inserted into the `post_revisions` table. - **Redirect**: After creating the revision, the user is redirected to the appropriate page, such as showing the post. + +### Note on Constraints in Inherited Tables + +When using table inheritance in PostgreSQL and IHP, it's important to understand that constraints such as **UNIQUE**, **PRIMARY KEY**, and other table-level constraints are **not inherited** by child tables. While the child table inherits all the columns from its parent table, it does not inherit the constraints applied to those columns. + +#### Why Constraints Are Not Inherited + +This behavior is particularly useful in scenarios like creating revision or history tables. For example, consider a `posts` table where the `title` column has a **UNIQUE** constraint to prevent duplicate titles. When creating a `post_revisions` table that inherits from `posts`, you wouldn't want the **UNIQUE** constraint on `title` to apply. This is because multiple revisions of the same post might have the same `title`, and enforcing uniqueness would prevent this. \ No newline at end of file From c95783359162797a78c33cbe368e2f4ddfcb1197 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 16 Sep 2024 15:34:24 +0300 Subject: [PATCH 61/65] minor typo --- Test/Main.hs | 64 +++++++++++++++++------------------ ihp-ide/IHP/SchemaCompiler.hs | 2 +- 2 files changed, 33 insertions(+), 33 deletions(-) diff --git a/Test/Main.hs b/Test/Main.hs index 4a26b94cd..4410851db 100644 --- a/Test/Main.hs +++ b/Test/Main.hs @@ -52,36 +52,36 @@ import qualified Test.SEO.Sitemap main :: IO () main = hspec do - Test.IDE.SchemaDesigner.CompilerSpec.tests - Test.IDE.SchemaDesigner.ParserSpec.tests - Test.IDE.SchemaDesigner.Controller.EnumValuesSpec.tests - Test.IDE.SchemaDesigner.Controller.HelperSpec.tests - Test.IDE.SchemaDesigner.Controller.ValidationSpec.tests - Test.ValidationSupport.ValidateFieldSpec.tests - Test.IDE.CodeGeneration.ControllerGenerator.tests - Test.IDE.CodeGeneration.ViewGenerator.tests - Test.IDE.CodeGeneration.MailGenerator.tests - Test.IDE.CodeGeneration.JobGenerator.tests - Test.NameSupportSpec.tests - Test.HaskellSupportSpec.tests - Test.View.CSSFrameworkSpec.tests - Test.View.FormSpec.tests - Test.Controller.ContextSpec.tests - Test.Controller.ParamSpec.tests - Test.Controller.AccessDeniedSpec.tests - Test.Controller.NotFoundSpec.tests - Test.SchemaMigrationSpec.tests - Test.ModelSupportSpec.tests + -- Test.IDE.SchemaDesigner.CompilerSpec.tests + -- Test.IDE.SchemaDesigner.ParserSpec.tests + -- Test.IDE.SchemaDesigner.Controller.EnumValuesSpec.tests + -- Test.IDE.SchemaDesigner.Controller.HelperSpec.tests + -- Test.IDE.SchemaDesigner.Controller.ValidationSpec.tests + -- Test.ValidationSupport.ValidateFieldSpec.tests + -- Test.IDE.CodeGeneration.ControllerGenerator.tests + -- Test.IDE.CodeGeneration.ViewGenerator.tests + -- Test.IDE.CodeGeneration.MailGenerator.tests + -- Test.IDE.CodeGeneration.JobGenerator.tests + -- Test.NameSupportSpec.tests + -- Test.HaskellSupportSpec.tests + -- Test.View.CSSFrameworkSpec.tests + -- Test.View.FormSpec.tests + -- Test.Controller.ContextSpec.tests + -- Test.Controller.ParamSpec.tests + -- Test.Controller.AccessDeniedSpec.tests + -- Test.Controller.NotFoundSpec.tests + -- Test.SchemaMigrationSpec.tests + -- Test.ModelSupportSpec.tests Test.SchemaCompilerSpec.tests - Test.QueryBuilderSpec.tests - Test.RouterSupportSpec.tests - Test.ViewSupportSpec.tests - Test.ServerSideComponent.HtmlParserSpec.tests - Test.ServerSideComponent.HtmlDiffSpec.tests - Test.FileStorage.MimeTypesSpec.tests - Test.DataSync.DynamicQueryCompiler.tests - Test.IDE.SchemaDesigner.SchemaOperationsSpec.tests - Test.IDE.CodeGeneration.MigrationGenerator.tests - Test.Controller.CookieSpec.tests - Test.PGListenerSpec.tests - Test.SEO.Sitemap.tests + -- Test.QueryBuilderSpec.tests + -- Test.RouterSupportSpec.tests + -- Test.ViewSupportSpec.tests + -- Test.ServerSideComponent.HtmlParserSpec.tests + -- Test.ServerSideComponent.HtmlDiffSpec.tests + -- Test.FileStorage.MimeTypesSpec.tests + -- Test.DataSync.DynamicQueryCompiler.tests + -- Test.IDE.SchemaDesigner.SchemaOperationsSpec.tests + -- Test.IDE.CodeGeneration.MigrationGenerator.tests + -- Test.Controller.CookieSpec.tests + -- Test.PGListenerSpec.tests + -- Test.SEO.Sitemap.tests diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index db07ffac0..76b9baea3 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -509,7 +509,7 @@ isVariableAttribute :: (?schema :: Schema) => CreateTable -> Column -> Bool isVariableAttribute = isRefCol --- | Returns @True@ when the coluns is referencing another column via foreign key constraint +-- | Returns @True@ when the column is referencing another column via foreign key constraint isRefCol :: (?schema :: Schema) => CreateTable -> Column -> Bool isRefCol table column = isJust (findForeignKeyConstraint table column) From 2ce5f4fb1d6fe705b356ec747f28fa8fbb37d59c Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 16 Sep 2024 15:35:35 +0300 Subject: [PATCH 62/65] Remove duplicated func --- ihp-ide/IHP/SchemaCompiler.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 76b9baea3..3e9c0ea9c 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -431,7 +431,7 @@ dataFields table@(CreateTable { name, columns }) = columnFields <> queryBuilderF let fieldName = columnNameToFieldName column.name in ( fieldName - , if isVariableAttribute table column + , if isRefCol table column then fieldName else haskellType table column ) @@ -503,11 +503,7 @@ columnsReferencingTable theTableName = _ -> Nothing variableAttributes :: (?schema :: Schema) => CreateTable -> [Column] -variableAttributes table@(CreateTable { columns }) = filter (isVariableAttribute table) columns - -isVariableAttribute :: (?schema :: Schema) => CreateTable -> Column -> Bool -isVariableAttribute = isRefCol - +variableAttributes table@(CreateTable { columns }) = filter (isRefCol table) columns -- | Returns @True@ when the column is referencing another column via foreign key constraint isRefCol :: (?schema :: Schema) => CreateTable -> Column -> Bool From c727968ff82c7bc8b1dacf6b863d16aa755c6a09 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 16 Sep 2024 15:36:17 +0300 Subject: [PATCH 63/65] Revert "minor typo" This reverts commit c95783359162797a78c33cbe368e2f4ddfcb1197. --- Test/Main.hs | 64 +++++++++++++++++------------------ ihp-ide/IHP/SchemaCompiler.hs | 2 +- 2 files changed, 33 insertions(+), 33 deletions(-) diff --git a/Test/Main.hs b/Test/Main.hs index 4410851db..4a26b94cd 100644 --- a/Test/Main.hs +++ b/Test/Main.hs @@ -52,36 +52,36 @@ import qualified Test.SEO.Sitemap main :: IO () main = hspec do - -- Test.IDE.SchemaDesigner.CompilerSpec.tests - -- Test.IDE.SchemaDesigner.ParserSpec.tests - -- Test.IDE.SchemaDesigner.Controller.EnumValuesSpec.tests - -- Test.IDE.SchemaDesigner.Controller.HelperSpec.tests - -- Test.IDE.SchemaDesigner.Controller.ValidationSpec.tests - -- Test.ValidationSupport.ValidateFieldSpec.tests - -- Test.IDE.CodeGeneration.ControllerGenerator.tests - -- Test.IDE.CodeGeneration.ViewGenerator.tests - -- Test.IDE.CodeGeneration.MailGenerator.tests - -- Test.IDE.CodeGeneration.JobGenerator.tests - -- Test.NameSupportSpec.tests - -- Test.HaskellSupportSpec.tests - -- Test.View.CSSFrameworkSpec.tests - -- Test.View.FormSpec.tests - -- Test.Controller.ContextSpec.tests - -- Test.Controller.ParamSpec.tests - -- Test.Controller.AccessDeniedSpec.tests - -- Test.Controller.NotFoundSpec.tests - -- Test.SchemaMigrationSpec.tests - -- Test.ModelSupportSpec.tests + Test.IDE.SchemaDesigner.CompilerSpec.tests + Test.IDE.SchemaDesigner.ParserSpec.tests + Test.IDE.SchemaDesigner.Controller.EnumValuesSpec.tests + Test.IDE.SchemaDesigner.Controller.HelperSpec.tests + Test.IDE.SchemaDesigner.Controller.ValidationSpec.tests + Test.ValidationSupport.ValidateFieldSpec.tests + Test.IDE.CodeGeneration.ControllerGenerator.tests + Test.IDE.CodeGeneration.ViewGenerator.tests + Test.IDE.CodeGeneration.MailGenerator.tests + Test.IDE.CodeGeneration.JobGenerator.tests + Test.NameSupportSpec.tests + Test.HaskellSupportSpec.tests + Test.View.CSSFrameworkSpec.tests + Test.View.FormSpec.tests + Test.Controller.ContextSpec.tests + Test.Controller.ParamSpec.tests + Test.Controller.AccessDeniedSpec.tests + Test.Controller.NotFoundSpec.tests + Test.SchemaMigrationSpec.tests + Test.ModelSupportSpec.tests Test.SchemaCompilerSpec.tests - -- Test.QueryBuilderSpec.tests - -- Test.RouterSupportSpec.tests - -- Test.ViewSupportSpec.tests - -- Test.ServerSideComponent.HtmlParserSpec.tests - -- Test.ServerSideComponent.HtmlDiffSpec.tests - -- Test.FileStorage.MimeTypesSpec.tests - -- Test.DataSync.DynamicQueryCompiler.tests - -- Test.IDE.SchemaDesigner.SchemaOperationsSpec.tests - -- Test.IDE.CodeGeneration.MigrationGenerator.tests - -- Test.Controller.CookieSpec.tests - -- Test.PGListenerSpec.tests - -- Test.SEO.Sitemap.tests + Test.QueryBuilderSpec.tests + Test.RouterSupportSpec.tests + Test.ViewSupportSpec.tests + Test.ServerSideComponent.HtmlParserSpec.tests + Test.ServerSideComponent.HtmlDiffSpec.tests + Test.FileStorage.MimeTypesSpec.tests + Test.DataSync.DynamicQueryCompiler.tests + Test.IDE.SchemaDesigner.SchemaOperationsSpec.tests + Test.IDE.CodeGeneration.MigrationGenerator.tests + Test.Controller.CookieSpec.tests + Test.PGListenerSpec.tests + Test.SEO.Sitemap.tests diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 3e9c0ea9c..bf30a1dfb 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -505,7 +505,7 @@ columnsReferencingTable theTableName = variableAttributes :: (?schema :: Schema) => CreateTable -> [Column] variableAttributes table@(CreateTable { columns }) = filter (isRefCol table) columns --- | Returns @True@ when the column is referencing another column via foreign key constraint +-- | Returns @True@ when the coluns is referencing another column via foreign key constraint isRefCol :: (?schema :: Schema) => CreateTable -> Column -> Bool isRefCol table column = isJust (findForeignKeyConstraint table column) From c1806277a37e4e6f9c22f609eeabdc8eb7635931 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 16 Sep 2024 15:36:41 +0300 Subject: [PATCH 64/65] Fix typo --- ihp-ide/IHP/SchemaCompiler.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index bf30a1dfb..3e9c0ea9c 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -505,7 +505,7 @@ columnsReferencingTable theTableName = variableAttributes :: (?schema :: Schema) => CreateTable -> [Column] variableAttributes table@(CreateTable { columns }) = filter (isRefCol table) columns --- | Returns @True@ when the coluns is referencing another column via foreign key constraint +-- | Returns @True@ when the column is referencing another column via foreign key constraint isRefCol :: (?schema :: Schema) => CreateTable -> Column -> Bool isRefCol table column = isJust (findForeignKeyConstraint table column) From f2d002a428c0d014bd2b69d36682b49e7b318d54 Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 16 Sep 2024 15:41:34 +0300 Subject: [PATCH 65/65] more readable code --- ihp-ide/IHP/SchemaCompiler.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/ihp-ide/IHP/SchemaCompiler.hs b/ihp-ide/IHP/SchemaCompiler.hs index 3e9c0ea9c..08254a1ed 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -1278,7 +1278,7 @@ hasExplicitOrImplicitDefault column = case column of findTableByName :: (?schema :: Schema) => Text -> Maybe Statement -findTableByName tableName = ?schema.statements - |> find (\case - StatementCreateTable CreateTable { name } | name == tableName -> True - _ -> False) \ No newline at end of file +findTableByName tableName = find matchesTable ?schema.statements + where + matchesTable (StatementCreateTable CreateTable { name }) = name == tableName + matchesTable _ = False