From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sat, 12 Mar 2016 05:25:17 +0000 (+0000)
Subject: const and basic tracing
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bcee3a691353e457e0b72580656c2448960bb1d7;p=scpubgit%2FDX.git

const and basic tracing
---

diff --git a/fragments/member_at b/fragments/member_at
new file mode 100644
index 0000000..887e2ed
--- /dev/null
+++ b/fragments/member_at
@@ -0,0 +1,11 @@
+?
+eq ?X {{ a 1 b 2 c 3 }}
+member_at X ?Y ?Z
+...
+qlist
+?
+eq ?X {{ a 1 b 2 c 3 }}
+member_at X ?Y ?Z
+eq Z 2
+...
+qlist
diff --git a/lib/DX/Class.pm b/lib/DX/Class.pm
index a25c72f..c42d52e 100644
--- a/lib/DX/Class.pm
+++ b/lib/DX/Class.pm
@@ -5,6 +5,7 @@ use Import::Into;
 sub import {
   strictures->import::into(1); # should pass version
   DX::Types->import::into(1, ':types', ':assert');
+  DX::Utils->import::into(1, '*trace');
   Try::Tiny->import::into(1);
   Moo->import::into(1);
   # This would not be safe with method modifiers, but since the role
diff --git a/lib/DX/Hypothesis.pm b/lib/DX/Hypothesis.pm
index 314cc74..1bad497 100644
--- a/lib/DX/Hypothesis.pm
+++ b/lib/DX/Hypothesis.pm
@@ -63,6 +63,8 @@ sub but_recheck_for {
     action_policy => $ap,
   );
 
+  trace 'step.recheck.hyp' => $hyp;
+
   my $ss = DX::SearchState->new_for($hyp);
 
   return undef unless my $sol_ss = $ss->find_solution;
@@ -75,6 +77,8 @@ sub but_recheck_for {
     $_, $sol_rps->dependencies_for($_)
   ) for @recheck;
 
+  trace 'step.recheck.done' => 'yay';
+
   return $self->but(resolved_propositions => $rps);
 }
 
diff --git a/lib/DX/SearchState.pm b/lib/DX/SearchState.pm
index 4245668..f136e33 100644
--- a/lib/DX/SearchState.pm
+++ b/lib/DX/SearchState.pm
@@ -55,6 +55,7 @@ sub force_backtrack {
   my ($self) = @_;
   my ($first_alt, @rest_alt) = @{$self->alternatives};
   return undef unless $first_alt;
+  trace 'search.backtrack' => $first_alt->[0];
   return ref($self)->new(
     current_hypothesis => $first_alt->[0],
     resume_step => $first_alt->[1],
diff --git a/lib/DX/ShellSession.pm b/lib/DX/ShellSession.pm
index 5cde1d5..a24a106 100644
--- a/lib/DX/ShellSession.pm
+++ b/lib/DX/ShellSession.pm
@@ -73,6 +73,20 @@ has tcl => (is => 'lazy', builder => sub {
       $self->apply_predicate($pred => @args);
     });
   }
+  $tcl->CreateCommand(const => sub {
+    my (undef, undef, undef, $name, $value) = @_;
+    my $tqs = $self->shell_state->template_query_state;
+    my $new_tqs = $tqs->but(
+      globals => $tqs->globals->with_member_at(
+        $name => $self->expand_args($value),
+      ),
+    );
+    $self->_set_shell_state(
+      $self->shell_state->but(
+        template_query_state => $new_tqs
+      ),
+    );
+  });
   return $tcl;
 });
 
@@ -98,6 +112,8 @@ sub eval_command_string {
   my ($self, $string) = @_;
   local our @Result;
   try {
+    no warnings 'redefine';
+    local *DX::Utils::trace = $self->shell_state->trace_sub;
     $self->tcl->Eval($string);
   } catch {
     push @Result, [ output => $_ ];
@@ -117,6 +133,7 @@ sub apply_predicate {
   my ($intro, $need) = ({}, {});
   foreach my $arg (@args) {
     next if ref($arg);
+    next if $arg =~ /^\??[a-z]/; # skip globals
     # ?Foo is intro, Foo is need
     ($arg =~ s/^\?// ? $intro : $need)->{$arg} = 1;
   }
diff --git a/lib/DX/ShellState.pm b/lib/DX/ShellState.pm
index 52a6731..884696a 100644
--- a/lib/DX/ShellState.pm
+++ b/lib/DX/ShellState.pm
@@ -1,5 +1,6 @@
 package DX::ShellState;
 
+use DX::Utils qw(deparse);
 use DX::Class;
 
 has template_query_state => (
@@ -14,6 +15,15 @@ has mode => (is => 'ro', required => 1);
 
 sub new_query_state { $_[0]->template_query_state }
 
+sub trace_sub {
+  sub {
+    my ($tag, $thing) = @_;
+    my $dp = deparse($thing);
+    $dp =~ s/\n$//;
+    warn "${tag}: ${dp}\n";
+  }
+}
+
 sub with_new_query_state {
   my ($self) = @_;
   $self->but(
diff --git a/lib/DX/Step/Normal.pm b/lib/DX/Step/Normal.pm
index 8034c8c..8196461 100644
--- a/lib/DX/Step/Normal.pm
+++ b/lib/DX/Step/Normal.pm
@@ -29,7 +29,11 @@ sub but_with_alternative_step {
 
 sub apply_to {
   my ($self, $old_hyp) = @_;
-  return ($self->_apply_to_hyp($old_hyp), $self->alternative_step);
+  trace 'step.apply.old_hyp '.$self => $old_hyp;
+  my $new_hyp = $self->_apply_to_hyp($old_hyp);
+  return (undef, $self->alternative_step) unless $new_hyp;
+  trace 'step.apply.new_hyp '.$self => $new_hyp;
+  return ($new_hyp, $self->alternative_step);
 }
 
 sub _apply_to_hyp {
diff --git a/lib/DX/Utils.pm b/lib/DX/Utils.pm
index e7e3131..a3384bf 100644
--- a/lib/DX/Utils.pm
+++ b/lib/DX/Utils.pm
@@ -11,7 +11,7 @@ my @const = (
 our @EXPORT_OK = (
   @const,
   (my @builders = qw(step string number dict proposition)),
-  'deparse', 'trace',
+  'deparse', '*trace',
 );
 
 our %EXPORT_TAGS = (
@@ -42,12 +42,7 @@ our $VALUE_EXISTS = 1;
 our @VALUE_EXISTS = (EXISTENCE_OF(), TYPE_OF(), INDICES_OF(), CONTENTS_OF());
 our @VALUE_SET = (TYPE_OF(), INDICES_OF(), CONTENTS_OF());
 
-sub trace {
-  my ($tag, $thing) = @_;
-  my $dp = deparse($thing);
-  $dp =~ s/\n//;
-  warn "${tag}: ${dp}\n";
-}
+sub trace { }
 
 sub step {
   require DX::Step::Normal;