First pass at a Brainfuck to Perl 6 translator

BF.p6

use v6.c;

grammar Brainfuck {
  token TOP { <statements> }

  token statements { <statement>* }

  token statement {
    || $<value> = <comment>
    || $<value> = <oplist>
    || $<value> = <loop>
  }

  token op {
    || $<op> = <repeated-op>
    || $<op> = <combined-op>
    || $<op> = <single-op>
  }

  proto token repeated-op {*}
  token repeated-op:sym<single> {
    <single-op>  $<repeat> = $<single-op>+
  }
  token repeated-op:sym<combined> {
    <combined-op>  $<repeat> = $<combined-op>+
  }

  proto token single-op {*}
  token single-op:sym«<» {<sym>}
  token single-op:sym«>» {<sym>}
  token single-op:sym<-> {<sym>}
  token single-op:sym<+> {<sym>}
  token single-op:sym<.> {<sym>}
  token single-op:sym<,> {<sym>}

  proto token combined-op {*}
  token combined-op:sym«[-]» { <sym> | '[+]'  } # clear
  token combined-op:sym«[-]>» { <sym> | '[+]>' } # clear, move to next
  token combined-op:sym«[-]+» {[<sym> | '[+]+'] @<value> = ('+')*} # set to a value
  token combined-op:sym«[-]+>» { ['[-]+' | '[+]+'] @<value> = ('+')* '>' }

  token oplist { <op>+ }

  token loop { '[' ~ ']' <statements> }

  token comment {
    | ^ [<.comment-char>* <loop>]+
    | <.comment-char>+
  }
  token comment-char {
    # <!before <op>>
    # <!before <loop>>
    # .

    <-[ ,. \[\] +\- <> ]>
  }
}

role Op {
  method equiv ( $level = 0 --> Str ) {...}
}

class SingleOp {...}
class RepeatedSingleOp {...}
class CombinedOp {...}
class RepeatedCombinedOp {...}


class SingleOp does Op {
  has Str $.ident is required;

  method equiv ( $level = 0 ) {
    my $pad = '  ' x $level;
    given $.ident {
      when ''  { Slip }
      when '<' { $pad ~ '--$ptr;' }
      when '>' { $pad ~ '++$ptr;' }
      when '-' { $pad ~ '--@data-mem[$ptr];' }
      when '+' { $pad ~ '++@data-mem[$ptr];' }
      when '.' { $pad ~ 'print chr @data-mem[$ptr];' }
      when ',' { $pad ~ '@data-mem[$ptr] = ord $*IN.getc;' }
    }
  }

  method repeat ( UInt $repeat ) {
    return SingleOp unless $repeat;
    return self if $repeat == 1;
    RepeatedSingleOp.new: :$.ident, :$repeat;
  }
}

class RepeatedSingleOp is SingleOp {
  has UInt $.repeat is required;

  method equiv ( $level = 0  ) {
    my $pad = '  ' x $level;
    given $.ident {
      when '<' { $pad ~ '$ptr -= ' ~ $.repeat ~ ';' }
      when '>' { $pad ~ '$ptr += ' ~ $.repeat ~ ';' }
      when '-' { $pad ~ '@data-mem[$ptr] -= ' ~ $.repeat ~ ';' }
      when '+' { $pad ~ '@data-mem[$ptr] += ' ~ $.repeat ~ ';' }
      when '.' { $pad ~ 'print chr(@data-mem[$ptr]) x ' ~ $.repeat ~ ';' }
      when ',' { $pad ~ '$*IN.getc xx ' ~ $.repeat - 1 ~'@data-mem[$ptr] = ord $*IN.getc' }
    }
  }
}

class CombinedOp is SingleOp {
  has UInt $.value;

  method equiv ( $level = 0 ) {
    my $pad = '  ' x $level;
    given $.ident {
      when '>+'    { $pad ~     '++@data-mem[++$ptr];' }
      when '[-]'   { $pad ~     '@data-mem[$ptr] = 0;' }
      when '[-]+'  { $pad ~ Q:c '@data-mem[$ptr] = {$.value};' }
      when '[-]>'  { $pad ~     '@data-mem[$ptr++] = 0;' }
      when '[-]+>' { $pad ~ Q:c '@data-mem[$ptr++] = {$.value};' }
      when '>[-]'  { $pad ~     '@data-mem[++$ptr] = 0;' }
      when '>[-]+' { $pad ~ Q:c '@data-mem[++$ptr] = {$.value};' }
    }
  }

  method repeat ( UInt $repeat --> Op ) {
    return SingleOp unless $repeat;
    return self if $repeat == 1;

    # pointless repetition
    return self if $.ident eq '[-]' | '[-]+';

    RepeatedCombinedOp.new: :$.ident, :$repeat; 
  }
}

class RepeatedCombinedOp is CombinedOp {
  has UInt $.repeat is required;

  method equiv ( $level = 0 ) {
    my $pad = '  ' x $level;
    given $.ident {
      when '>+'    { slip  ($pad ~ '++@data-mem[++$ptr];') xx $.repeat }
      when '[-]'   { callwith $level } # pointless repetition
      when '[-]+'  { callsame $level }

      when '[-]>'  { $pad ~ Q:c '@data-mem[$ptr..^$ptr+{$.repeat}] = 0 xx {$.repeat}; $ptr += {$.repeat};' }
      when '[-]+>' { $pad ~ Q:c '@data-mem[$ptr..^$ptr+{$.repeat}] = {$.value} xx {$.repeat}; $ptr += {$.repeat};' }
      when '>[-]'  { $pad ~ Q:c '@data-mem[$ptr+1..$ptr+{$.repeat}] = 0 xx {$.repeat}; $ptr += {$.repeat}' }
      when '>[-]+' { $pad ~ Q:c '@data-mem[$ptr+1..$ptr+{$.repeat}] = {$.value} xx {$.repeat}; $ptr += {$.repeat}' }
    }
  }
}

class OpList does Op {
  has Op @.ops is required;

  method equiv ( $level = 0 --> Str ) {
    join "\n", @.ops».equiv($level)
  }
}

class Loop does Op {
  has Op @.statements is required;

  method equiv ( $level = 0 ) {
   my $pad = ' ' x 2 * $level;
   $pad ~ Q:b 'while @data-mem[$ptr] {\n'~
   join("\n", @.statements».equiv($level+1),'') ~
   "{$pad}}\n"
  }
}
class Comment does Op {
  has Str $.text is required;
  method equiv ( $level = 0 ) {
    return slip if $.text ~~ m/^\s*$/;
    S/^^/{ ' ' x $level*2 }# / given $.text;
  }
}

class Actions {
  method TOP ($/) { make $<statements>.made }

  method comment ($/) { make Comment.new: :text(~$/) }
  method comment-char ($/) { make ~$/ }

  method op ($/) { make $<op>.made }

  method repeated-op:sym<single> ($/) {
    make $<single-op>.made.repeat: 1+@<repeat>
  }
  method repeated-op:sym<combined> ($/) {
    say $*ERR: $/.kv;
    say $*ERR: .equiv given make $<combined-op>.made.repeat: 1+$<repeat>;
  }

  method !op ($/) { make SingleOp.new( :ident(~$<sym>) ) }
  method single-op:sym«<» ($/) { self!op: $/ }
  method single-op:sym«>» ($/) { self!op: $/ }
  method single-op:sym<-> ($/) { self!op: $/ }
  method single-op:sym<+> ($/) { self!op: $/ }
  method single-op:sym<.> ($/) { self!op: $/ }
  method single-op:sym<,> ($/) { self!op: $/ }

  method combined-op:sym<[-]>  ($/) {
    make CombinedOp.new: :ident<[-]>;
  }
  method combined-op:sym«[-]>»  ($/) { 
    make CombinedOp.new: :ident«[-]>»,  :equiv('@data-mem[$ptr] = 0;');
  }
  method combined-op:sym<[-]+> ($/) {
    make CombinedOp.new: :ident<[-]+>, :value(1+@<value>);
  }
  method combined-op:sym«[-]+>» ($/) {
    make CombinedOp.new: :ident«[-]+>», :value(1+@<value>);
  }

  method oplist ($/) { make OpList.new: ops => $/.values».made }

  method statements ($/) { make OpList.new: ops => @<statement>».made }
  method statement ($/) { make $<value>.made }
  method loop ($/) { make Loop.new: statements => $<statements>.made.ops }

  method FALLBACK ($name,$/){ die $name; make ($name,$/.made // ~$/) }

  method alpha ($/) { #`(say $/.perl) }
}

multi sub MAIN ( $file ){
  say Brainfuck.parsefile($file, :actions(Actions)).made.equiv;
}
multi sub MAIN () {
  $*IN.encoding: 'latin1';
  print Brainfuck.parse($*IN.slurp-rest, :actions(Actions)).made.equiv
}