Implement tr

src/Perl6/Actions.nqp

@@ -4970,6 +4970,14 @@ class Perl6::Actions is HLL::Actions does STDActions {
                 )
             );
         }
+        # Transliteration shuffles values around itself and returns the
+        # Right Thing regardless of whether we're in a smart-match or
+        # implicitely against $_, so we just do the RHS here.
+        elsif $rhs<is_trans> {
+            $sm_call := QAST::Stmt.new(
+                $rhs
+            );
+        }
         else {
             # Call $rhs.ACCEPTS( $_ ), where $_ is $lhs.
             $sm_call := QAST::Op.new(
@@ -5834,15 +5842,58 @@ class Perl6::Actions is HLL::Actions does STDActions {
         if nqp::elems($<rx_adverbs><quotepair>) {
             $*W.throw($/, 'X::Comp::NYI', feature => 'tr/// adverbs');
         }
-        my $left  := ~$<tribble><left>;
-        my $right := ~$<tribble><right>;
-        make QAST::Op.new(:op<p6store>,
+        my $left  := $<tribble><left>.ast;
+        my $right := $<tribble><right>.ast;
+
+        # First we get ourselves a local variable to store the original LHS,
+        # which might be $_ or a LHS to ~~ - in both cases $_ holds the value.
+        my $orig_lhs := $*W.cur_lexpad.unique('orig_lhs');
+
+        # Next we build a Pair to pass to .trans.
+        $left.named('key');
+        $right.named('value');
+        my $pair := QAST::Op.new(
+            :op('callmethod'), :name('new'), :returns($*W.find_symbol(['Pair'])),
+            QAST::Var.new( :name('Pair'), :scope('lexical') ),
+            $left, $right
+        );
+
+        # We store the value currently in $_ to get the distance later.
+        my $store := QAST::Op.new( :op<bind>, 
+            QAST::Var.new( :name($orig_lhs), :scope<lexical>, :decl<var> ),
+            QAST::Op.new( :op<decont>,
+                QAST::Var.new( :name('$_'), :scope<lexical> )
+            )
+        );
+
+        # ...pass the Pair we build to &Str.trans.
+        my $trans := QAST::Op.new(
+            :node($/),
+            :op<callmethod>, :name<trans>,
             QAST::Var.new(:name('$_'), :scope<lexical>),
-            QAST::Op.new(:op<callmethod>, :name<trans>,
+            $pair
+        );
+
+        my $StrDistance := $*W.find_symbol(['StrDistance']);
+        # Putting it all together.
+        my $past := make QAST::Stmt.new(
+            $store,
+            QAST::Op.new(
+                :op<call>, :name('&infix:<=>'),
                 QAST::Var.new(:name('$_'), :scope<lexical>),
-                make_pair($left, QAST::SVal.new(:value($right))),
+                $trans,
+            ),
+            # We build a StrDistance here, which lazily gets us the distance.
+            QAST::Op.new(
+                :op<callmethod>, :name<new>, :returns($StrDistance),
+                QAST::Var.new( :name<StrDistance>, :scope<lexical> ),
+                QAST::Var.new( :name($orig_lhs), :scope<lexical>, :named('before') ),
+                QAST::Var.new( :name('$_'), :scope<lexical>, :named('after') )
             )
         );
+
+        $past<is_trans> := 1;
+        $past
     }
 
     method quote:sym<s>($/) {
@@ -7144,6 +7195,11 @@ class Perl6::QActions is HLL::Actions does STDActions {
                 :node($/)));
     }
 
+    # The next three are currently only used for tr///.
+    method escape:ch ($/)     { make ~$/; }
+    method escape:sym<..>($/) { make ~$/; }
+    method escape:ws ($/)     { make ~$/; }
+
     method escape:sym<$>($/) { make $<EXPR>.ast; }
     method escape:sym<@>($/) { make $<EXPR>.ast; }
     method escape:sym<%>($/) { make $<EXPR>.ast; }

src/Perl6/Grammar.nqp

@@ -3169,12 +3169,13 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
         :my $start;
         :my $stop;
         :my $*CCSTATE := '';
-        <babble($l)>
+        <babble($l, @lang2tweaks)>
         { my $B := $<babble><B>.ast; $lang := $B[0]; $start := $B[1]; $stop := $B[2]; }
+
         $start <left=.nibble($lang)> [ $stop || <.panic: "Couldn't find terminator $stop"> ]
         { $*CCSTATE := ''; }
         [ <?{ $start ne $stop }>
-            <.ws> <quibble($lang2)>
+            $start <right=.nibble($lang)> [ $stop || { $/.CURSOR.panic("Couldn't find terminator $stop") } ]
         ||
             { $lang := self.quote_lang($lang2, $stop, $stop, @lang2tweaks); }
             <right=.nibble($lang)> $stop || <.panic("Malformed replacement part; couldn't find final $stop")>
@@ -3186,7 +3187,7 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
         :my %*RX;
         :my $*INTERPOLATE := 1;
         <rx_adverbs>
-        <tribble(%*RX<P5> ?? %*LANG<P5Regex> !! %*LANG<Regex>, %*LANG<Q>, ['cc'])>
+        <tribble(%*LANG<Q>, %*LANG<Q>, ['cc'])>
         <.old_rx_mods>?
     }
 
@@ -4269,7 +4270,7 @@ grammar Perl6::QGrammar is HLL::Grammar does STD {
         # (must not allow anything to match . in nibbler or we'll lose track of state)
         token escape:ws { \s+ [ <?[#]> <.ws> ]? }
         token escape:sym<#> { '#' <.panic: "Please backslash # for literal char or put whitespace in front for comment"> }
-        token escape:sym<\\> { <sym> <item=.backslash> <.ccstate('\\' ~ $<item>.Str)> }
+        token escape:sym<\\> { <sym> <item=.backslash> <.ccstate('\\' ~ $<item>)> }
         token escape:sym<..> { <sym>
             [
             || <?{ ($*CCSTATE eq '') || ($*CCSTATE eq '..') }> <.sorry("Range missing start character on the left")>
@@ -4283,9 +4284,10 @@ grammar Perl6::QGrammar is HLL::Grammar does STD {
             '-' <?{ $*CCSTATE ne '' }> \s* <!stopper> \S 
             <.obs('- as character range','.. (or \\- if you mean a literal hyphen)')>
         }
-        token escape:ch { $<ch> = [\S] <.ccstate($<ch>.Str)> }
+        token escape:ch { $<ch> = [\S] { self.ccstate($<ch>) } }
 
         token backslash:delim { <text=.starter> | <text=.stopper> }
+        token backslash:<\\> { <text=.sym> }
         token backslash:a { :i <sym> }
         token backslash:b { :i <sym> }
         token backslash:c { :i <sym> <charspec> }

src/core/StrDistance.pm

@@ -0,0 +1,34 @@
+my class StrDistance is Cool {
+    has Str $.before;
+    has Str $.after;
+    has Int $!distance;
+
+    method Bool() {
+        $.before ne $.after
+    }
+
+    method Numeric() {
+        self.Int
+    }
+
+    method Int() {
+        $!distance //= do {
+            my @s = *, $.before.comb;
+            my @t = *, $.after.comb;
+            my @d;
+            @d[$_][ 0] = $_ for ^@s.end;
+            @d[ 0][$_] = $_ for ^@t.end;
+
+            for 1..@s.end X 1..@t.end -> $i, $j {
+                @d[$i][$j] = @s[$i] eq @t[$j]
+                    ??   @d[$i-1][$j-1]    # No operation required when eq
+                    !! ( @d[$i-1][$j  ],   # Deletion
+                         @d[$i  ][$j-1],   # Insertion
+                         @d[$i-1][$j-1],   # Substitution
+                       ).min + 1;
+            }
+
+            @d[*-1][*-1];
+        }
+    }
+}

tools/build/Makefile-JVM.in

@@ -187,6 +187,7 @@ J_CORE_SOURCES = \
   src/core/Argfiles.pm \
   src/core/Inc.pm \
   src/core/Process.pm \
+  src/core/StrDistance.pm \
   src/core/core_epilogue.pm \
 
 PERL6_DEBUG_JAR = perl6-debug.jar

tools/build/Makefile-Moar.in

@@ -188,6 +188,7 @@ M_CORE_SOURCES = \
   src/core/Argfiles.pm \
   src/core/Inc.pm \
   src/core/Process.pm \
+  src/core/StrDistance.pm \
   src/core/core_epilogue.pm \
 
 PERL6_DEBUG_MOAR = perl6-debug.moarvm

tools/build/Makefile-Parrot.in

@@ -255,6 +255,7 @@ P_CORE_SOURCES = \
   src/core/Argfiles.pm \
   src/core/Inc.pm \
   src/core/Process.pm \
+  src/core/StrDistance.pm \
   src/core/core_epilogue.pm \
 
 PERL6_DEBUG_PBC = perl6-debug.pbc