misc/Parser-Mini/pil1_json_emit_p6.pl

   1 =pod
   2
   3 PIL2-JSON simple Perl 6 code emitter
   4 by fglock
   5
   6   ../../pugs -CPIL2-JSON -e ' say "hello" ' | \
   7     ../../pugs pil2_json_emit_p6.pl
   8
   9   use v6-alpha;
  10   &*END () {  }
  11   (&say("hello"));
  12
  13 Other examples:
  14
  15   ../../pugs -Cpil2-json -e ' my Int $x; ($x~"a")( "a",1,$x,$x+1); { say 1 } ' | \
  16     ../../pugs pil2_json_emit_p6.pl
  17
  18 The code created by this example has syntax errors, but I'm not sure if these things are
  19 really forbidden in p6:
  20
  21   ../../pugs -Cpil2-json -e 'my ($x,$y)=(1,2); sub infix:<aaa>($a,$b){$a+1} 1 aaa 2;' | \
  22     ../../pugs pil2_json_emit_p6.pl
  23
  24 =cut
  25
  26 use v6-alpha;
  27
  28 # -- Language specific
  29
  30 sub emit_Main ( $global, $main ) {
  31     "#! /usr/bin/pugs\n" ~
  32     "use v6-alpha;\n" ~
  33     $global ~ $main
  34 }
  35 sub emit_Stmt ( $s ) { $s ~ '; ' }
  36 sub emit_Code ( $body, $is_multi, $lvalue, @params, $type ) {
  37     '{ ' ~ $body ~ ' }'
  38 }
  39 sub emit_Assign( $to, $from ) { $to ~ ' = ' ~ $from }
  40 sub emit_Bind( $to, $from )   { $to ~ ' := ' ~ $from }
  41 sub emit_Sub ( $name, $body, $is_multi, $lvalue, @params, $type ) {
  42     if @params.elems > 1 {
  43         for 0 .. @params.elems-2 -> $i {
  44             # if there are many invocants, separate them with ',' instead of ':'
  45             if @params[$i+1] ~~ m:perl5 {:$} {
  46                 @params[$i] ~~ s:perl5 {:$}{,};
  47             }
  48         }
  49     }
  50     my $param_list = @params.join(" ");
  51     $param_list ~~ s:perl5 {,$}{};  # remove last ','
  52     " $name (" ~ $param_list ~ ") { " ~ $body ~ " \}\n"
  53 }
  54 sub emit_App ( $function, @args, $context, $invocant ) {
  55     "(" ~ $function ~ "(" ~  @args.join(", ") ~ ")" ~ ")"
  56 }
  57 sub emit_Pad ( $scope, @symbols, $statements ) {
  58     "\{\n" ~ @symbols.map:{ "my " ~ emit_Variable($_) ~ ";\n" } ~ "$statements\n\}\n";
  59 }
  60 sub emit_Variable ( $s is copy ) {
  61     # rewrite PIL2 '"&infix:+"' to p6 '&infix:<+>'
  62     # but don't re-quote '&main::zz'
  63     $s ~~ s:perl5 /^"(.*)"$/$0/;
  64     $s ~~ s:perl5 {\&(.+fix:)([^:].*)}{&$0:<$1>};
  65
  66     # XXX fix corner cases like 'infix:<:>' and '&main::infix:<aaa>'
  67     $s ~~ s:perl5 {(fix::<)(.*?)>$}{fix:<$1>};
  68     $s ~~ s:perl5 {fix::$}{fix:<:>};
  69
  70     $s
  71 }
  72 sub emit_Int ( $s ) { $s }
  73 sub emit_Str ( $s ) { $s }
  74 sub emit_Rat ( $a, $b ) { "($a / $b)" }
  75 sub emit_parameter(
  76     $name, $is_invocant, $is_lvalue, $is_lazy, $is_named,
  77     $is_optional, $is_writable, $context, $default )
  78 {
  79     #say "(param=$name, $is_invocant, $is_lvalue, $is_lazy, $is_named, ",
  80     #    "$is_optional, $is_writable, <", $context.perl, ">, <$default>)";
  81
  82     # ??? - "paramDefault"
  83     # ??? - what is the syntax for $is_lvalue
  84     # ??? - what is the PIL for 'is copy'
  85
  86     # $context = [["CxtSlurpy", [[["MkType", ["Int"] ]]] ]]
  87     my $is_slurpy = $context[0][0] eq '"CxtSlurpy"';
  88     my $type = emit_Variable( $context[0][1][0][0][1] );
  89
  90     my $s;
  91     $s ~= $type eq 'main' ?? '' !! ($type ~ ' ');
  92     $s ~= $is_slurpy ?? '*' !! '';
  93
  94     $s ~= $is_named    eq 'true'        ?? ':' !! '';
  95     $s ~= emit_Variable( $name );
  96     $s ~= $is_optional eq 'true'        ?? '?' !! '';   # '!' is default
  97     $s ~= ' is rw '   if $is_writable eq 'true';
  98     $s ~= ' is lazy ' if $is_lazy     eq 'true';
  99     $s ~= $is_invocant eq 'true'        ?? ':' !! ',';
 100     return $s;
 101 }
 102 sub emit_parameter_with_default( $param, $default ) {
 103     return $param if $default eq '';
 104     # rewrite '$name,' to '$name = default,'
 105     my ($name, $separator) = $param ~~ m:perl5 {(.*)(.)};
 106     $name ~ ' = ' ~ $default ~ $separator
 107 }
 108
 109 # -- Main program
 110 # this is the same for all languages
 111
 112 push @*INC, "./";
 113 require 'pil2_json_emit.pm';
 114
 115 # slurp stdin - xinming++
 116 my $pil2 = ** $*IN.slurp;
 117
 118 my @b = tokenize( $pil2 );
 119 # say "Tokens: ", @b.join('><');
 120
 121 my $ast = parse( << { >>, 'hash', << } >>, @b );
 122 # say $ast.perl;
 123
 124 my $program = traverse_ast( $ast );
 125 say $program;
 126