Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Implement stepping through regexes, with view of current match state.…

… Some todo and polish needed, but basically works.
  • Loading branch information...
commit fbc95e1b24d9f950d9870bd74b022aead4e1aa5a 1 parent 70c9c91
@jnthn authored
Showing with 100 additions and 18 deletions.
  1. +46 −0 bin/perl6-debug.nqp
  2. +54 −18 lib/Debugger/UI/CommandLine.pm
View
46 bin/perl6-debug.nqp
@@ -35,6 +35,50 @@ sub ps_qast() {
)
}
+grammar Perl6::HookRegexGrammar is Perl6::RegexGrammar {
+ method nibbler() {
+ my $*RX_TOP_LEVEL_NIBBLER := 0;
+ unless %*RX<DEBUGGER_SEEN> {
+ %*RX<DEBUGGER_SEEN> := 1;
+ $*RX_TOP_LEVEL_NIBBLER := 1;
+ }
+ Perl6::RegexGrammar.HOW.find_method(Perl6::RegexGrammar, 'nibbler')(self)
+ }
+}
+
+class Perl6::HookRegexActions is Perl6::RegexActions {
+ method nibbler($/) {
+ if $*RX_TOP_LEVEL_NIBBLER && $*DEBUG_HOOKS.has_hook('regex_region') {
+ my $file := pir::find_caller_lex__Ps('$?FILES') // '<unknown>';
+ $*DEBUG_HOOKS.get_hook('regex_region')($file, $/.from, $/.to);
+ }
+ Perl6::RegexActions.nibbler($/);
+ }
+
+ method quantified_atom($/) {
+ Perl6::RegexActions.quantified_atom($/);
+ my $qa := $/.ast;
+ if $qa && $*DEBUG_HOOKS.has_hook('regex_atom') {
+ $/.'!make'(QAST::Regex.new(
+ :rxtype('concat'),
+ QAST::Regex.new(
+ :rxtype('qastnode'),
+ :subtype('declarative'),
+ QAST::Op.new(
+ :op('call'),
+ QAST::WVal.new( :value($*DEBUG_HOOKS.get_hook('regex_atom')) ),
+ $*W.add_string_constant(pir::find_caller_lex__ps('$?FILES') // '<unknown>'),
+ ps_qast(),
+ $*W.add_numeric_constant('Int', $/.from),
+ $*W.add_numeric_constant('Int', $/.to)
+ )
+ ),
+ $qa
+ ));
+ }
+ }
+}
+
class Perl6::HookActions is Perl6::Actions {
my %uninteresting := nqp::hash(
'package_declarator', 1,
@@ -157,6 +201,8 @@ class Perl6::HookGrammar is Perl6::Grammar {
$*DEBUG_HOOKS.get_hook('new_file')($file, self.MATCH.orig);
# Also fiddle the %*LANG for the appropriate actions.
+ %*LANG<Regex> := Perl6::HookRegexGrammar;
+ %*LANG<Regex-actions> := Perl6::HookRegexActions;
%*LANG<MAIN> := Perl6::HookGrammar;
%*LANG<MAIN-actions> := Perl6::HookActions;
}
View
72 lib/Debugger/UI/CommandLine.pm
@@ -5,12 +5,23 @@ use Term::ANSIColor;
# The source code of the files we've encountred while debugging.
my %sources;
+sub eval_in_ctx($ctx, $code) {
+ ENTER $*DEBUG_HOOKS.suspend();
+ LEAVE $*DEBUG_HOOKS.unsuspend();
+ my $compiler := pir::compreg__PS('perl6');
+ my $vm_ctx := nqp::getattr(nqp::p6decont($ctx), PseudoStash, '$!ctx');
+ my $pbc := $compiler.compile($code, :outer_ctx($vm_ctx), :global(GLOBAL));
+ nqp::atpos($pbc, 0).set_outer_ctx($vm_ctx);
+ $pbc();
+}
+
# Represents a file that we're debugging.
my class SourceFile {
has $.filename;
has $.source;
has @!lines;
has @!line_offsets;
+ has @!regex_regions;
method BUILD(:$!filename, :$!source) {
# Ensure source ends with a newline.
@@ -30,6 +41,10 @@ my class SourceFile {
@!line_offsets.push($!source.chars);
}
+ method add_regex_region($from_pos, $to_pos) {
+ @!regex_regions.push(item $from_pos..$to_pos);
+ }
+
method line_of($pos, $def_line, $def_pos) {
my $last_p = 0;
for @!line_offsets.kv -> $l, $p {
@@ -90,7 +105,28 @@ my class SourceFile {
}
}
- method summary_around($from, $to) {
+ method regex_match_status($from, $to, $ctx) {
+ if $from..$to ~~ any(@!regex_regions) {
+ my $cur = try eval_in_ctx($ctx, q[DYNAMIC::<$¢>]);
+ if $cur ~~ Cursor {
+ my $pos = $cur.pos;
+ my $before = $cur.target.substr(0, $pos);
+ my $after = $cur.target.substr($pos);
+ if $cur.target.chars > 77 {
+
+ }
+ return normal_lines(
+ [
+ colored('Regex Match Position', 'blue'),
+ colored($before, 'green') ~ $after
+ ],
+ 'blue')
+ }
+ }
+ ()
+ }
+
+ method summary_around($from, $to, $ctx) {
my ($from_line, $from_pos) = self.line_of($from, 0, 0);
my ($to_line, $to_pos) = self.line_of($to, $from_line, $from_pos);
my $ctx_start = $from_line - 2;
@@ -101,7 +137,8 @@ my class SourceFile {
colored("+ $!filename ($ctx_start.succ() - $ctx_end.succ())", 'blue'),
normal_lines(@!lines[$ctx_start..^$from_line], 'blue'),
highlighted_lines(@!lines[$from_line..$to_line], $from_pos, $to_pos),
- normal_lines(@!lines[$to_line^..$ctx_end], 'blue');
+ normal_lines(@!lines[$to_line^..$ctx_end], 'blue'),
+ self.regex_match_status($from, $to, $ctx);
}
method throw_summary($e, $line) {
@@ -141,17 +178,7 @@ my class DebugState {
my Bool $in_prompt = False;
my %breakpoints;
my $cur_ex;
-
- method eval_in_ctx($ctx, $code) {
- ENTER $*DEBUG_HOOKS.suspend();
- LEAVE $*DEBUG_HOOKS.unsuspend();
- my $compiler := pir::compreg__PS('perl6');
- my $vm_ctx := nqp::getattr(nqp::p6decont($ctx), PseudoStash, '$!ctx');
- my $pbc := $compiler.compile($code, :outer_ctx($vm_ctx), :global(GLOBAL));
- nqp::atpos($pbc, 0).set_outer_ctx($vm_ctx);
- $pbc();
- }
-
+
method set_current_exception($ex) {
$cur_ex = $ex;
}
@@ -248,7 +275,7 @@ my class DebugState {
!! return
}
when /^ < p print s say > \s+ (.+)/ {
- say self.eval_in_ctx($ctx, ~$0);
+ say eval_in_ctx($ctx, ~$0);
CATCH {
default {
say colored($_.message, 'red');
@@ -256,7 +283,7 @@ my class DebugState {
}
}
when /^ < e eval > \s+ (.+)/ {
- self.eval_in_ctx($ctx, ~$0);
+ eval_in_ctx($ctx, ~$0);
CATCH {
default {
say colored($_.message, 'red');
@@ -264,7 +291,7 @@ my class DebugState {
}
}
when /^ (< $ @ % > .+)/ {
- say self.eval_in_ctx($ctx, ~$0).perl;
+ say eval_in_ctx($ctx, ~$0).perl;
CATCH {
default {
say colored($_.message, 'red');
@@ -365,13 +392,22 @@ $*DEBUG_HOOKS.set_hook('new_file', -> $filename, $source {
});
$*DEBUG_HOOKS.set_hook('statement_simple', -> $filename, $ctx, $from, $to {
if DebugState.should_break_at($filename, $from, $to) {
- say %sources{$filename}.summary_around($from, $to);
+ say %sources{$filename}.summary_around($from, $to, $ctx);
DebugState.issue_prompt($ctx, $filename);
}
});
$*DEBUG_HOOKS.set_hook('statement_cond', -> $filename, $ctx, $type, $from, $to {
if DebugState.should_break_at($filename, $from, $to) {
- say %sources{$filename}.summary_around($from, $to);
+ say %sources{$filename}.summary_around($from, $to, $ctx);
+ DebugState.issue_prompt($ctx, $filename);
+ }
+});
+$*DEBUG_HOOKS.set_hook('regex_region', -> $filename, $from_pos, $to_pos {
+ %sources{$filename}.add_regex_region($from_pos, $to_pos);
+});
+$*DEBUG_HOOKS.set_hook('regex_atom', -> $filename, $ctx, $from, $to {
+ if DebugState.should_break_at($filename, $from, $to) {
+ say %sources{$filename}.summary_around($from, $to, $ctx);
DebugState.issue_prompt($ctx, $filename);
}
});
Please sign in to comment.
Something went wrong with that request. Please try again.