pgmtool.raku

#!/usr/bin/env raku

#use Grammar::Tracer;

grammar PGMFormat {
   token space     { <[\ \t]> }
   token nl        { [ <.space>* \v ]+ }
   token eol       { <.nl> | $ }

   #| Basic JVM Name
   regex name         { <[a..zA..Z_0..9$-]>+ }
   #| Package name, consisting of multiple names joined by .
   regex package-name { <name>+ % '.' }

   #| Method name, which is either a standard name or a special
   #| name for static{} or constructors
   token method-name {
      | '<' [ 'init' | 'clinit' ] '>'
      | <.name>
   }

   # we need this so we can handle in the action object, as
   # it has different semantic meaning
   token class-name { <.name> }
   
   #| A fully qualified name of a class, meaning
   #| a class name that is preceeded by a package name
   regex class-ref { [ <package-name> '.' ]? <class-name> }
   
   token array-flag { '[]' }

   #| A type name, which is a fully qualified name possibly
   #| followed by an array indicator ([])
   token type { <class-ref> <array-flag>* }

   #| Matches a method signature, which has a return type
   token meth {
      <return-type=type> <.ws> <name=method-name> '(' ~ ')' <params=type>* % [ <.ws>? ',' <.ws>? ]
   }

   #| A member field
   token field { <type> <.ws> <name> }

   #| A class mapping, opens a member mapping block
   token class-mapping { <from=.class-ref> <.ws> '->' <.ws> <to=.class-ref> }
   
   #| A member mapping, which describes the relationship between either a method or field
   #| and its updated name
   token member-mapping {
      | <meth> <.ws> '->' <.ws> <new-name=method-name>
      | <field> <.ws> '->' <.ws> <new-name=name>
   }

   #| A mapping block. This opens with a class mapping followed by a colon and nl
   #| Each following line is lead by at least one ws and a member mapping, repeated
   token block {
      <class-mapping> ':' <.nl> # class mapping will always be followed by at least one member
      [ [ <.ws> <member-mapping> ]+ %% <.eol> ]?
   }
   
   token TOP { [ <block> ]+ }
}

#| Grammar for an alternative ProGuard map
#| syntax that is nested, allowing for easy editing
grammar PGTFormat {
   #| Basic JVM Name
   token name { <[a..zA..Z_]> <[a..zA..Z_0..9]>* }

   token comment { '#' .* $ }
   
   #| Rules that can apply to 
   token common-rule { 'rename' }

   rule  package-block {
      'package' <name> '{' <.comment>?
      [
         | <package-block>
         | <class-block>
         | <.comment>
      ]?
      '}' <.comment>?
   }
}

#| Tree that understands semantic meaning of FQDNs and lays them out
#| accordingly
class PGTree {
   role Path {
      has @.package;
      has @.class;
      has $.member;
   }

   #| Tags provide information about the nature of a Node
   #| in the tree.
   role Tag { * };
   class PackageTag does Tag { * };
   class ClassTag does Tag { ... };

   role Node[Tag ::T] { }
   
   role NodeLike[::P, Tag ::T, ::C] {
      has     $.parent;
      has T   $.tag;
      has Str $.name;

      has %.children;

      method insert(::C $child) {
         %!children{$child.name} = $child;
      }
   }

   role Node[PackageTag] does NodeLike[
      Node[PackageTag],
      PackageTag,
      Node[PackageTag]|Node[ClassTag]
   ] {
      proto method declare(@, @, :$tag = Nil, |) { ... }

      multi method declare([], [$name], :$tag = Nil) {
         say " → leaf $name";
         %.children{$name} //= Node[ClassTag].new(
            :parent(self),
            :tag($tag // ClassTag.new),
            :$name
         )
      }

      # This ^
      # Appears to shadow this v
      
      multi method declare([], [$name, *@class], :$tag = Nil) {
         given %.children{$name} //= Node[ClassTag].new: :parent(self), :$name {
            say " → declare({@class.gist}) [ClassTag]";
            .declare(@class, :$tag);
         }
      }

      # Also, @class here doesn't match array params unless it's marked as greedy (*)
      multi method declare([$name, *@package], *@class, :$tag = Nil) {
         given %.children{$name} //= Node[PackageTag].new: :parent(self), :$name {
            say " → declare({@package.gist}, {@class.gist})";
            .declare(@package, |@class, :$tag);
         }
      }
   }
   
   role Node[ClassTag] does NodeLike[
      Node[PackageTag]|Node[ClassTag],
      ClassTag,
      Node[ClassTag]
   ] {
      proto method declare(@, :$tag = Nil, |) { ... }
      
      multi method declare([Str $name], :$tag = Nil) {
         say " → leaf $name [ClassTag]";
         %.children{$name} //= Node[ClassTag].new(
            :parent(self),
            :tag($tag // ClassTag.new),
            :$name
         )
      }

      multi method declare([Str $name, *@class], :$tag = Nil) {
         given %.children{$name} //= Node[ClassTag].new: :parent(self), :$name {
            .declare(@class, :$tag);
         }
      }

   }

   role Member {
      has Str $.name-lhs;
      has Str $.name-rhs;
   }

   #| A type, possibly an array
   class Type {
      has ClassTag $.class;
      has Int      $.dimension = 0;

      multi method ACCEPTS(Type:D $t) {
         $.class ~~ $t.class && $.dimension == $t.dimension;
      }
   }
   
   class Field does Member {
      has Type $.type;
   }

   class Method does Member {
      has Type $.return-type;
      has      @.param-types;
   }
   
   #| ClassTags serve to convey information about member
   #| tag ownership. ClassTags need distinct identity because
   #| they are referenced from both trees.
   class ClassTag does Tag {
      has Node $.lhs is rw;
      has Node $.rhs is rw;

      has %.fields;
      has %.methods;
   }

   has Node[PackageTag] $.lhs = Node[PackageTag].new;
   has Node[PackageTag] $.rhs = Node[PackageTag].new;

   # Grammar Actions
   
   class PGMBuilder {
      has PGTree $.tree;

      method class-name($/)   {
         # break the class name into subclass components
         # be sure to cache the values because we're going
         # to be destructuring this a whole lot
         make $/.Str.split('$').cache
      }
      
      method package-name($/) {
         # Lift the string values for each package name,
         # caching them for the same reason as the class names
         make $<name>.map(*.Str).cache
      }
      
      method class-ref($/) {
         # We don't resolve this yet because we can't know if this is LHS
         # or RHS
         make {
            :package($<package-name>.?made // ()),
            :class($<class-name>.made)
         }
      }
      
      method type($/) {
         # Types in the PGM format always refer to names from the LHS tree
         make {
            :class($<class-ref>.made),
            :dimensions(+$<array-flag>)
         }
      }

      
      method meth($/) {
         make {
            :old-name($<name>.Str),
            :return-type($<return-type>.made),
            :parameter-types($<params>.map: *.made)
         }
      }
      
      method class-mapping($/) {
         my $from = $<from>.made;
         my $to   = $<to>.made;

         dd $from<package>;
         dd $to;

         say "lhs.declare({$from<package>.gist}, {$from<class>.gist}, :tag)";
         
         my $lhs  = $.tree.lhs.declare($from<package>, $from<class>);
         my $tag  = $lhs.tag;
         my $rhs  = $.tree.rhs.declare($to<package>,   $to<class>, :$tag);

         $tag.lhs = $lhs;
         $tag.rhs = $rhs;

         make $tag;
      }

      method member-mapping($/) {
         when $<meth> {
            say $<meth>.made;
         }

         when $<field> {
         }
      }
   }

   class PGTBuilder {
   }

   #| Create an action object appropriate for populating the tree
   #| from a PGMap format file.
   method map-builder {
      PGMBuilder.new: :tree(self);
   }

   #| Create an action object appropriate for populating the tree
   #| from a PGTree format file.
   method tree-builder {
      PGTBuilder.new: :tree(self);
   }
}

sub MAIN(Str $f where *.IO.f) {
   my $tree = PGTree.new;
   
   PGMFormat.parsefile($f, :actions($tree.map-builder));
}

test.map

c.h.a.d -> c.h.a.d:
c.h.a.d$b -> c.h.a.d$b:
    c.h.a.d$b[] $VALUES -> e
    c.h.a.d$b DISK -> a
    c.h.a.d$b MEMORY -> b
    c.h.a.d$b NETWORK -> c
    int debugColor -> d
    void <clinit>() -> <clinit>
    void <init>(java.lang.String,int,int) -> <init>
    c.h.a.d$b valueOf(java.lang.String) -> a
    c.h.a.d$b[] values() -> a
    a[][] b(a[],b$c[][]) -> x