From 16889125ace17e14de9459145017fdf114342238 Mon Sep 17 00:00:00 2001
From: Zakariyya Mughal <zaki.mughal@gmail.com>
Date: Tue, 29 Mar 2022 02:38:38 -0400
Subject: [PATCH] Use parent ::Match grammar in ::SubMatch

This allows for using rules that have been defined by `extend_grammar`
to extract out sub-matches.
---
 lib/Babble/Match.pm |  7 +++-
 t/submatch-rule.t   | 93 +++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 98 insertions(+), 2 deletions(-)
 create mode 100644 t/submatch-rule.t

diff --git a/lib/Babble/Match.pm b/lib/Babble/Match.pm
index c87b690..b760a46 100644
--- a/lib/Babble/Match.pm
+++ b/lib/Babble/Match.pm
@@ -8,8 +8,11 @@ use re 'eval';
 ro 'top_rule';
 rwp 'text';
 
-lazy 'grammar' => sub { Babble::Grammar->new }
-  => handles => [ 'grammar_regexp' ];
+lazy 'grammar' => sub {
+  $_[0]->can('parent')
+    ? $_[0]->parent->grammar
+    : Babble::Grammar->new
+  } => handles => [ 'grammar_regexp' ];
 
 lazy 'symbol_generator' => sub {
   $_[0]->can('parent')
diff --git a/t/submatch-rule.t b/t/submatch-rule.t
new file mode 100644
index 0000000..cb44544
--- /dev/null
+++ b/t/submatch-rule.t
@@ -0,0 +1,93 @@
+use strictures 2;
+use Test::More;
+use Babble::Match;
+
+{
+package # hide from PAUSE
+  ClassKeyword;
+
+use Moo;
+
+sub extend_grammar {
+  my ($self, $g) = @_;
+  $g->add_rule(ClassExtends => q{
+    extends (?&PerlOWS) (?&PerlQualifiedIdentifier)
+  });
+  $g->add_rule(RolesList => q{
+    (?&PerlQualifiedIdentifier)
+    (?: (?&PerlOWS) , (?&PerlOWS) (?&PerlQualifiedIdentifier) )*?
+  });
+  $g->add_rule(ClassRoles => q{
+    with (?&PerlOWS) (?&PerlRolesList)
+  });
+  $g->add_rule(ClassDef => q{
+    class (?&PerlOWS) (?&PerlQualifiedIdentifier)
+    (?: (?&PerlOWS) (?&PerlClassExtends) )?
+    (?: (?&PerlOWS) (?&PerlClassRoles) )?
+    (?&PerlOWS)
+    (?&PerlBlock)
+  });
+  $g->augment_rule(Keyword => '(?&PerlClassDef)');
+}
+
+sub transform_to_plain {
+  my ($self, $top) = @_;
+  $top->each_match_within(Keyword => [
+    [ kw => 'class(?&PerlOWS)'],
+    [ name =>  '(?&PerlQualifiedIdentifier)'],
+    [ extends => '(?: (?&PerlOWS) (?&PerlClassExtends) )?' ],
+    [ roles   => '(?: (?&PerlOWS) (?&PerlClassRoles) )?'   ],
+    [ space => '(?&PerlOWS)' ],
+    [ block => '(?&PerlBlock)' ],
+  ] => sub {
+    my ($m) = @_;
+    my $gr = $m->grammar_regexp;
+    my ($kw, $name, $extends, $roles, $space, $block)
+      = @{$m->submatches}{qw(kw name extends roles space block)};
+
+    my $extends_text = $extends->text;
+    $extends_text =~ s/\A (?&PerlOWS) extends (?&PerlOWS) $gr//mx;
+
+    my $roles_text = $roles->text;
+    $roles_text =~ s/\A (?&PerlOWS) with (?&PerlOWS) $gr//mx;
+    my @roles = grep defined, split /(?:(?&PerlOWS)) , (?: (?&PerlOWS)) $gr/mx, $roles_text;
+
+    my $block_text = $block->text;
+    my $prefix = "package @{[ $name->text ]}; use Moo;";
+
+    $prefix .= " extends ".B::perlstring($extends_text). ";" if $extends_text;
+    $prefix .= " with ".join(", ", map B::perlstring($_), @roles). ";" if @roles;
+
+    $block_text =~ s/\{/{ $prefix/;
+    $_->replace_text('') for $kw, $name, $extends, $roles, $space;
+
+    $block->replace_text($block_text);
+  });
+}
+}
+
+my @cand = (
+  [ 'class Foo::Bar { 42 }',
+    q|{ package Foo::Bar; use Moo; 42 }|, ],
+  [ 'class Baz extends Foo::Bar { 42 }',
+    q|{ package Baz; use Moo; extends "Foo::Bar"; 42 }|, ],
+  [ 'class Baz extends Foo with Foo::Role::Trackable { 42 }',
+    q|{ package Baz; use Moo; extends "Foo"; with "Foo::Role::Trackable"; 42 }|, ],
+  [ 'class Baz extends Foo with Trackable, Aliasable { 42 }',
+    q|{ package Baz; use Moo; extends "Foo"; with "Trackable", "Aliasable"; 42 }|, ],
+);
+
+my $ck = ClassKeyword->new;
+
+my $g = Babble::Grammar->new;
+
+$ck->extend_grammar($g);
+
+foreach my $cand (@cand) {
+  my ($from, $to) = @$cand;
+  my $top = $g->match('Document' => $from);
+  $ck->transform_to_plain($top);
+  is($top->text, $to, "${from}");
+}
+
+done_testing;