From c4696f5690c33e021475f7b97ba615ffc040f693 Mon Sep 17 00:00:00 2001
From: Carl Masak <cmasak@gmail.com>
Date: Mon, 29 Mar 2010 18:07:01 +0200
Subject: [PATCH] [GGE] grammars now work

See examples/mygrammar for a working example.
---
 examples/mygrammar    | 15 +++++++++++++++
 lib/GGE.pm            |  1 +
 lib/GGE/Exp.pm        | 41 +++++++++++++++++++++++++++++++----------
 lib/GGE/Grammar.pm    | 12 ++++++++++++
 lib/GGE/Match.pm      |  7 +++++--
 lib/GGE/Perl6Regex.pm |  4 ++--
 6 files changed, 66 insertions(+), 14 deletions(-)
 create mode 100644 examples/mygrammar
 create mode 100644 lib/GGE/Grammar.pm

diff --git a/examples/mygrammar b/examples/mygrammar
new file mode 100644
index 0000000..f661cf4
--- /dev/null
+++ b/examples/mygrammar
@@ -0,0 +1,15 @@
+use v6;
+
+use GGE;
+
+my $debug = False;
+
+class MyGrammar is GGE::Grammar {
+    GGE::Perl6Regex.new("<bar>",    :$debug, :grammar<MyGrammar>, :name<TOP>);
+    GGE::Perl6Regex.new("'OH HAI'", :$debug, :grammar<MyGrammar>, :name<bar>);
+}
+
+my GGE::Match $match
+    = MyGrammar.parse('this string contains "OH HAI" as a substring', :$debug);
+
+say $match ?? $match.dump_str('mob', ' ', '') !! "No match\n";
diff --git a/lib/GGE.pm b/lib/GGE.pm
index 7317bb7..c1c3673 100644
--- a/lib/GGE.pm
+++ b/lib/GGE.pm
@@ -1,2 +1,3 @@
 use v6;
 use GGE::Perl6Regex;
+use GGE::Grammar;
diff --git a/lib/GGE/Exp.pm b/lib/GGE/Exp.pm
index 3f04371..c21abb0 100644
--- a/lib/GGE/Exp.pm
+++ b/lib/GGE/Exp.pm
@@ -66,26 +66,44 @@ class GGE::Exp is GGE::Match {
         '  ' x $indent ~ self.WHAT.perl.subst(/^.*':'/, '') ~ $contents;
     }
 
-    method compile(:$debug) {
-        my $source = self.root-p6(:$debug);
+    method compile(:$debug, :$grammar, :$name, :$target = 'routine') {
+        my $source = self.root-p6(:$debug, :$grammar, :$name);
         if $debug {
             say $source;
             say '';
         }
-        my $binary = eval $source
-            or die ~$!;
-        return $binary;
+        if $target eq 'P6' {
+            return $source;
+        }
+        else {
+            my $binary = eval $source
+                or die ~$!;
+            return $binary;
+        }
     }
 
     method reduce() {
         self;
     }
 
-    method root-p6(:$debug) {
+    method root-p6(:$debug, :$grammar, :$name = '') {
         my $code = CodeString.new();
         $code.unique(); # XXX: Remove this one when we do other real calls
-        $code.emit( q[[sub ($m, :$debug) {
-    my $mob = GGE::Match.new($m);
+        my $MATCH = 'GGE::Match';
+        if $grammar {
+            $code.emit( q[[class %0 is also { ]], $grammar );
+            $MATCH = $grammar;
+        }
+        if $name {
+            $code.emit( q[[ method %0(:$debug) {
+    my $m = self;
+            ]], $name );
+        }
+        else {
+            $code.emit( q[[ sub ($m, :$debug) { ]] );
+        }
+        $code.emit( q[[
+    my $mob = %1.new($m);
     my $target = $mob.target;
     my $iscont = $mob.iscont;
     my $mfrom;
@@ -135,7 +153,7 @@ class GGE::Exp is GGE::Match {
             }
             when 'fail' {
                 local-return();
-            } ]], CUT_RULE);
+            } ]], CUT_RULE, $MATCH);
         my $explabel = 'R';
         $GGE::Exp::group = self;
         my $exp = self.reduce;
@@ -150,7 +168,10 @@ class GGE::Exp is GGE::Match {
             }
         }
     }
-} ]]);
+} ]], $name);
+        if $grammar {
+            $code.emit( q[[ } ]] ); # close off the grammar class
+        }
         ~$code;
     }
 
diff --git a/lib/GGE/Grammar.pm b/lib/GGE/Grammar.pm
new file mode 100644
index 0000000..602b726
--- /dev/null
+++ b/lib/GGE/Grammar.pm
@@ -0,0 +1,12 @@
+use v6;
+
+use GGE::Match;
+
+class GGE::Grammar is GGE::Match {
+    method parse($target, :$debug) {
+        die "Cannot call .parse on a grammar with no TOP rule"
+            unless self.can('TOP');
+        my $m = self.new($target);
+        $m.TOP(:$debug);
+    }
+}
diff --git a/lib/GGE/Match.pm b/lib/GGE/Match.pm
index cff9dc8..86befc7 100644
--- a/lib/GGE/Match.pm
+++ b/lib/GGE/Match.pm
@@ -27,6 +27,8 @@ class GGE::Match {
     has $.from is rw = 0;
     has $.to is rw = 0;
     has $.iscont = False;
+    # XXX: This is *so* a hack. Can't think of anything better now. Sorry.
+    has $.iscont2 = False;
     has $.startpos = 0;
     has $!store = Store.new;
     has $!ast;
@@ -37,12 +39,13 @@ class GGE::Match {
     }
 
     multi method new(Str $target) {
-        self.new(:$target, :from(0), :to(-1), :iscont(True));
+        self.new(:$target, :from(0), :to(-1), :iscont(True), :iscont2(True));
     }
 
     multi method new(GGE::Match $match) {
         defined $match ?? self.new(:target($match.target), :from($match.from),
-                                   :to(-1), :iscont(False),
+                                   :to(-1),
+                                   :iscont2(False), :iscont($match.iscont2),
                                    :startpos($match.to))
                        !! self.new();
     }
diff --git a/lib/GGE/Perl6Regex.pm b/lib/GGE/Perl6Regex.pm
index 10b22ef..28e1964 100644
--- a/lib/GGE/Perl6Regex.pm
+++ b/lib/GGE/Perl6Regex.pm
@@ -120,12 +120,12 @@ class GGE::Perl6Regex is also {
     $optable.newtok('prefix::',  :looser<infix:|>,
                     :parsed(&GGE::Perl6Regex::parse_modifier));
 
-    method new($pattern, :$debug) {
+    method new($pattern, :$grammar, :$name, :$debug) {
         my $match = parse_regex($pattern);
         die 'Perl6Regex rule error: can not parse expression'
             if $match.to < $pattern.chars;
         my $exp = perl6exp($match.hash-access('expr'), { lexscope => {} });
-        my $binary = $exp.compile(:$debug);
+        my $binary = $exp.compile(:$debug, :$grammar, :$name);
         return self.bless(*, :$exp, :$binary);
     }