Create and use typed exception

X::Parameter::InvalidConcreteness
rakudo · May 1, 2017 · d1a81b3 · d1a81b3
1 parent 146f3a3
commit d1a81b3
Show file tree

Hide file tree

Showing 2 changed files with 40 additions and 10 deletions.
diff --git a/src/Perl6/Metamodel/BOOTSTRAP.nqp b/src/Perl6/Metamodel/BOOTSTRAP.nqp
@@ -316,21 +316,26 @@ my class Binder {
 
                 # Also enforce definedness constraints.
                 if $flags +& $SIG_ELEM_DEFINEDNES_CHECK {
-                    if (my $should_be_undef := $flags +& $SIG_ELEM_UNDEFINED_ONLY &&  nqp::isconcrete($oval)) ||
-                                               $flags +& $SIG_ELEM_DEFINED_ONLY   && !nqp::isconcrete($oval)
+                    if (my $should_be_concrete := $flags +& $SIG_ELEM_DEFINED_ONLY   && !nqp::isconcrete($oval)) ||
+                                                  $flags +& $SIG_ELEM_UNDEFINED_ONLY &&  nqp::isconcrete($oval)
                     {
                         if nqp::defined($error) {
                             my $method := nqp::getcodeobj(nqp::ctxcode($lexpad)).name;
-                            $method    := '<anon>' if nqp::isnull_s($method) || $method eq '';
                             my $class  := $nom_type.HOW.name($nom_type);
                             my $got    := $oval.HOW.name($oval);
-                            $error[0]  := $flags +& $SIG_ELEM_INVOCANT
-                              ?? $should_be_undef
-                                   ?? "Method '$method' must be called on a type object of type '$class', not an object instance of type '$got'.  Did you forget a 'multi'?"
-                                   !! "Method '$method' must be called on an object instance of type '$class', not a '$got' type object.  Did you forget a '.new'?"
-                              !! $should_be_undef
-                                   ?? "Parameter '$varname' of routine '$method' must be a type object of type '$class', but an object instance of type '$got' was passed.  Did you forget a 'multi'?"
-                                   !! "Parameter '$varname' of routine '$method' must be an object instance of type '$class', but a '$got' type object was passed.  Did you forget a '.new'?";
+                            my %ex     := nqp::gethllsym('perl6', 'P6EX');
+                            if nqp::isnull(%ex) || !nqp::existskey(%ex, 'X::Parameter::RW') {
+                                $method   := '<anon>' if nqp::isnull_s($method) || $method eq '';
+                                $error[0] := $flags +& $SIG_ELEM_INVOCANT
+                                  ?? $should_be_concrete
+                                       ?? "Invocant of method '$method' must be an object instance of type '$class', not a type object of type '$got'.  Did you forget a '.new'?"
+                                       !! "Invocant of method '$method' must be a type object of type '$class', not an object instance of type '$got'.  Did you forget a 'multi'?"
+                                  !! $should_be_concrete
+                                       ?? "Parameter '$varname' of routine '$method' must be an object instance of type '$class', not a type object of type '$got'.  Did you forget a '.new'?"
+                                       !! "Parameter '$varname' of routine '$method' must be a type object of type '$class', not an object instance of type '$got'.  Did you forget a 'multi'?";
+                            } else {
+                                $error[0] := { nqp::atkey(%ex, 'X::Parameter::InvalidConcreteness')($class, $got, $method, $varname, $should_be_concrete, $flags +& $SIG_ELEM_INVOCANT) };
+                            }
                         }
                         return $oval.WHAT =:= Junction && nqp::isconcrete($oval)
                             ?? $BIND_RESULT_JUNCTION

diff --git a/src/core/Exception.pm b/src/core/Exception.pm
@@ -1143,6 +1143,26 @@ my class X::Parameter::WrongOrder does X::Comp {
     }
 }
 
+my class X::Parameter::InvalidConcreteness is Exception {
+    has $.expected;
+    has $.got;
+    has $.routine;
+    has $.param;
+    has $.should-be-concrete;
+    has $.param-is-invocant;
+
+    method message() {
+        $!routine = '<anon>' if not $!routine.defined or $!routine eq '';
+        $!param   = '<anon>' if not $!param.defined   or $!param   eq '';
+        my $beginning  = $!param-is-invocant  ?? 'Invocant of method' !! "Parameter '$!param' of routine";
+        my $must-be    = $!should-be-concrete ?? 'an object instance' !! 'a type object';
+        my $not-a      = $!should-be-concrete ?? 'a type object'      !! 'an object instance';
+        my $suggestion = $!should-be-concrete ?? '.new'               !! 'multi';
+
+        "$beginning '$!routine' must be $must-be of type '$!expected', not $not-a of type '$!got'.  Did you forget a '$suggestion'?"
+    }
+}
+
 my class X::Parameter::InvalidType does X::Comp {
     has $.typename;
     has @.suggestions;
@@ -2457,6 +2477,7 @@ my class X::PhaserExceptions is Exception {
     }
 }
 
+
 #?if jvm
 nqp::bindcurhllsym('P6EX', nqp::hash(
 #?endif
@@ -2529,6 +2550,10 @@ nqp::bindcurhllsym('P6EX', BEGIN nqp::hash(
   -> $type, $subtype, $declaring, $name {
       X::Trait::Invalid.new(:$type, :$subtype, :$declaring, :$name).throw;
   },
+  'X::Parameter::InvalidConcreteness',
+  -> $expected, $got, $routine, $param, $should-be-concrete, $param-is-invocant {
+      X::Parameter::InvalidConcreteness.new(:$expected, :$got, :$routine, :$param, :$should-be-concrete, :$param-is-invocant).throw;
+  },
 ));
 
 my class X::HyperWhatever::Multiple is Exception {