Create the Schema class and change tests to use schema(...).create wh…

…ere needed
FCO · Jan 12, 2020 · 660495d · 660495d
1 parent e59b314
commit 660495d
Show file tree

Hide file tree

Showing 40 changed files with 316 additions and 140 deletions.
diff --git a/META6.json b/META6.json
@@ -26,6 +26,7 @@
     "MetamodelX::Red::Relationship" : "lib/MetamodelX/Red/Relationship.pm6",
     "Red" : "lib/Red.pm6",
     "Red::AST" : "lib/Red/AST.pm6",
+    "Red::AST::AddForeignKeyOnTable" : "lib/Red/AST/AddForeignKeyOnTable.pm6",
     "Red::AST::BeginTransaction" : "lib/Red/AST/BeginTransaction.pm6",
     "Red::AST::Case" : "lib/Red/AST/Case.pm6",
     "Red::AST::Chained" : "lib/Red/AST/Chained.pm6",
@@ -104,6 +105,7 @@
     "Red::ResultSeq" : "lib/Red/ResultSeq.pm6",
     "Red::ResultSeq::Iterator" : "lib/Red/ResultSeq/Iterator.pm6",
     "Red::ResultSeqSeq" : "lib/Red/ResultSeqSeq.pm6",
+    "Red::Schema" : "lib/Red/Schema.pm6",
     "Red::SchemaReader" : "lib/Red/SchemaReader.pm6",
     "Red::Statement" : "lib/Red/Statement.pm6",
     "Red::Traits" : "lib/Red/Traits.pm6",

diff --git a/lib/Red.pm6 b/lib/Red.pm6
@@ -19,6 +19,7 @@ use Red::AST::Optimizer::OR;
 use Red::AST::Optimizer::Case;
 use Red::Class;
 use Red::DB;
+use Red::Schema;
 
 class Red:ver<0.1.4>:api<2> {
     method events { Red::Class.instance.events }
@@ -50,6 +51,7 @@ multi EXPORT("experimental migrations") {
         Red::Do::EXPORT::ALL::,
         Red::Traits::EXPORT::ALL::,
         Red::Operators::EXPORT::ALL::,
+        Red::Schema::EXPORT::ALL::,
         ‘&database’ => &database,
     )
 }
@@ -59,6 +61,7 @@ multi EXPORT {
         Red::Do::EXPORT::ALL::,
         Red::Traits::EXPORT::ALL::,
         Red::Operators::EXPORT::ALL::,
+        Red::Schema::EXPORT::ALL::,
         ‘&database’ => &database,
     )
 }

diff --git a/lib/Red/AST/AddForeignKeyOnTable.pm6 b/lib/Red/AST/AddForeignKeyOnTable.pm6
@@ -0,0 +1,23 @@
+use Red::Column;
+unit class Red::AST::AddForeignKeyOnTable does Red::AST;
+
+class Fk {
+    has Str         $.name;
+    has Red::Column $.from is required;
+    has Red::Column $.to   is required;
+}
+
+has Str $.table;
+has Fk  @.foreigns;
+
+method new(:$table, :@foreigns) {
+    self.bless: :$table, :foreigns(Array[Fk].new: @foreigns.map: {
+        Fk.new: :from(.<from>), :to(.<to>), |(:name($_) with .<name>),
+    })
+}
+
+method args {}
+
+method returns {}
+
+method find-column-name {}
diff --git a/lib/Red/Do.pm6 b/lib/Red/Do.pm6
@@ -138,7 +138,6 @@ multi red-do(
     KEEP get-RED-DB.commit;
     UNDO get-RED-DB.rollback;
     red-do |@blocks, :$async, |%pars, :with(get-RED-DB.begin);
-    True
 }
 
 #| Receives list of pairs with connection name and block

diff --git a/lib/Red/Driver/CommonSQL.pm6 b/lib/Red/Driver/CommonSQL.pm6
@@ -26,6 +26,7 @@ use Red::AST::CommitTransaction;
 use Red::AST::RollbackTransaction;
 use Red::AST::Generic::Prefix;
 use Red::AST::Generic::Postfix;
+use Red::AST::AddForeignKeyOnTable;
 use Red::Cli::Column;
 use Red::FromRelationship;
 use Red::Driver;
@@ -165,82 +166,134 @@ multi method diff-to-ast(@diff) {
     @diff.map({ |self.diff-to-ast(|$_).pairs }).classify(|*.key, :as{ |.value }).sort.map: *.value
 }
 
+method create-schema(%models where .values.all ~~ Red::Model) {
+    for %models.kv -> Str() $name, Red::Model \model {
+        self.execute: Red::AST::CreateTable.new:
+                :name(model.^table),
+                :temp(model.^temp),
+                :columns(model.^columns.map(*.column.clone: :references(Callable), :class(model))),
+                |(:comment(Red::AST::TableComment.new: :msg(.Str), :table(model.^table)) with model.WHY)
+    }
+
+    for %models.kv -> Str() $name, Red::Model \model {
+        my @fks = model.^columns>>.column.grep({ .ref.defined });
+        self.execute: Red::AST::AddForeignKeyOnTable.new:
+                :table(model.^table),
+                :foreigns[@fks.map: {
+                    %(
+                            :name("{
+                                .class.^table
+                            }_{
+                                .name
+                            }_{
+                                .ref.class.^table
+                            }_{
+                                .ref.name
+                            }_fkey"),
+                            :from($_),
+                            :to(.ref),
+                    )
+                }]
+        if @fks
+    }
+    %models.keys Z=> True xx *
+}
+
 proto method translate(Red::AST, $? --> Pair) {*}
 
 multi method translate(Red::AST::BeginTransaction, $context?) {
-    "BEGIN" => []
-}
+                                    "BEGIN" => []
+                                }
 
 multi method translate(Red::AST::CommitTransaction, $context?) {
-    "COMMIT" => []
-}
+                                    "COMMIT" => []
+                                }
 
 multi method translate(Red::AST::RollbackTransaction, $context?) {
-    "ROLLBACK" => []
-}
+                                    "ROLLBACK" => []
+                                }
 
 multi method translate(Red::AST::DropColumn $_, $context?) {
-    "ALTER TABLE {
-        .table
-    } DROP COLUMN {
-        .name
-    }" => []
-}
+                                    "ALTER TABLE {
+                                        .table
+                                    } DROP COLUMN {
+                                        .name
+                                    }" => []
+                                }
 
 multi method translate(Red::AST::ChangeColumn $_, $context?) {
-    "ALTER TABLE {
-        .table
-    } ALTER COLUMN {
-        .name
-    } {
-        .type // ""
-    }{
-        " NOT NULL" unless .nullable
-    }{
-        " UNIQUE" if .unique
-    }{
-        " REFERENCES { .ref-table }({ .ref-col })" if .ref-table and .ref-col
-    }{
-        " PRIMARY KEY" if .pk
-    }" => []
-}
+                                    "ALTER TABLE {
+                                        .table
+                                    } ALTER COLUMN {
+                                        .name
+                                    } {
+                                        .type // ""
+                                    }{
+                                        " NOT NULL" unless .nullable
+                                    }{
+                                        " UNIQUE" if .unique
+                                    }{
+                                        " REFERENCES { .ref-table }({ .ref-col })" if .ref-table and .ref-col
+                                    }{
+                                        " PRIMARY KEY" if .pk
+                                    }" => []
+                                }
 
 multi method translate(Red::AST::CreateColumn $_, $context?) {
-    "ALTER TABLE {
-        .table
-    } ADD {
-        .name
-    } {
-        .type
-    }{
-        " NOT NULL" unless .nullable
-    }{
-        " UNIQUE" if .unique
-    }{
-        " REFERENCES { .ref-table }({ .ref-col })" if .ref-table and .ref-col
-    }{
-        " PRIMARY KEY" if .pk
-    }" => []
-}
+                                    "ALTER TABLE {
+                                        .table
+                                    } ADD {
+                                        .name
+                                    } {
+                                        .type
+                                    }{
+                                        " NOT NULL" unless .nullable
+                                    }{
+                                        " UNIQUE" if .unique
+                                    }{
+                                        " REFERENCES { .ref-table }({ .ref-col })" if .ref-table and .ref-col
+                                    }{
+                                        " PRIMARY KEY" if .pk
+                                    }" => []
+                                }
+
+multi method translate(Red::AST::AddForeignKeyOnTable $_, $context?) {
+                                    "ALTER TABLE {
+                                        .table
+                                    } {
+                                        .foreigns.map({
+                                            "ADD CONSTRAINT {
+                                                $_ with .name
+                                            } FOREIGN KEY ({
+                                                .from.name
+                                            }) REFERENCES {
+                                                .to.class.^table
+                                            }({
+                                                .to.name
+                                            })"
+                                        }).join(" ")
+                                    }" => []
+
+                                }
 
 multi method translate(Red::AST::Union $ast, $context?) {
-    $ast.selects.map({
-        self.translate( $_, "multi-select" ).key
-    })
-    .join("\n{
-        self.translate($ast, "multi-select-op").key
-    }\n") => []
-}
+                                    $ast.selects.map({
+                                        self.translate( $_, "multi-select" ).key
+                                    })
+                                            .join("\n{
+                                        self.translate($ast, "multi-select-op").key
+                                    }\n") => []
+                                }
 
 multi method translate(Red::AST::Intersect $ast, $context?) {
-    $ast.selects.map({ self.translate( $_, "multi-select").key })
-            .join("\n{ self.translate($ast, "multi-select-op").key }\n") => []
-}
+                                    $ast.selects.map({ self.translate( $_, "multi-select").key })
+                                            .join("\n{ self.translate($ast, "multi-select-op").key }\n") => []
+                                }
 
 multi method translate(Red::AST::Minus $ast, $context?) {
-    $ast.selects.map({ self.translate( $_, "multi-select" ).key })
-            .join("\n{ self.translate($ast, "multi-select-op").key }\n") => []
-}
+                                    $ast.selects.map({ self.translate( $_, "multi-select" ).key })
+                                            .join("\n{ self.translate($ast, "multi-select-op").key }\n") => []
+                                }
 
 multi method translate(Red::AST::Union $ast, "multi-select-op") { "UNION" => [] }
 multi method translate(Red::AST::Intersect $ast, "multi-select-op") { "INTERSECT" => [] }

diff --git a/lib/Red/Driver/SQLite.pm6 b/lib/Red/Driver/SQLite.pm6
@@ -50,6 +50,12 @@ multi method prepare(Str $query) {
     Statement.new: :driver(self), :statement($!dbh.prepare: $query);
 }
 
+method create-schema(%models where .values.all ~~ Red::Model) {
+    do for %models.kv -> Str() $name, Red::Model $model {
+        $name => $model.^create-table
+    }
+}
+
 multi method join-type("outer") { die "'OUTER JOIN' is not supported by SQLite" }
 multi method join-type("right") { die "'RIGHT JOIN' is not supported by SQLite" }
 

diff --git a/lib/Red/Schema.pm6 b/lib/Red/Schema.pm6
@@ -0,0 +1,28 @@
+use Red::Do;
+unit class Red::Schema;
+
+sub schema(+@models) is export {
+    ::?CLASS.new: @models
+}
+
+has %.models;
+
+method new(@models) {
+    my %models = @models.map: {
+        do if $_ ~~ Str {
+            require ::($_);
+            $_ => ::($_)
+        } else {
+            .^name => $_
+        }
+    }
+    self.bless: :%models
+}
+
+method FALLBACK(Str $name) { %!models{ $name } }
+
+method create(:$where) {
+    red-do (:$where with $where), :transaction, {
+        %( |.create-schema(%!models) )
+    }
+}
diff --git a/t/04-blog.t b/t/04-blog.t
@@ -30,10 +30,11 @@ model Person is rw {
 
 my $*RED-DEBUG          = $_ with %*ENV<RED_DEBUG>;
 my $*RED-DEBUG-RESPONSE = $_ with %*ENV<RED_DEBUG_RESPONSE>;
-my $*RED-DB             = database "SQLite", |(:database($_) with %*ENV<RED_DATABASE>);
+my @conf                = (%*ENV<RED_DATABASE> // "SQLite").split(" ");
+my $driver              = @conf.shift;
+my $*RED-DB             = database $driver, |%( @conf.map: { do given .split: "=" { .[0] => .[1] } } );
 
-lives-ok { Person.^create-table }
-lives-ok { Post.^create-table }
+lives-ok { schema(Person, Post).create }
 
 my $p;
 lives-ok { $p = Person.^create: :name<Fernando> }

diff --git a/t/05-ticket.t b/t/05-ticket.t
@@ -3,7 +3,9 @@ use Red;
 
 my $*RED-DEBUG          = $_ with %*ENV<RED_DEBUG>;
 my $*RED-DEBUG-RESPONSE = $_ with %*ENV<RED_DEBUG_RESPONSE>;
-my $*RED-DB             = database "SQLite", |(:database($_) with %*ENV<RED_DATABASE>);
+my @conf                = (%*ENV<RED_DATABASE> // "SQLite").split(" ");
+my $driver              = @conf.shift;
+my $*RED-DB             = database $driver, |%( @conf.map: { do given .split: "=" { .[0] => .[1] } } );
 
 model TicketStatus {
     has UInt $.id       is serial;
@@ -37,8 +39,7 @@ model Ticket is rw {
     has Person          $.author    is relationship{ .author-id }
 }
 
-Ticket.^create-table;
-Person.^create-table;
+schema(Ticket, Person).create;
 
 my \me = Person.^create: :name<Me>;
 isa-ok me, Person;

diff --git a/t/08-best-tree.t b/t/08-best-tree.t
@@ -36,9 +36,11 @@ model BestTree::Store is table<tree> {
 
 my $*RED-DEBUG          = $_ with %*ENV<RED_DEBUG>;
 my $*RED-DEBUG-RESPONSE = $_ with %*ENV<RED_DEBUG_RESPONSE>;
-my $*RED-DB             = database "SQLite", |(:database($_) with %*ENV<RED_DATABASE>);
+my @conf                = (%*ENV<RED_DATABASE> // "SQLite").split(" ");
+my $driver              = @conf.shift;
+my $*RED-DB             = database $driver, |%( @conf.map: { do given .split: "=" { .[0] => .[1] } } );
 
-lives-ok { BestTree::Store.^create-table }
+lives-ok { schema(BestTree::Store).create }
 
 is BestTree::Store.all-trees, ();
 is-deeply BestTree::Store.find-tree(1.1, 2.1), Nil;

diff --git a/t/09-alternate-relation.t b/t/09-alternate-relation.t
@@ -23,10 +23,11 @@ model Person is rw {
 
 my $*RED-DEBUG          = $_ with %*ENV<RED_DEBUG>;
 my $*RED-DEBUG-RESPONSE = $_ with %*ENV<RED_DEBUG_RESPONSE>;
-my $*RED-DB             = database "SQLite", |(:database($_) with %*ENV<RED_DATABASE>);
+my @conf                = (%*ENV<RED_DATABASE> // "SQLite").split(" ");
+my $driver              = @conf.shift;
+my $*RED-DB             = database $driver, |%( @conf.map: { do given .split: "=" { .[0] => .[1] } } );
 
-lives-ok { Person.^create-table }, "create table for Person";
-lives-ok { Post.^create-table }, "create table for Post";
+lives-ok { schema(Person, Post).create }, "create table for Person and Post";
 
 my $p;
 lives-ok { $p = Person.^create: :name<Fernando> }, "Create a Person";