WiP: .^create from belongs-to relationship

lib/MetamodelX/Red/Model.pm6

@@ -223,19 +223,20 @@ method alias(|c (Red::Model:U \type, Str $name = "{type.^name}_{$alias_num++}",
     my \alias = ::?CLASS.new_type(:$name);
     %!alias-cache{$name} := alias;
     my role RAlias[Red::Model:U \rtype, Str $rname, \alias, \rel, \base, \join-type, @cols] {
-        method columns(|)     { @cols }
-        method table(|)       { rtype.^table }
-        method as(|)          { self.table-formatter: $rname }
-        method orig(|)        { rtype }
-        method join-type(|)   { join-type }
-        method tables(|)      { [ |base.^tables, alias ] }
-        method join-on(|)     {
+        method parent(|) is rw { $ }
+        method columns(|)      { @cols }
+        method table(|)        { rtype.^table }
+        method as(|)           { self.table-formatter: $rname }
+        method orig(|)         { rtype }
+        method join-type(|)    { join-type }
+        method tables(|)       { [ |base.^tables, alias ] }
+        method join-on($, \a = alias) {
             do given rel {
                 when Red::AST {
                     $_
                 }
                 when Callable {
-                    my $filter = do given what-does-it-do($_, alias) {
+                    my $filter = do given what-does-it-do($_, a) {
                         do if [eqv] .values {
                             .values.head
                         } else {
@@ -254,7 +255,7 @@ method alias(|c (Red::Model:U \type, Str $name = "{type.^name}_{$alias_num++}",
                     $filter
                 }
                 default {
-                    .relationship-ast(alias)
+                    .relationship-ast(a)
 
                 }
             }
@@ -455,7 +456,8 @@ multi method create(Str :$with!, |c) is hidden-from-backtrace {
 #| Creates a new object and saves it on DB
 #| It accepts a list os pairs (the same as C<.new>)
 #| And Lists and/or Hashes for relationships
-multi method create(\model where *.DEFINITE, *%orig-pars, :$with where not .defined) is hidden-from-backtrace is rw {
+multi method create(\mo where *.DEFINITE, *%orig-pars, :$with where not .defined) is hidden-from-backtrace is rw {
+    my \model = mo.^orig;
     my $RED-DB = get-RED-DB;
     my $trans  = so $*RED-TRANSCTION-RUNNING;
     $RED-DB   .= begin    unless $trans;
@@ -470,6 +472,8 @@ multi method create(\model where *.DEFINITE, *%orig-pars, :$with where not .defi
         my %pars;
         my %positionals;
         my %has-one{Mu};
+        # TODO: make it before creating transaction
+        die "Not possible call .^create on a defined model" if mo.defined;
 
         for %orig-pars.kv -> $name, $val {
             my \attr = model.^attributes.first(*.name.substr(2) eq $name);
@@ -531,6 +535,29 @@ multi method create(\model where *.DEFINITE, *%orig-pars, :$with where not .defi
             $type.^create: |%( |%val, $id-name => $no.^id-values.head )
         }
         self.apply-row-phasers($obj, AfterCreate);
+
+        if mo.HOW.?join-on(mo) && mo.HOW.?parent(mo) {
+            my $obj;
+            my $*RED-DB = $RED-DB;
+            if !$data.elems {
+                $obj = model.^find: $filter
+            } else {
+                $obj = model.^new-from-data($data.elems ?? |$data !! |%orig-pars);
+                $obj.^saved-on-db;
+                $obj.^clean-up;
+                $obj.^populate-ids;
+            }
+            my %should-set = |mo.^join-on(mo.^parent).should-set.Hash if mo.HOW.?join-on: mo;
+            my $p = mo.^parent;
+            my %attrs = |$p.^columns.map: { .name.substr(2) => .self }
+            for %should-set.kv -> $name, $value {
+                $p.^set-attr: $name, $value;
+                $p.^set-dirty: %attrs{ $name };
+            }
+            $p.^save;
+            return $obj
+        }
+
         return-rw Proxy.new:
                 STORE => -> | {
                     die X::Assignment::RO.new(value => $obj)

lib/MetamodelX/Red/Relationship.pm6

@@ -160,7 +160,11 @@ multi method add-relationship(::Type Mu:U $self, Red::Attr::Relationship $attr)
         } else {
             $self.^add_multi_method: $name, my method (Mu:D:) is rw {
                 use nqp;
-                nqp::getattr(self, self.WHAT, $attr.name)
+                my \value = nqp::getattr(self, self.WHAT, $attr.name);
+                my $n = $self.WHAT."$name"();
+                $n.^parent = self if $n.HOW.^can: "parent";
+                return $n unless value;
+                value
             }
         }
     }

lib/Red/Attr/Relationship.pm6

@@ -15,7 +15,7 @@ unit role Red::Attr::Relationship[
     Red::Model  :$model-type,
 ];
 
-has Mu:U $!type;
+#has Mu:U $!type;
 
 has Bool $.has-lazy-relationship = ?$model;
 
@@ -110,8 +110,8 @@ method build-relationship(\instance) is hidden-from-sql-commenting {
                     Red::AST::AND.new: $left, $right
                 }))
             }
-	    return ret.head if type !~~ Positional || attr.has-one;
-	    ret
+            return ret.head if type !~~ Positional || attr.has-one;
+            ret
         },
         STORE => method ($value where type) {
             die X::Assignment::RO.new(value => attr.type) unless attr.rw;
@@ -137,7 +137,7 @@ method relationship-ast($type = Nil) is hidden-from-sql-commenting {
     my \type = self.relationship-argument-type;
     my @col1 = |rel1 type;
     @col1.map({
-        Red::AST::Eq.new: $_, .ref: $type
+        Red::AST::Eq.new: $_, ast-value .ref: $type
     }).reduce: -> $agg, $i {
         Red::AST::AND.new: $agg, $i
     }

lib/Red/Column.pm6

@@ -139,7 +139,9 @@ class ReferencesProxy does Callable {
     }
 
     method CALL-ME($alias = Nil) {
-        if &!references {
+        do if $alias.DEFINITE {
+            &!references.($alias)
+        } elsif &!references {
             my $model = self.model($alias);
             my $ret = &!references.($model);
             if $ret ~~ Red::Column && $ret.class.^name eq '$?CLASS' {

lib/Red/PrepareCode.pm6

@@ -93,4 +93,4 @@ sub what-does-it-do(&func, \type --> Hash) is export {
         %values{hash-to-cond(.[0])} = prepare-response .[1]
     }
     %values
-}
+}

t/35-create.t

@@ -25,6 +25,63 @@ my $*RED-DB             = database $driver, |%( @conf.map: { do given .split: "=
 
 schema(Bla, Ble).drop.create;
 
+# TODO: Figure out why this test can't be the last one
+subtest "Create on has-one", {
+    my $ble = Ble.^create(:value<ble>);
+    my $bla = $ble.bla.^create: :value<bla>;
+    is $bla.bles.head.gist, $ble.gist;
+    is $ble.bla.gist, $bla.gist;
+}
+
+subtest "belogs-to using types", {
+    model Blo { ... }
+    model Bli {
+        has UInt $.id      is serial;
+        has Str  $.value   is column;
+        has Blo  @.blos    is relationship(*.bli-id, :model(Blo));
+        has Blo  $.one-blo is relationship(*.bli-id, :model(Blo), :has-one);
+    }
+
+    model Blo {
+        has UInt $.id     is serial;
+        has Str  $.value  is column;
+        has UInt $.bli-id is referencing(*.id, :model(Bli));
+        has Bli  $.bli    is relationship(*.bli-id, :model(Bli));
+    }
+
+    schema(Bli, Blo).create;
+
+    my $blo = Blo.^create(:value<blo>);
+    my $bli = $blo.bli.^create: :value<bli>;
+    is $bli.blos.head.gist, $blo.gist;
+    is $blo.bli.gist, $bli.gist;
+}
+
+# TODO: make this work
+#subtest "belogs-to using types not using it on attrs", {
+#    model Blu { ... }
+#    model Blb {
+#        has UInt $.id      is serial;
+#        has Str  $.value   is column;
+#        has      @.blus    is relationship(*.blb-id, :model(Blu));
+#        has      $.one-blu is relationship(*.blb-id, :model(Blu), :has-one);
+#    }
+#
+#    model Blu {
+#        has UInt $.id     is serial;
+#        has Str  $.value  is column;
+#        has UInt $.blb-id is referencing(*.id, :model(Blb));
+#        has      $.blb    is relationship(*.blb-id, :model(Blb));
+#    }
+#
+#    schema(Blb, Blu).create;
+#
+#    my $blu = Blu.^create(:value<blu>);
+#    my $blb = $blu.blb.^create: :value<blb>;
+#    is $blb.blus.head.gist, $blu.gist;
+#    is $blu.blb.gist, $blb.gist;
+#}
+
 subtest "Simple create and fk id", {
     my $bla = Bla.^create: :value<test1>;
     my $ble = Ble.^create: :value<test2>, :bla-id($bla.id);
@@ -79,17 +136,6 @@ subtest "Simple create and calling create on Relationship", {
     is        $bla.bles.map(*.value),       <test test test>;
 };
 
-subtest "Simple create and creating by array", {
-    my $bla = Bla.^create: :value<test1>, :bles[{:value<test3>}, {:value<test4>}];
-
-    isa-ok    $bla,                         Bla;
-    is-deeply $bla,                         Bla.^load: $bla.id;
-
-    does-ok   $bla.bles,                    Red::ResultSeq;
-    isa-ok    $bla.bles,                    Ble::ResultSeq;
-    is        $bla.bles.map(*.value),       <test3 test4>;
-};
-
 subtest "Create with has-one", {
     my $bla = Bla.^create: :value<test1>, :one-ble{:value<test42>};
 
@@ -107,4 +153,15 @@ subtest "Create on transaction", {
 	is Bla.^all.grep(*.value eq "trans1").elems, 0
 };
 
+subtest "Simple create and creating by array", {
+    my $bla = Bla.^create: :value<test1>, :bles[{:value<test3>}, {:value<test4>}];
+
+    isa-ok    $bla,                         Bla;
+    is-deeply $bla,                         Bla.^load: $bla.id;
+
+    does-ok   $bla.bles,                    Red::ResultSeq;
+    isa-ok    $bla.bles,                    Ble::ResultSeq;
+    is        $bla.bles.map(*.value),       <test3 test4>;
+};
+
 done-testing;