Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Initial commit of modules, a README and META.info.

  • Loading branch information...
commit 4689eefcd570fb07999a8888a8c15534df1e75c6 0 parents
Jonathan Worthington authored
7 META.info
@@ -0,0 +1,7 @@
+{
+ "name" : "Grammar::Debugger",
+ "version" : "*",
+ "description" : "Simple tracing and debugging support for Perl 6 grammars",
+ "depends" : [ "Term::ANSIColor" ],
+ "source-url" : "git://github.com/jnthn/grammar-debugger.git"
+}
1  README.markdown
@@ -0,0 +1 @@
+# Grammar::Debugger
171 lib/Grammar/Debugger.pm
@@ -0,0 +1,171 @@
+use Term::ANSIColor;
+
+my enum InterventionPoint <EnterRule ExitRule>;
+
+multi trait_mod:<is>(Method $m, :$breakpoint!) is export {
+ $m does role { method breakpoint { True } }
+}
+multi trait_mod:<will>(Method $m, $cond, :$break!) is export {
+ $m does role {
+ has $.breakpoint-condition is rw;
+ method breakpoint { True }
+ }
+ $m.breakpoint-condition = $cond;
+}
+
+my class DebuggedGrammarHOW is Metamodel::GrammarHOW is Mu {
+ has $!indent = 0;
+ has $!auto-continue = False;
+ has $!stop-at-fail = False;
+ has $!stop-at-name = '';
+ has @!breakpoints;
+ has %!cond-breakpoints;
+
+ method add_method(Mu $obj, $name, $code) {
+ if $code.?breakpoint {
+ if $code.?breakpoint-condition {
+ %!cond-breakpoints{$code.name} = $code.breakpoint-condition;
+ }
+ else {
+ @!breakpoints.push($code.name);
+ }
+ }
+ nextsame;
+ }
+
+ method find_method($obj, $name) {
+ my $meth := callsame;
+ substr($name, 0, 1) eq '!' || $name eq any(<parse CREATE Bool defined MATCH>) ??
+ $meth !!
+ -> $c, |$args {
+ # Method name.
+ say ('| ' x $!indent) ~ BOLD() ~ $name ~ RESET();
+
+ # Call rule.
+ self.intervene(EnterRule, $name);
+ $!indent++;
+ my $result := $meth($obj, |$args);
+ $!indent--;
+
+ # Dump result.
+ my $match := $result.MATCH;
+ say ('| ' x $!indent) ~ '* ' ~
+ ($result.MATCH ??
+ colored('MATCH', 'white on_green') ~ self.summary($match) !!
+ colored('FAIL', 'white on_red'));
+ self.intervene(ExitRule, $name, :$match);
+ $result
+ }
+ }
+
+ method intervene(InterventionPoint $point, $name, :$match) {
+ # Any reason to stop?
+ my $stop =
+ !$!auto-continue ||
+ $point == EnterRule && $name eq $!stop-at-name ||
+ $point == ExitRule && !$match && $!stop-at-fail ||
+ $point == EnterRule && $name eq any(@!breakpoints) ||
+ $point == ExitRule && $name eq any(%!cond-breakpoints.keys)
+ && %!cond-breakpoints{$name}.ACCEPTS($match);
+ if $stop {
+ my $done;
+ repeat {
+ my @parts = split /\s+/, prompt("> ");
+ $done = True;
+ given @parts[0] {
+ when '' {
+ $!auto-continue = False;
+ $!stop-at-fail = False;
+ $!stop-at-name = '';
+ }
+ when 'r' {
+ given +@parts {
+ when 1 {
+ $!auto-continue = True;
+ $!stop-at-fail = False;
+ $!stop-at-name = '';
+ }
+ when 2 {
+ $!auto-continue = True;
+ $!stop-at-fail = False;
+ $!stop-at-name = @parts[1];
+ }
+ default {
+ usage();
+ $done = False;
+ }
+ }
+ }
+ when 'rf' {
+ $!auto-continue = True;
+ $!stop-at-fail = True;
+ $!stop-at-name = '';
+ }
+ when 'bp' {
+ if +@parts == 2 && @parts[1] eq 'list' {
+ say "Current Breakpoints:\n" ~
+ @!breakpoints.map({ " $_" }).join("\n");
+ }
+ elsif +@parts == 3 && @parts[1] eq 'add' {
+ unless @!breakpoints.grep({ $_ eq @parts[2] }) {
+ @!breakpoints.push(@parts[2]);
+ }
+ }
+ elsif +@parts == 3 && @parts[1] eq 'rm' {
+ my @rm'd = @!breakpoints.grep({ $_ ne @parts[2] });
+ if +@rm'd == +@!breakpoints {
+ say "No breakpoint '@parts[2]'";
+ }
+ else {
+ @!breakpoints = @rm'd;
+ }
+ }
+ elsif +@parts == 2 && @parts[1] eq 'rm' {
+ @!breakpoints = [];
+ }
+ else {
+ usage();
+ }
+ $done = False;
+ }
+ when 'q' {
+ exit(0);
+ }
+ default {
+ usage();
+ $done = False;
+ }
+ }
+ } until $done;
+ }
+ }
+
+ method summary($match) {
+ my $snippet = $match.Str;
+ my $sniplen = 60 - (3 * $!indent);
+ $sniplen > 0 ??
+ colored(' ' ~ $snippet.substr(0, $sniplen).perl, 'white') !!
+ ''
+ }
+
+ sub usage() {
+ say
+ " r run (until breakpoint, if any)\n" ~
+ " <enter> single step\n" ~
+ " rf run until a match fails\n" ~
+ " r <name> run until rule <name> is reached\n" ~
+ " bp add <name> add a rule name breakpoint\n" ~
+ " bp list list all active rule name breakpoints\n" ~
+ " bp rm <name> remove a rule name breakpoint\n" ~
+ " bp rm removes all breakpoints\n" ~
+ " q quit"
+ }
+
+ method publish_method_cache($obj) {
+ # Suppress this, so we always hit find_method.
+ }
+}
+
+# Export this as the meta-class for the "grammar" package declarator.
+my module EXPORTHOW { }
+EXPORTHOW.WHO.<grammar> = DebuggedGrammarHOW;
44 lib/Grammar/Tracer.pm
@@ -0,0 +1,44 @@
+use Term::ANSIColor;
+
+my class TracedGrammarHOW is Metamodel::GrammarHOW is Mu {
+ my $indent = 0;
+
+ method find_method($obj, $name) {
+ my $meth := callsame;
+ substr($name, 0, 1) eq '!' || $name eq any(<parse CREATE Bool defined MATCH>) ??
+ $meth !!
+ -> $c, |$args {
+ # Method name.
+ say ('| ' x $indent) ~ BOLD() ~ $name ~ RESET();
+
+ # Call rule.
+ $indent++;
+ my $result := $meth($obj, |$args);
+ $indent--;
+
+ # Dump result.
+ my $match := $result.MATCH;
+ say ('| ' x $indent) ~ '* ' ~
+ ($result.MATCH ??
+ colored('MATCH', 'white on_green') ~ summary($match) !!
+ colored('FAIL', 'white on_red'));
+ $result
+ }
+ }
+
+ sub summary($match) {
+ my $snippet = $match.Str;
+ my $sniplen = 60 - (3 * $indent);
+ $sniplen > 0 ??
+ colored(' ' ~ $snippet.substr(0, $sniplen).perl, 'white') !!
+ ''
+ }
+
+ method publish_method_cache($obj) {
+ # Suppress this, so we always hit find_method.
+ }
+}
+
+# Export this as the meta-class for the "grammar" package declarator.
+my module EXPORTHOW { }
+EXPORTHOW.WHO.<grammar> = TracedGrammarHOW;
Please sign in to comment.
Something went wrong with that request. Please try again.