WiP: adding a centralized supply of events. Related to #400

lib/MetamodelX/Red/Model.pm6

@@ -26,6 +26,7 @@ use MetamodelX::Red::OnDB;
 use MetamodelX::Red::Id;
 use X::Red::Exceptions;
 use Red::Phaser;
+use Red::Event;
 
 =head2 MetamodelX::Red::Model
 
@@ -46,6 +47,14 @@ has @!constraints;
 has $.table;
 has Bool $!temporary;
 
+multi method emit(Mu $model, Red::Event $event) {
+    get-RED-DB.emit: $event.clone: :model($model.WHAT)
+}
+
+multi method emit(Mu $model, $data) {
+    get-RED-DB.emit: Red::Event.new: :model($model.WHAT), :$data
+}
+
 #| Returns a list of columns names.of the model.
 method column-names(|) { @!columns>>.column>>.name }
 
@@ -249,8 +258,7 @@ multi method create-table(\model) {
     die X::Red::InvalidTableName.new: :table(model.^table)
         unless get-RED-DB.is-valid-table-name: model.^table
     ;
-    get-RED-DB.execute:
-        Red::AST::CreateTable.new:
+    my $data = Red::AST::CreateTable.new:
             :name(model.^table),
             :temp(model.^temp),
             :columns[|model.^columns.map(*.column)],
@@ -266,6 +274,14 @@ multi method create-table(\model) {
             ],
             |(:comment(Red::AST::TableComment.new: :msg(.Str), :table(model.^table)) with model.WHY)
     ;
+    get-RED-DB.execute: |$data;
+    self.emit: model, Red::Event.new: :$data;
+    CATCH {
+        default {
+            self.emit: model, Red::Event.new: :$data, :error($_);
+            proceed
+        }
+    }
     True
 }
 

lib/Red.pm6

@@ -16,6 +16,7 @@ use Red::AST::Infixes;
 use Red::AST::Optimizer::AND;
 use Red::AST::Optimizer::OR;
 use Red::AST::Optimizer::Case;
+use Red::Class;
 
 class Red:ver<0.0.4>:api<1> {}
 
@@ -43,6 +44,7 @@ multi EXPORT("red-do") {
         Red::Traits::EXPORT::ALL::,
         Red::Operators::EXPORT::ALL::,
         ‘&database’ => &database,
+        'red'      => Red::Class.instance,
     )
 }
 
@@ -55,6 +57,7 @@ multi EXPORT("experimental migrations") {
         Red::Traits::EXPORT::ALL::,
         Red::Operators::EXPORT::ALL::,
         ‘&database’ => &database,
+        'red'      => Red::Class.instance,
     )
 }
 
@@ -63,6 +66,7 @@ multi EXPORT {
         Red::Traits::EXPORT::ALL::,
         Red::Operators::EXPORT::ALL::,
         ‘&database’ => &database,
+        'red'      => Red::Class.instance,
     )
 }
 

lib/Red/Class.pm6

@@ -0,0 +1,11 @@
+unit class Red::Class;
+
+method instance(::?CLASS:U: --> ::?CLASS:D) { $ //= self.bless }
+method new {!!!}
+
+has Supplier $!supplier .= new;
+has Supply   $.events    = $!supplier.Supply;
+
+method register-supply(Supply $_) {
+    .tap: { $!supplier.emit: $_ }
+}

lib/Red/Database.pm6

@@ -15,6 +15,8 @@ multi sub database(Str $type, |c --> Red::Driver) is export {
     my $driver-name = "Red::Driver::$type";
     require ::($driver-name);
     my Red::Driver $driver = ::($driver-name).new: |c;
+    $driver.auto-register;
+    $driver
 }
 
 #| Accepts an SQL driver name and a database handle, and
@@ -23,4 +25,6 @@ multi sub database(Str $type, $dbh --> Red::Driver) {
     my $driver-name = "Red::Driver::$type";
     require ::($driver-name);
     my Red::Driver $driver = ::($driver-name).new: :$dbh;
+    $driver.auto-register;
+    $driver
 }

lib/Red/Do.pm6

@@ -1,6 +1,9 @@
 use Red::Database;
 use Red::Driver;
 use X::Red::Exceptions;
+use Red::Class;
+use Red::Event;
+use Red::DB;
 
 =head1 This module is experimental, to use it, do:
 
@@ -71,22 +74,14 @@ multi red-defaults(*%drivers) is export {
     }).Hash;
 }
 
-sub supply-pair-for-name(Str $name) {
-    %*RED-SUPPLIES{$name} //= do {
-        my Supplier $supplier .= new;
-        my $supply = $supplier.Supply;
-        { :$supplier, :$supply }
-    }
-}
-
-sub red-emit(Str() $name, |c) is export {
-    supply-pair-for-name($name)<supplier>.emit: |c
+sub red-emit(Str() $name, $data) is export {
+    get-RED-DB.emit: Red::Event.new: :$name, :$data
 }
 
 sub red-tap(Str() $name, &func, :$red-db = $*RED-DB) is export {
-    supply-pair-for-name($name)<supply>.tap: -> |c {
+    Red::Class.instance.events.grep({ .name eq $name }).tap: -> Red::Event $_ {
         my $*RED-DB = $red-db;
-        func |c
+        func .data
     }
 }
 

lib/Red/Driver.pm6

@@ -2,11 +2,29 @@ use Red::AST;
 use Red::Column;
 use Red::SchemaReader;
 use X::Red::Exceptions;
+use Red::Class;
+use Red::Event;
 
 =head2 Red::Driver
 
 unit role Red::Driver;
 
+has Supplier $!supplier .= new;
+has Supply   $.events    = $!supplier.Supply;
+
+method auto-register(|) {
+    Red::Class.instance.register-supply: $!events;
+    self
+}
+
+multi method emit($data) {
+    $!supplier.emit: Red::Event.new: :db(self), :db-name(self.^name), :$data
+}
+
+multi method emit(Red::Event $event) {
+    $!supplier.emit: $event.clone: :db(self), :db-name(self.^name)
+}
+
 method schema-reader(--> Red::SchemaReader)             { ... }
 method translate(Red::AST, $?)                          { ... }
 multi method prepare(Str)                               { ... }

lib/Red/Driver/Cache.pm6

@@ -26,13 +26,24 @@ multi cache(Str $cache, Pair $driver-pair) {
     cache $cache => \(), $driver-pair
 }
 
+multi cache(Str $cache, Red::Driver $driver) {
+    cache $cache => \(), $driver
+}
+
+multi cache(Pair (Str :key($cache-driver), Capture :value($cache-conf)), Red::Driver $driver) {
+    my $cache = "Red::Driver::Cache::$cache-driver";
+    require ::($cache);
+    ::($cache).new: :$driver, |$cache-conf
+}
+
 multi cache(
     Pair (Str :key($cache-driver), Capture :value($cache-conf)),
-    Pair (Str :key($driver),       Capture :value($driver-conf))
+    Pair (Str :key($driver-name),  Capture :value($driver-conf))
 ) is export {
+    my $driver = database $driver-name, |$driver-conf;
     my $cache = "Red::Driver::Cache::$cache-driver";
     require ::($cache);
-    ::($cache).new: :driver(database $driver, |$driver-conf), |$cache-conf
+    ::($cache).new: :$driver, |$cache-conf
 }
 
 multi method get-from-cache(Red::AST)  { ... }

lib/Red/Event.pm6

@@ -0,0 +1,11 @@
+use Red::Model;
+unit class Red::Event;
+
+has              $.db;
+has Str          $.db-name;
+has Str          $.driver-name;
+has Str          $.name;
+has              $.data;
+has Red::Model:U $.model;
+has Red::Model   $.origin;
+has Exception    $.error;

t/22-red-do.t

@@ -106,9 +106,9 @@ use Red::Driver::Cache;
 use Red::Driver::Cache::Memory;
 
 red-defaults
-    bla   => \(database("SQLite", :database<./a.db>)),
-    ble   => \(database("SQLite", :database<./b.db>)),
-    cache => \(cache "Memory", "SQLite"),
+    bla   => database("SQLite", :database<./a.db>),
+    ble   => database("SQLite", :database<./b.db>),
+    cache => cache("Memory", "SQLite"),
 ;
 
 red-do