diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 37ac4d6a7..51325af12 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -78,12 +78,16 @@ 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 -:l IHP/exe/IHP/IDE/DevServer.hs -main + +-- Load the development server + :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. diff --git a/Guide/database.markdown b/Guide/database.markdown index ed1c145c6..03fd0752d 100644 --- a/Guide/database.markdown +++ b/Guide/database.markdown @@ -853,3 +853,73 @@ 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. + +### 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 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) = 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/CompilerSpec.hs b/Test/IDE/SchemaDesigner/CompilerSpec.hs index 22a2f3bc4..962965fa3 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 @@ -628,7 +638,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 @@ -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 @@ -841,7 +851,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" @@ -1030,6 +1040,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = False + , inherits = Nothing } ] compileSql statements `shouldBe` sql @@ -1040,16 +1051,17 @@ tests = do it "should compile 'CREATE UNLOGGED TABLE' statements" do let sql = [trimming| CREATE UNLOGGED TABLE pg_large_notifications ( - + ); |] <> "\n" let statements = [ StatementCreateTable CreateTable { name = "pg_large_notifications" , columns = [] + , primaryKeyConstraint = PrimaryKeyConstraint [] , constraints = [] , unlogged = True - , primaryKeyConstraint = PrimaryKeyConstraint [] + , inherits = Nothing } ] compileSql statements `shouldBe` sql @@ -1067,4 +1079,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 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"] 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 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..8a9cc36c2 100644 --- a/Test/SchemaCompilerSpec.hs +++ b/Test/SchemaCompilerSpec.hs @@ -119,13 +119,14 @@ 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 it "should compile CanCreate instance with sqlQuery" $ \statement -> do @@ -157,7 +158,9 @@ tests = do primaryKeyConstraint = PrimaryKeyConstraint ["id"], constraints = [] , unlogged = False + , inherits = Nothing } + let compileOutput = compileStatementPreview [statement] statement |> Text.strip getInstanceDecl "CanUpdate" compileOutput `shouldBe` [trimming| @@ -177,15 +180,16 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } 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 @@ -242,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" @@ -252,15 +260,16 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } 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 @@ -317,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" @@ -327,15 +339,16 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } 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 @@ -391,6 +404,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 ( @@ -415,7 +431,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 +497,7 @@ tests = do , primaryKeyConstraint = PrimaryKeyConstraint ["id"] , constraints = [] , unlogged = False + , inherits = Nothing } let compileOutput = compileStatementPreview [statement] statement |> Text.strip @@ -513,7 +530,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 +599,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 @@ -647,16 +664,97 @@ tests = do columns = [ Column "id" PUUID Nothing True True Nothing ], primaryKeyConstraint = PrimaryKeyConstraint ["id"], constraints = [], - unlogged = False + 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 = 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 = @@ -675,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 } 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 <> ")" <> ";" diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/Parser.hs b/ihp-ide/IHP/IDE/SchemaDesigner/Parser.hs index 753e0c21c..2fc9a439d 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, @@ -116,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" @@ -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/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 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) diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs b/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs index 2105f17cc..1ff36e1a0 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/View/Layout.hs @@ -222,6 +222,9 @@ renderColumnSelector tableName columns statements = [hsx| {forEach columns (\column -> renderColumn (snd column) (fst column) tableName statements)} + + {maybeInherits} + {suggestedColumnsSection tableName columns} {auth} @@ -246,11 +249,26 @@ renderColumnSelector tableName columns statements = [hsx| {renderColumnIndexes tableName statements} |] - Nothing -> [hsx||] + Nothing -> "" auth :: Html auth = renderPolicies tableName statements + 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 suggestedColumnsSection tableName indexAndColumns = unless isUsersTable [hsx|
@@ -411,7 +429,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 31237b3c8..08254a1ed 100644 --- a/ihp-ide/IHP/SchemaCompiler.hs +++ b/ihp-ide/IHP/SchemaCompiler.hs @@ -317,13 +317,14 @@ 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,23 +333,77 @@ 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 + parentTypes = map (haskellType parentCreateTable) (variableAttributes parentCreateTable) + in if null parentTypes + then [] + -- Add space if there are parent types. + else " " : parentTypes + + -- Satisfy the compiler. + Nothing -> error $ "Parent table " <> cs parentTableName <> " not found for table " <> cs name + + + primaryKeyTypeName :: Text -> Text primaryKeyTypeName name = "Id' " <> tshow name <> "" compileData :: (?schema :: Schema) => CreateTable -> Text -compileData table@(CreateTable { name, columns }) = - "data " <> modelName <> "' " <> typeArguments - <> " = " <> modelName <> " {" - <> - table - |> dataFields +compileData table@(CreateTable { name, inherits }) = + "data " <> modelName <> "' " <> typeArguments <> " = " <> modelName <> " {" + <> + allDataFields |> map (\(fieldName, fieldType) -> fieldName <> " :: " <> fieldType) |> commaSep - <> "} deriving (Eq, Show)\n" + <> "} deriving (Eq, Show)\n" where modelName = tableNameToModelName name + + -- @todo: Find a better way. + colName = modelName |> pluralize |> Text.toLower + 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)) + -- We remove ref to own table (e.g. `post_revisions` table should not have postRevisions) + |> filter (\fieldName -> Text.toLower fieldName /= colName) + |> unwords + + 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")] + compileInputValueInstance :: CreateTable -> Text compileInputValueInstance table = @@ -376,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 ) @@ -401,7 +456,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 @@ -448,13 +503,9 @@ 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 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) @@ -542,11 +593,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) @@ -597,11 +664,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 @@ -642,17 +725,50 @@ 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} - let theRecord = #{modelName} #{intercalate " " (map compileField (dataFields table))} + let theRecord = #{modelName} #{intercalate " " (map compileField allDataFields)} pure theRecord |] where modelName = tableNameToModelName name - columnNames = map (columnNameToFieldName . (.name)) columns + + -- @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") + + + -- 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 @@ -729,11 +845,29 @@ instance FromRow #{modelName} where -- otherwise -> toBinding modelName attributes 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 + 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 |> 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 <> "." + + allColumns = columns <> parentColumns + -- @todo: Parent is not needed? + allColumnsReferencingTable = columnsReferencingTable name -- <> parentColumnsReferencingTable compileDefaultIdInstance :: CreateTable -> Text compileDefaultIdInstance table = "instance Default (Id' \"" <> table.name <> "\") where def = Id def" @@ -769,9 +903,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" @@ -846,35 +996,139 @@ 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)) + |> filter (\(fieldName, _) -> fieldName /= "meta") + |> 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" +compileGetModelName table@(CreateTable { name, inherits }) = + let + -- @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. + 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) +compileDataTypePattern table@(CreateTable { name, inherits }) = tableNameToModelName name <> " " <> unwords (allDataFields |> map fst) + where + modelName = tableNameToModelName name + + -- @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") + + + -- Place the `meta` as the last value. + allDataFields = currentDataFields <> parentDataFields + |> \fields -> fields <> [("meta", "MetaBag")] 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 + |> 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 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 @@ -886,16 +1140,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 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 - 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" @@ -903,14 +1176,47 @@ 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 allDataFields) 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))) + -- @todo: Find a better way. + colName = modelName |> pluralize |> Text.toLower + + 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 + + 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 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` typeArgs + if name `elem` allTypeArguments then (name, name <> "'") else (fieldType, fieldType) @@ -920,7 +1226,9 @@ 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 = tableNameToModelName table.name <> "' " <> unwords (map (\f -> if f == name then name <> "'" else f) allTypeArguments) + + compileHasFieldId :: (?schema :: Schema) => CreateTable -> Text compileHasFieldId table@CreateTable { name, primaryKeyConstraint } = cs [i| @@ -967,3 +1275,10 @@ hasExplicitOrImplicitDefault column = case column of Column { columnType = PSerial } -> True Column { columnType = PBigserial } -> True _ -> False + + +findTableByName :: (?schema :: Schema) => Text -> Maybe Statement +findTableByName tableName = find matchesTable ?schema.statements + where + matchesTable (StatementCreateTable CreateTable { name }) = name == tableName + matchesTable _ = False