Skip to content

Commit

Permalink
Merge pull request #8 from zmughal/context-subst
Browse files Browse the repository at this point in the history 
SubstituteAndReturn: chained and contextual
  • Loading branch information
@zmughal
zmughal committed Sep 2, 2022
2 parents 9593fe1 + 2b634d7 commit e7642f3
Show file tree
Hide file tree
Showing 2 changed files with 163 additions and 17 deletions.
149 changes: 132 additions & 17 deletions lib/Babble/Plugin/SubstituteAndReturn.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,25 +2,140 @@ package Babble::Plugin::SubstituteAndReturn;

use Moo;

my $s_FLAGS_RE = qr/([msixpodualgcern]*+)$/;
my $y_FLAGS_RE = qr/([cdsr]*+)$/;

sub _get_flags {
my ($text) = @_;
$text =~ /^s/ ? $s_FLAGS_RE : $y_FLAGS_RE;
}

sub _transform_binary {
my ($self, $top) = @_;
my $replaced;
do {
$replaced = 0;
$top->each_match_within(BinaryExpression => [
[ 'left' => '(?>(?&PerlPrefixPostfixTerm))' ],
'(?>(?&PerlOWS)) =~ (?>(?&PerlOWS))',
[ 'right' => '(?>
(?&PerlSubstitution)
| (?&PerlTransliteration)
)' ],
] => sub {
my ($m) = @_;
my ($left, $right);
eval {
($left, $right) = $m->subtexts(qw(left right));
1
} or return;
my ($flags) = $right =~ _get_flags($right);
return unless (my $newflags = $flags) =~ s/r//g;

# find chained substitutions
# ... =~ s///r =~ s///r =~ s///r
my $top_text = $top->text;
pos( $top_text ) = $m->start + length $m->text;
my $chained_subs_length = 0;
my @chained_subs;
while( $top_text =~ /
\G
(
(?>(?&PerlOWS)) =~ (?>(?&PerlOWS))
((?>
(?&PerlSubstitution)
| (?&PerlTransliteration)
))
)
@{[ $m->grammar_regexp ]}
/xg ) {
$chained_subs_length += length $1;
push @chained_subs, $2;
}
for my $subst_c (@chained_subs) {
my ($f_c) = $subst_c =~ _get_flags($subst_c);
die "Chained substitution must use the /r modifier"
unless (my $nf_c = $f_c) =~ s/r//g;
$subst_c =~ s/\Q${f_c}\E$/${nf_c}/;
}

$right =~ s/\Q${flags}\E$/${newflags}/;
$left =~ s/\s+$//;
my $genlex = '$'.$m->gensym;

if( @chained_subs ) {
my $chained_for = 'for ('.$genlex.') { '
. join("; ", @chained_subs)
. ' }';
$top->replace_substring(
$m->start,
length($m->text) + $chained_subs_length,
'(map { (my '.$genlex.' = $_) =~ '.$right.'; '.$chained_for.' '.$genlex.' }'
.' '.$left.')[0]'
);
} else {
$m->replace_text(
'(map { (my '.$genlex.' = $_) =~ '.$right.'; '.$genlex.' }'
.' '.$left.')[0]'
);
}

$replaced++;
});
} while( $replaced );
}

sub _transform_contextualise {
my ($self, $top) = @_;

my $contextual_subst = 0;
do {
my %subst_pos;
# Look for substitution without binding operator:
# First look for an expression that begins with Substitution.
$top->each_match_within(Expression => [
[ subst => '(?>
(?&PerlSubstitution)
| (?&PerlTransliteration)
)' ],
] => sub {
my ($m) = @_;
my ($subst) = @{$m->submatches}{qw(subst)};
my ($flags) = $subst->text =~ _get_flags($subst->text);
return unless $flags =~ /r/;
$subst_pos{$m->start} = 1;
});
# Then remove Substitution within a BinaryExpression
$top->each_match_within(BinaryExpression => [
[ 'left' => '(?>(?&PerlPrefixPostfixTerm))' ],
'(?>(?&PerlOWS)) =~ (?>(?&PerlOWS))',
[ 'right' => '(?>
(?&PerlSubstitution)
| (?&PerlTransliteration)
)' ],
] => sub {
my ($m) = @_;
delete $subst_pos{ $m->start + $m->submatches->{right}->start };
});

# Insert context variable and binding operator
my @subst_pos = sort keys %subst_pos;
$contextual_subst = @subst_pos;
my $diff = 0;
my $replace = '$_ =~ ';
while( my $pos = shift @subst_pos ) {
$top->replace_substring($pos + $diff, 0, $replace);
$diff += length $replace;
}
} while( $contextual_subst);
}

sub transform_to_plain {
my ($self, $top) = @_;
$top->each_match_within(BinaryExpression => [
[ 'left' => '(?>(?&PerlPrefixPostfixTerm))' ],
'(?>(?&PerlOWS)) =~ (?>(?&PerlOWS))',
[ 'right' => '(?>(?&PerlSubstitution))' ],
] => sub {
my ($m) = @_;
my ($left, $right) = $m->subtexts(qw(left right));
my ($flags) = $right =~ /([msixpodualgcern]*+)$/;
return unless (my $newflags = $flags) =~ s/r//g;
$right =~ s/\Q${flags}\E$/${newflags}/;
$left =~ s/\s+$//;
my $genlex = '$'.$m->gensym;
$m->replace_text(
'(map { (my '.$genlex.' = $_) =~ '.$right.'; '.$genlex.' }'
.' '.$left.')[0]'
);
});

$self->_transform_contextualise($top);

$self->_transform_binary($top);
}

1;
31 changes: 31 additions & 0 deletions t/plugin-substituteandreturn.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,37 @@ my $sr = Babble::Plugin::SubstituteAndReturn->new;
my @cand = (
[ 'my $foo = $bar =~ s/baz/quux/r;',
'my $foo = (map { (my $__B_001 = $_) =~ s/baz/quux/; $__B_001 } $bar)[0];', ],
[ '$foo =~ s/foo/bar/gr =~ s/(bar)+/baz/gr',
'(map { (my $__B_001 = $_) =~ s/foo/bar/g; for ($__B_001) { s/(bar)+/baz/g } $__B_001 } $foo)[0]', ],
[ 'map { s/foo/bar/gr =~ s/(bar)+/baz/gr =~ s/xyzzy/ijk/gr } @list',
'map { (map { (my $__B_001 = $_) =~ s/foo/bar/g; for ($__B_001) { s/(bar)+/baz/g; s/xyzzy/ijk/g } $__B_001 } $_)[0] } @list', ],
[ 'my @new = map { s|foo|bar|gr } @old',
'my @new = map { (map { (my $__B_001 = $_) =~ s|foo|bar|g; $__B_001 } $_)[0] } @old', ],
[ 'while(<>) { print( s/aa/1/gr =~ s/bb/2/gr =~ s/cc/3/gr ); }',
'while(<>) { print( (map { (my $__B_001 = $_) =~ s/aa/1/g; for ($__B_001) { s/bb/2/g; s/cc/3/g } $__B_001 } $_)[0] ); }', ],
[ 'while(<>) {
print( s/aa/1/gr =~ s/bb/2/gr =~ s/cc/3/gr );
print( s/dd/4/gr =~ s/ee/5/gr =~ s/ff/6/gr );
}',
'while(<>) {
print( (map { (my $__B_001 = $_) =~ s/aa/1/g; for ($__B_001) { s/bb/2/g; s/cc/3/g } $__B_001 } $_)[0] );
print( (map { (my $__B_002 = $_) =~ s/dd/4/g; for ($__B_002) { s/ee/5/g; s/ff/6/g } $__B_002 } $_)[0] );
}',
],
[ 'my $foo = $bar =~ y/a-c/d/r;',
'my $foo = (map { (my $__B_001 = $_) =~ y/a-c/d/; $__B_001 } $bar)[0];', ],
[ q{
while(<>) {
print( y/a-c/d/r =~ tr/d/z/cr );
print( y/a-c/d/r =~ s/d/foo/gr );
}
}, q{
while(<>) {
print( (map { (my $__B_001 = $_) =~ y/a-c/d/; for ($__B_001) { tr/d/z/c } $__B_001 } $_)[0] );
print( (map { (my $__B_002 = $_) =~ y/a-c/d/; for ($__B_002) { s/d/foo/g } $__B_002 } $_)[0] );
}
}
],
);

foreach my $cand (@cand) {
Expand Down

0 comments on commit e7642f3

Please sign in to comment.