Skip to content

Commit

Permalink
Implement stepping through regexes, with view of current match state.…
Browse files Browse the repository at this point in the history 
… Some todo and polish needed, but basically works.
  • Loading branch information
@jnthn
jnthn committed Aug 21, 2012
1 parent 70c9c91 commit fbc95e1
Show file tree
Hide file tree
Showing 2 changed files with 100 additions and 18 deletions.
46 changes: 46 additions & 0 deletions bin/perl6-debug.nqp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down Expand Up @@ -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;
}
Expand Down
72 changes: 54 additions & 18 deletions lib/Debugger/UI/CommandLine.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand All @@ -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 {
Expand Down Expand Up @@ -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;
Expand All @@ -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) {
Expand Down Expand Up @@ -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;
}
Expand Down Expand Up @@ -248,23 +275,23 @@ 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');
}
}
}
when /^ < e eval > \s+ (.+)/ {
self.eval_in_ctx($ctx, ~$0);
eval_in_ctx($ctx, ~$0);
CATCH {
default {
say colored($_.message, 'red');
}
}
}
when /^ (< $ @ % > .+)/ {
say self.eval_in_ctx($ctx, ~$0).perl;
say eval_in_ctx($ctx, ~$0).perl;
CATCH {
default {
say colored($_.message, 'red');
Expand Down Expand Up @@ -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);
}
});
Expand Down

0 comments on commit fbc95e1

Please sign in to comment.