Merge branch 'smiley-coercers2'

- Fixes parsing bugs where `Foo:D(Bar)` got parsed as just a DefiniteHOW, completely ignoring stuff in parentheses - `Foo:D(Bar)` is now a definite-how coercer that accepts a `Bar` and coerces to `Foo`. The definiteness check on the resultant type is not yet performed - Now throws X::MultipleTypeSmiley on stuff like `Foo:D:U:D:D:D` that previously parsed without issues
rakudo · Jan 3, 2018 · fc99d5e · fc99d5e
2 parents b3e73b6 + 8dcf9da
commit fc99d5e
Show file tree

Hide file tree

Showing 5 changed files with 61 additions and 35 deletions.
diff --git a/src/Perl6/Actions.nqp b/src/Perl6/Actions.nqp
@@ -6012,7 +6012,17 @@ class Perl6::Actions is HLL::Actions does STDActions {
             }
 
             # If needed, try to form a coercion type.
-            if $<accept> || $<accept_any> {
+            my $accept := $<accept>
+              ?? $<accept>.ast
+              !! $<accept_any>
+                ?? $*W.find_symbol: ['Any']
+                !! $<colonpairs>
+                  && ($<colonpairs>.ast<D> || $<colonpairs>.ast<U>)
+                  && nqp::istype($<longname><colonpair>[0].ast[2], QAST::WVal)
+                  ?? $<longname><colonpair>[0].ast[2].value
+                  !! nqp::null;
+
+            unless nqp::isnull($accept) {
                 my $value;
                 if nqp::istype($past, QAST::WVal) {
                     $value := $past.value;
@@ -6024,8 +6034,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
                     $/.panic("Target type too complex to form a coercion type");
                 }
 
-                my $type := $*W.create_coercion_type($/, $value,
-                    $<accept> ?? $<accept>.ast !! $*W.find_symbol(['Any']));
+                my $type := $*W.create_coercion_type($/, $value, $accept);
                 $past := QAST::WVal.new( :value($type) );
             }
         }
@@ -7863,12 +7872,22 @@ class Perl6::Actions is HLL::Actions does STDActions {
                     $type := $*W.create_definite_type($*W.resolve_mo($/, 'definite'), $type, 0);
                 }
 
-                if $<accept> || $<accept_any> {
+                my $accept := $<accept>
+                  ?? $<accept>.ast
+                  !! $<accept_any>
+                    ?? $*W.find_symbol: ['Any']
+                    !! $<colonpairs>
+                      && ($<colonpairs>.ast<D> || $<colonpairs>.ast<U>)
+                      && nqp::istype(
+                        $<longname><colonpair>[0].ast[2], QAST::WVal)
+                      ?? $<longname><colonpair>[0].ast[2].value
+                      !! nqp::null;
+
+                if ! nqp::isnull($accept) {
                     if $<typename> {
                         $/.panic("Cannot put 'of' constraint on a coercion type");
                     }
-                    $type := $*W.create_coercion_type($/, $type,
-                        $<accept> ?? $<accept>.ast !! $*W.find_symbol(['Any']));
+                    $type := $*W.create_coercion_type($/, $type, $accept);
                 }
                 elsif $<typename> {
                     $type := $*W.parameterize_type_with_args($/, $type,

diff --git a/src/Perl6/Grammar.nqp b/src/Perl6/Grammar.nqp
@@ -3479,20 +3479,12 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
                     || $<accept_any>=<?>
                 ] <.ws> ')'
             ]?
-            {
-                for $<longname><colonpair> {
-                    if $_<identifier> {
-                        my $name := $_<identifier>.Str;
-                        if $name eq 'D' || $name eq 'U' || $name eq '_' {
-                            %colonpairs{$name} := 1;
-                        }
-                        else {
-                            $*W.throw($/, ['X', 'InvalidTypeSmiley'], :$name)
-                        }
-                    }
-                }
-            }
-            [<?{ %colonpairs }> <colonpairs=.O(|%colonpairs)>]?
+            [
+                <?{
+                    %colonpairs
+                    := $*W.validate_type_smiley: $/, $<longname><colonpair>
+                }> <colonpairs=.O(|%colonpairs)>
+            ]?
         || [ \\ <?before '('> ]? <args(1)>
             {
                 if !$<args><invocant> {
@@ -3688,20 +3680,12 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
         <.unsp>? [ <?before '{'> <whence=.postcircumfix> <.NYI('Autovivifying object closures')> ]?
         <.unsp>? [ <?[(]> '(' ~ ')' [<.ws> [<accept=.typename> || $<accept_any>=<?>] <.ws>] ]?
         [<.ws> 'of' <.ws> <typename> ]?
-        {
-            for ($<longname> ?? $<longname><colonpair> !! $<colonpair>) {
-                if $_<identifier> {
-                    my $name := $_<identifier>.Str;
-                    if $name eq 'D' || $name eq 'U' || $name eq '_' {
-                        %colonpairs{$name} := 1;
-                    }
-                    else {
-                        $*W.throw($/, ['X', 'InvalidTypeSmiley'], :$name)
-                    }
-                }
-            }
-        }
-        [<?{ %colonpairs }> <colonpairs=.O(|%colonpairs)>]?
+        [
+            <?{
+                %colonpairs := $*W.validate_type_smiley: $/, $<longname>
+                    ?? $<longname><colonpair> !! $<colonpair>
+            }> <colonpairs=.O(|%colonpairs)>
+        ]?
     }
 
     token typo_typename($panic = 0) {

diff --git a/src/Perl6/Metamodel/BOOTSTRAP.nqp b/src/Perl6/Metamodel/BOOTSTRAP.nqp
@@ -1598,7 +1598,10 @@ BEGIN {
         }));
     Parameter.HOW.add_method(Parameter, 'set_coercion', nqp::getstaticcode(sub ($self, $type) {
             my $dcself := nqp::decont($self);
-            nqp::bindattr_s($dcself, Parameter, '$!coerce_method', $type.HOW.name($type));
+            nqp::bindattr_s($dcself, Parameter, '$!coerce_method',
+              nqp::istype($type.HOW, Perl6::Metamodel::DefiniteHOW)
+              ?? $type.HOW.base_type($type).HOW.name($type.HOW.base_type: $type)
+              !! $type.HOW.name($type));
             nqp::bindattr($dcself, Parameter, '$!coerce_type', nqp::decont($type));
             $dcself
         }));

diff --git a/src/Perl6/World.nqp b/src/Perl6/World.nqp
@@ -4188,6 +4188,20 @@ class Perl6::World is HLL::World {
         }
     }
 
+    method validate_type_smiley ($/, $colonpairs) {
+        1 < $colonpairs && self.throw: $/, ['X', 'MultipleTypeSmiley'];
+        my %colonpairs;
+        for $colonpairs {
+            if $_<identifier> {
+                my $name := $_<identifier>.Str;
+                $name eq 'D' || $name eq 'U' || $name eq '_'
+                    ?? (%colonpairs{$name} := 1)
+                    !! self.throw: $/, ['X', 'InvalidTypeSmiley'], :$name
+            }
+        }
+        %colonpairs
+    }
+
     # Takes a longname and turns it into an object representing the
     # name.
     method dissect_longname($longname) {

diff --git a/src/core/Exception.pm b/src/core/Exception.pm
@@ -2850,6 +2850,12 @@ my class X::InvalidTypeSmiley does X::Comp {
     }
 }
 
+my class X::MultipleTypeSmiley does X::Comp {
+    method message() {
+        "Multiple type smileys cannot be used";
+    }
+}
+
 my class X::Seq::Consumed is Exception {
     method message() {
         "The iterator of this Seq is already in use/consumed by another Seq\n" ~