From: Matt S Trout <mst@shadowcat.co.uk>
Date: Wed, 4 Apr 2018 21:24:43 +0000 (+0000)
Subject: rspace tracing
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c99dbb05d5cbafccac051a6877424dacd050ad06;p=scpubgit%2FDX.git

rspace tracing
---

diff --git a/lib/DX/Resolution.pm b/lib/DX/Resolution.pm
index 9e67d4d..3606633 100644
--- a/lib/DX/Resolution.pm
+++ b/lib/DX/Resolution.pm
@@ -1,5 +1,6 @@
 package DX::Resolution;
 
+use DX::Utils qw(expand_deps);
 use DX::Class;
 
 has veracity_depends_on => (is => 'ro', required => 1);
@@ -10,4 +11,22 @@ sub next_resolution { $_[0] }
 
 sub remainder { () }
 
+sub for_deparse {
+  my ($self) = @_;
+  [ statement => [
+    [ symbol => 'resolution' ],
+    [ pairs => [
+      (@{$self->actions}
+        ? [ actions => [ block => $self->actions ] ]
+        : ()),
+      [ veracity_depends_on => [ block => [
+        map [ statement => [
+          [ symbol => (split '::', ${$_->[0]})[-1] ],
+          [ value_path => [ @{$_}[1..$#$_] ] ],
+        ] ], @{expand_deps($self->veracity_depends_on)}
+      ] ] ],
+    ] ],
+  ] ];
+}
+
 1;
diff --git a/lib/DX/ResolutionSpace.pm b/lib/DX/ResolutionSpace.pm
index 8342640..4d2bd1f 100644
--- a/lib/DX/ResolutionSpace.pm
+++ b/lib/DX/ResolutionSpace.pm
@@ -2,6 +2,7 @@ package DX::ResolutionSpace;
 
 use DX::Step::Backtrack;
 use DX::Step::ResolveProposition;
+use DX::Utils qw(expand_deps);
 use DX::Class;
 
 has proposition => (is => 'ro');
@@ -15,8 +16,25 @@ has members => (is => 'ro', required => 1);
 sub for_deparse {
   my ($self) = @_;
   [ statement => [
-    [ symbol => 'rspace' ],
-    [ block => $self->members ],
+    [ symbol => 'resolution_space' ],
+    [ pairs => [
+      [ proposition => $self->proposition ],
+      [ geometry_depends_on => [ block => [
+        map [ statement => [
+          [ symbol => (split '::', ${$_->[0]})[-1] ],
+          [ value_path => [ @{$_}[1..$#$_] ] ],
+        ] ], @{expand_deps($self->geometry_depends_on)}
+      ] ] ],
+      (@{$self->aperture}
+        ? [ aperture => [ block => [
+            map [ statement => [
+              [ symbol => (split '::', ${$_->[0]})[-1] ],
+              [ value_path => [ @{$_}[1..$#$_] ] ],
+            ] ], @{$self->aperture}
+          ] ] ]
+        : ()),
+      [ members => [ block => [ @{$self->members} ] ] ]
+    ] ],
   ] ];
 }
 
diff --git a/lib/DX/ResolutionStrategy.pm b/lib/DX/ResolutionStrategy.pm
index 8c5d65f..ac54832 100644
--- a/lib/DX/ResolutionStrategy.pm
+++ b/lib/DX/ResolutionStrategy.pm
@@ -41,4 +41,30 @@ sub remainder {
   return $self->but(implementation_candidates => \@rest);
 }
 
+sub for_deparse {
+  my ($self) = @_;
+  [ statement => [
+    [ symbol => 'resolution_strategy' ],
+    [ pairs => [
+      [ action_prototypes => [ block => [
+        map {
+          my ($inv, $type, @args) = @$_;
+          [ statement => [
+            [ symbol => $type ],
+            [ value_path => $inv->value_path ],
+            @args
+          ] ]
+        } @{$self->action_prototypes}
+      ] ] ],
+      [ implementation_candidates => [ block => [
+        map [ block => [
+          map [ block => [
+            map +($_->value_path ? [ value_path => $_->value_path ] : $_), @$_
+          ] ], @$_
+        ] ], @{$self->implementation_candidates}
+      ] ] ]
+    ] ],
+  ] ];
+}
+
 1;
diff --git a/lib/DX/Role/Predicate.pm b/lib/DX/Role/Predicate.pm
index a8e86a6..e4e83ba 100644
--- a/lib/DX/Role/Predicate.pm
+++ b/lib/DX/Role/Predicate.pm
@@ -1,11 +1,13 @@
 package DX::Role::Predicate;
 
+use Object::Tap;
 use DX::Role;
 
 sub resolution_step_for {
   my ($self, $prop, @args) = @_;
   $self->_resolution_space_for(@args)
        ->but(proposition => $prop)
+       ->$_tap(sub { trace rspace => $_[0] })
        ->next_step;
 }
 
diff --git a/lib/DX/Step/Backtrack.pm b/lib/DX/Step/Backtrack.pm
index f693c49..a7c107b 100644
--- a/lib/DX/Step/Backtrack.pm
+++ b/lib/DX/Step/Backtrack.pm
@@ -9,6 +9,10 @@ sub apply_to {
   trace backtrack => [ statement => [ [ symbol => 'backtrack' ] ] ];
   foreach my $adj (@{$ss->decisions_taken}) {
     my ($rspace_was, $ss_was) = @$adj;
+    trace rspace => [ statement => [
+      [ symbol => 'remaining' ],
+      @{$rspace_was->remaining_resolution_space->for_deparse->[1]}
+    ] ];
     return $ss_was->but(
       next_step => $rspace_was->remaining_resolution_space->next_step
     );
diff --git a/lib/DX/Step/ResolveProposition.pm b/lib/DX/Step/ResolveProposition.pm
index 42b92dc..3969867 100644
--- a/lib/DX/Step/ResolveProposition.pm
+++ b/lib/DX/Step/ResolveProposition.pm
@@ -4,6 +4,7 @@ use DX::Step::EnterRecheck;
 use DX::Step::Backtrack;
 
 use Types::Standard qw(ArrayRef);
+use DX::Utils qw(expand_deps);
 
 use DX::Class;
 
@@ -28,15 +29,7 @@ has actions => (is => 'lazy', init_arg => undef, builder => sub {
 
 has depends_on => (is => 'lazy', init_arg => undef, builder => sub {
   my ($self) = @_;
-  my $_expand_dep = sub {
-    my ($type, @path) = @{$_[0]};
-    my @expanded = map {
-      ref() ? @{$_->value_path or return ()} : $_
-    } @path;
-    return [ $type, @expanded ];
-  };
-  [ map $_expand_dep->($_),
-      @{$self->current_resolution->veracity_depends_on} ];
+  expand_deps($self->current_resolution->veracity_depends_on);
 });
 
 has alternative_step => (is => 'lazy', init_arg => undef, builder => sub {
@@ -68,7 +61,7 @@ sub apply_to {
       (@{$self->actions}
         ? [ statement => [
             [ symbol => 'actions' ],
-            [ block => [ @{$self->actions} ] ],
+            [ block => $self->actions ],
           ] ]
         : ()),
       [ statement => [
diff --git a/lib/DX/Utils.pm b/lib/DX/Utils.pm
index 0391df3..b52119d 100644
--- a/lib/DX/Utils.pm
+++ b/lib/DX/Utils.pm
@@ -11,7 +11,7 @@ my @const = (
 our @EXPORT_OK = (
   @const,
   (my @builders = qw(rspace rstrat res string number dict proposition)),
-  'deparse', '*trace',
+  'deparse', '*trace', 'expand_deps',
 );
 
 our %EXPORT_TAGS = (
@@ -52,7 +52,7 @@ sub _expand_dep {
   return [ $type, @expanded ];
 }
 
-sub _expand_deps {
+sub expand_deps {
   [ map _expand_dep($_), @{$_[0]} ]
 }