Adding exception mapper. t/10 is breaking on calling 'database'. Rela…

…ted to #69

META6.json

@@ -77,7 +77,8 @@
     "SameIfPresent"                 : "lib/Red/AST/Optimizer.pm6",
     "SameIfTheOtherIsTrue"          : "lib/Red/AST/Optimizer.pm6",
     "Red::AST::Optimizer"           : "lib/Red/AST/Optimizer.pm6",
-    "X::Red::InvalidTableName"      : "lib/X/Red/InvalidTableName.pm6"
+    "X::Red::Exceptions"            : "lib/X/Red/Exceptions.pm6",
+    "X::Red::InvalidTableName"      : "lib/X/Red/Exceptions.pm6"
   },
   "resources" : [ ],
   "source-url" : "",

lib/MetamodelX/Red/Model.pm6

@@ -18,7 +18,7 @@ use Red::AST::LastInsertedRow;
 use MetamodelX::Red::Dirtable;
 use MetamodelX::Red::Comparate;
 use MetamodelX::Red::Relationship;
-use X::Red::InvalidTableName;
+use X::Red::Exceptions;
 
 unit class MetamodelX::Red::Model is Metamodel::ClassHOW;
 also does MetamodelX::Red::Dirtable;
@@ -171,7 +171,7 @@ method rs($)                        { $.rs-class.new }
 method all($obj)                    { $obj.^rs }
 
 method create-table(\model) {
-    die X::Red::InvalidTableName.new: :table(model.^table), :driver($*RED-DB.^name)
+    die X::Red::InvalidTableName.new: :table(model.^table)
     unless $*RED-DB.is-valid-table-name: model.^table;
     $*RED-DB.execute:
         Red::AST::CreateTable.new:

lib/Red/Driver.pm6

@@ -1,5 +1,6 @@
 use Red::AST;
 use Red::Column;
+use X::Red::Exceptions;
 unit role Red::Driver;
 
 method translate(Red::AST, $?)                          { ... }
@@ -12,6 +13,10 @@ multi method is-valid-table-name(Str --> Bool)          { True }
 multi method type-by-name("string" --> "text")          {}
 multi method type-by-name("int"    --> "integer")       {}
 
+multi method map-exception($orig-exception) {
+    X::Red::Driver::Mapped::UnknownError.new: :$orig-exception
+}
+
 multi method prepare("") {class :: { method execute(|) {} }}
 
 multi method inflate(Any $value, Any :$to) { $value }

lib/Red/Driver/Pg.pm6

@@ -3,6 +3,7 @@ use Red::Driver;
 use Red::Driver::CommonSQL;
 use Red::Statement;
 use Red::AST::Infixes;
+use X::Red::Exceptions;
 unit class Red::Driver::Pg does Red::Driver::CommonSQL;
 
 has Str $!user;
@@ -62,3 +63,11 @@ multi method default-type-for(Red::Column $ where .attr.type ~~ Bool
 multi method default-type-for(Red::Column $                                                 --> Str:D) {"varchar(255)"}
 
 multi method inflate(Str $value, DateTime :$to!) { DateTime.new: $value }
+
+multi method map-exception(DB::Pg::Error::FatalError $x where /"duplicate key value violates unique constraint"/) {
+    $x.message ~~ /"DETAIL:  Key (" \s* (\w+)+ % [\s* "," \s*] \s* ")=(" .*? ") already exists."/;
+    X::Red::Driver::Mapped::Unique.new:
+        :driver<Pg>,
+        :orig-exception($x),
+        :fields($0>>.Str)
+}

lib/Red/Driver/SQLite.pm6

@@ -8,6 +8,7 @@ use Red::AST::Infixes;
 use Red::AST::Function;
 use Red::Driver::CommonSQL;
 use Red::AST::LastInsertedRow;
+use X::Red::Exceptions;
 unit class Red::Driver::SQLite does Red::Driver::CommonSQL;
 
 has $.database = q<:memory:>;
@@ -72,3 +73,11 @@ multi method translate(Red::Column $_, "column-auto-increment") { "AUTOINCREMENT
 
 multi method default-type-for(Red::Column $ where .attr.type ~~ Bool           --> Str:D) {"integer"}
 multi method default-type-for(Red::Column $ where .attr.type ~~ one(Int, Bool) --> Str:D) {"integer"}
+
+multi method map-exception(Exception $x where { .code == 19 and .native-message.starts-with: "UNIQUE constraint failed:" }) {
+    X::Red::Driver::Mapped::Unique.new:
+        :driver<SQLite>,
+        :orig-exception($x),
+        :fields($x.native-message.substr(26).split: /\s* "," \s*/)
+}
+

lib/Red/Statement.pm6

@@ -8,7 +8,12 @@ method stt-exec($, *@) { ... }
 
 method predefined-bind { $!predefined-bind = True }
 
-method execute(*@binds) {
+method execute(*@binds) is hidden-from-backtrace {
+    CATCH {
+        default {
+            $!driver.map-exception($_).throw
+        }
+    }
     $!statement = do if $!predefined-bind {
         self.stt-exec: $!statement, |@binds
     } else {

lib/X/Red/Exceptions.pm6

@@ -0,0 +1,44 @@
+class X::Red is Exception {}
+
+class X::Red::Driver is X::Red {
+    has Str $.driver = $*RED-DB.^name;
+}
+
+class X::Red::InvalidTableName is X::Red::Driver {
+    has Str $.table;
+
+    method message { "'$!table' is an invalid table name for driver { $.driver }" }
+}
+
+class X::Red::Driver::Mapped is X::Red::Driver {
+    has Exception   $.orig-exception is required;
+    has Str         $!orig-message   = $!orig-exception.message;
+    has Backtrace   $!orig-backtrace = $!orig-exception.backtrace;
+
+    method msg { !!! }
+
+    method message {
+        "{self.msg}\nOriginal error:\n{$!orig-message}"
+    }
+
+    method throw is hidden-from-backtrace {
+        nextwith $!orig-backtrace
+    }
+}
+
+class X::Red::Driver::Mapped::UnknownError is X::Red::Driver::Mapped {
+    has Str @.fields;
+    method msg {
+        qq:to/END/
+            Unknown Error!!!
+            Please, copy this backtrace and open an issue on https://github.com/FCO/Red/issues/new
+            Driver: { $.driver }
+            Original error: { $.orig-exception.perl }
+        END
+    }
+}
+
+class X::Red::Driver::Mapped::Unique is X::Red::Driver::Mapped {
+    has Str @.fields;
+    method msg { "Unique constraint ({@!fields.join: ", "}) violated" }
+}

t/08-best-tree.t

@@ -26,7 +26,7 @@ model BestTree::Store is table<tree> {
 
     method suggest-tree(Rat() $longitude, Rat() $latitude, Rat() $height, Str $description) {
         CATCH {
-            when /"UNIQUE constraint failed"/ {
+            when X::Red::Driver::Mapped::Unique {
                 die X::Tree::ExistsInTheSameArea.new: :$longitude, :$latitude
             }
         }

t/10-alternate-relation-modules.t

@@ -30,7 +30,7 @@ ok $p.id.defined, "primary key is defined";;
 is $p.id, 1, "and it is the value we expected";
 
 my $post;
-lives-ok { 
+lives-ok {
     $post = $p.posts.create: :title("Red's commit"), :body("Merge branch 'master' of https://github.com/FCO/Red") ;
 }, "create a related post";
 isa-ok $post, Post;