From: Matt S Trout <mst@shadowcat.co.uk>
Date: Fri, 4 Dec 2015 15:54:24 +0000 (+0000)
Subject: types and deparsing and recalculation part working
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3e465d5d72227913b2aeaffb5576b61af781e0e9;p=scpubgit%2FDX.git

types and deparsing and recalculation part working
---

diff --git a/lib/DX/ActionPolicy/Allow.pm b/lib/DX/ActionPolicy/Allow.pm
new file mode 100644
index 0000000..84965a0
--- /dev/null
+++ b/lib/DX/ActionPolicy/Allow.pm
@@ -0,0 +1,9 @@
+package DX::ActionPolicy::Allow;
+
+use DX::Class;
+
+with 'DX::Role::ActionPolicy';
+
+sub allows { 1 }
+
+1;
diff --git a/lib/DX/ActionPolicy/LockScope.pm b/lib/DX/ActionPolicy/LockScope.pm
new file mode 100644
index 0000000..caa8b96
--- /dev/null
+++ b/lib/DX/ActionPolicy/LockScope.pm
@@ -0,0 +1,18 @@
+package DX::ActionPolicy::LockScope;
+
+use DX::Class;
+
+with 'DX::Role::ActionPolicy';
+
+has lock_to_depth => (is => 'ro', required => 1);
+
+has next_policy => (is => 'ro', required => 1);
+
+sub allows {
+  my ($self, $action) = @_;
+  my $first = $action->target_path->[0];
+  return 0 unless $first =~ /^(\d+)$/ and $first > $self->lock_to_depth;
+  return $self->next_policy->allows($action);
+}
+
+1;
diff --git a/lib/DX/Class.pm b/lib/DX/Class.pm
index 730069a..cc51cd4 100644
--- a/lib/DX/Class.pm
+++ b/lib/DX/Class.pm
@@ -4,6 +4,7 @@ use Import::Into;
 
 sub import {
   strictures->import::into(1); # should pass version
+  DX::Types->import::into(1, ':types', ':assert');
   Moo->import::into(1);
   # This would not be safe with method modifiers, but since the role
   # provides only a single method it works out fine.
diff --git a/lib/DX/DependencyMap.pm b/lib/DX/DependencyMap.pm
index 1d58d1a..3a15193 100644
--- a/lib/DX/DependencyMap.pm
+++ b/lib/DX/DependencyMap.pm
@@ -1,13 +1,13 @@
 package DX::DependencyMap;
 
 use DX::Utils qw(CONTENTS_OF INDICES_OF);
-use Moo;
+use DX::Class;
 
 # { x => [ { y => [ ...
 # my $targ = $root; $targ = $targ->[0]{$_[0]} for @path
 # my $deps = $targ->[$${$dep_type}];
 
-has deps => (is => 'ro', required => 1);
+has deps => (is => 'ro', isa => DependencyTree, required => 1);
 
 has revdeps => (is => 'ro', required => 1);
 
@@ -64,6 +64,7 @@ sub _mangle_deps {
   my ($self, $deps, $mangler, @to_mangle) = @_;
   my $root = [ $deps ];
   foreach my $mangle_this (@to_mangle) {
+    assert_DependencySpec $mangle_this;
     my ($type, @path) = @$mangle_this;
     my $targ = $root;
     foreach my $part (@path) {
@@ -78,6 +79,7 @@ sub _mangle_deps {
 sub _expand_deps {
   my ($self, $deps) = @_;
   my @exp;
+  assert_DependencyGroupList $deps;
   DEP: foreach my $dep (map @{$_}[1..$#$_], @$deps) {
     my ($type, @path) = @$dep;
     push @exp, [
@@ -132,4 +134,6 @@ sub but_expire_dependents_of {
   ($self->without_entries_for(@expired), @expired);
 }
 
+sub dependencies_for { $_[0]->revdeps->{$_[1]} }
+
 1;
diff --git a/lib/DX/Hypothesis.pm b/lib/DX/Hypothesis.pm
index 61993c5..0cf02c6 100644
--- a/lib/DX/Hypothesis.pm
+++ b/lib/DX/Hypothesis.pm
@@ -1,14 +1,24 @@
 package DX::Hypothesis;
 
+use DX::ActionPolicy::LockScope;
+use Types::Standard qw(ArrayRef);
 use DX::Class;
 
-has scope => (is => 'ro', required => 1);
+has scope => (is => 'ro', isa => Scope, required => 1);
 
-has resolved_propositions => (is => 'ro', required => 1);
+has resolved_propositions => (
+  is => 'ro', isa => ResolvedPropositionSet, required => 1
+);
 
-has outstanding_propositions => (is => 'ro', required => 1);
+has outstanding_propositions => (
+  is => 'ro', isa => ArrayRef[Proposition], required => 1
+);
 
-has actions => (is => 'ro', required => 1);
+has actions => (
+  is => 'ro', isa => ArrayRef[Action], required => 1
+);
+
+has action_policy => (is => 'ro', isa => ActionPolicy, required => 1);
 
 sub head_proposition { shift->outstanding_propositions->[0] }
 
@@ -16,6 +26,7 @@ sub with_actions {
   my ($self, @actions) = @_;
   my $hyp = $self;
   foreach my $act (@actions) {
+    return undef unless $self->action_policy->allows($act);
     ($hyp, my @events) = $act->dry_run($hyp);
     return undef unless $hyp;
     $hyp = $hyp->but_recheck_for(@events);
@@ -28,9 +39,37 @@ sub but_recheck_for {
   my ($self, @events) = @_;
   my ($still_resolved, @recheck) = $self->resolved_propositions
                                         ->but_expire_for(@events);
-  my $hyp = $self->but(resolved_propositions => $still_resolved);
-  $hyp = $_->but_recheck_against($hyp) or return undef for @recheck;
-  return $hyp;
+  return $self unless @recheck;
+
+  my $ap = DX::ActionPolicy::LockScope->new(
+    lock_to_depth => $self->scope->depth,
+    next_policy => $self->action_policy,
+  );
+
+  # we should probably be doing something about pruning the scope
+  # but that's completely pointless until we have rules
+
+  my $hyp = ref($self)->new(
+    scope => $self->scope,
+    resolved_propositions => DX::ResolvedPropositionSet->new_empty,
+    outstanding_propositions => \@recheck,
+    actions => [],
+    action_policy => $ap,
+  );
+
+  my $ss = DX::SearchState->new_for($hyp);
+
+  return undef unless my $sol_ss = $ss->find_solution;
+
+  my $sol_rps = $sol_ss->current_hypothesis->resolved_propositions;
+
+  my $rps = $still_resolved;
+
+  $rps = $rps->with_updated_dependencies_for(
+    $_, $sol_rps->dependencies_for($_)
+  ) for @recheck;
+
+  return $self->but(resolved_propositions => $rps);
 }
 
 sub resolve_head_dependent_on {
diff --git a/lib/DX/ResolvedPropositionSet.pm b/lib/DX/ResolvedPropositionSet.pm
index ff37b41..af12e5b 100644
--- a/lib/DX/ResolvedPropositionSet.pm
+++ b/lib/DX/ResolvedPropositionSet.pm
@@ -1,11 +1,12 @@
 package DX::ResolvedPropositionSet;
 
 use DX::DependencyMap;
-use Moo;
+use Types::Standard qw(ArrayRef);
+use DX::Class;
 
-has dependency_map => (is => 'ro', required => 1);
+has dependency_map => (is => 'ro', isa => DependencyMap, required => 1);
 
-has propositions => (is => 'ro', required => 1);
+has propositions => (is => 'ro', isa => ArrayRef[Proposition], required => 1);
 
 has scope_depth => (is => 'ro', required => 1);
 
@@ -34,7 +35,8 @@ sub with_updated_dependencies_for {
   my ($self, $prop, $deps) = @_;
   my @props = @{$self->propositions};
   my ($id) = grep $props[$_] eq $prop, 0..$#props;
-  die "WHUT" unless $id;
+  # 0 is valid, undef means the grep failed
+  die "Unable to find $prop in proplist" unless defined $id;
   my $new_depmap = $self->dependency_map
                         ->with_entry_for($id, $deps);
   ref($self)->new(
@@ -50,8 +52,20 @@ sub but_expire_for {
                                     ->but_expire_dependents_of(@events);
   # Didn't expire anything? Don't clone self
   return $self if $depmap eq $self->dependency_map;
-  die 'WHUT';
+  my $props = $self->propositions;
+  return (
+    $self->but(dependency_map => $depmap),
+    map $props->[$_], @expired_ids
+  );
 }
 
+sub dependencies_for {
+  my ($self, $prop) = @_;
+  my @props = @{$self->propositions};
+  my ($id) = grep $props[$_] eq $prop, 0..$#props;
+  # 0 is valid, undef means the grep failed
+  die "Unable to find $prop in proplist" unless defined $id;
+  return $self->dependency_map->dependencies_for($id);
+}
 
 1;
diff --git a/lib/DX/Role.pm b/lib/DX/Role.pm
index f662316..045c8a2 100644
--- a/lib/DX/Role.pm
+++ b/lib/DX/Role.pm
@@ -4,6 +4,7 @@ use Import::Into;
 
 sub import {
   strictures->import::into(1);
+  DX::Types->import::into(1, ':types', ':assert');
   Moo::Role->import::into(1);
 }
 
diff --git a/lib/DX/Role/Action.pm b/lib/DX/Role/Action.pm
new file mode 100644
index 0000000..4d71f62
--- /dev/null
+++ b/lib/DX/Role/Action.pm
@@ -0,0 +1,9 @@
+package DX::Role::Action;
+
+use DX::Role;
+
+requires 'dry_run';
+
+requires 'run';
+
+1;
diff --git a/lib/DX/Role/ActionPolicy.pm b/lib/DX/Role/ActionPolicy.pm
new file mode 100644
index 0000000..bf977b0
--- /dev/null
+++ b/lib/DX/Role/ActionPolicy.pm
@@ -0,0 +1,7 @@
+package DX::Role::ActionPolicy;
+
+use DX::Role;
+
+requires 'allows';
+
+1;
diff --git a/lib/DX/Role/Predicate.pm b/lib/DX/Role/Predicate.pm
index b1c8181..2a94ade 100644
--- a/lib/DX/Role/Predicate.pm
+++ b/lib/DX/Role/Predicate.pm
@@ -1,7 +1,7 @@
 package DX::Role::Predicate;
 
 use List::Util qw(reduce);
-use DX::Utils qw(step);
+use DX::Utils qw(step CONTENTS_OF);
 use DX::Role;
 
 sub resolution_step_for {
@@ -18,7 +18,9 @@ sub _make_equal {
   if ($left->equals($right)) {
     return step(
       actions => [],
-      depends_on => [ [ undef ,=> [ $left, $right ] ] ],
+      depends_on => [
+        [ undef ,=> [ CONTENTS_OF ,=> $left ], [ CONTENTS_OF ,=> $right ] ]
+      ],
     );
   }
   return (
@@ -28,7 +30,7 @@ sub _make_equal {
           actions => [ $set ],
           depends_on => [
             [ $right =>
-              [ $left ], [ $right ]
+              [ CONTENTS_OF ,=> $left ], [ CONTENTS_OF ,=> $right ]
             ]
           ]
         )
@@ -42,7 +44,7 @@ sub _make_equal {
           actions => [ $set ],
           depends_on => [
             [ $left =>
-              [ $left ], [ $right ]
+              [ CONTENTS_OF ,=> $left ], [ CONTENTS_OF ,=> $right ]
             ]
           ]
         )
diff --git a/lib/DX/Role/SimpleAction.pm b/lib/DX/Role/SimpleAction.pm
index f4b1d76..f0b3120 100644
--- a/lib/DX/Role/SimpleAction.pm
+++ b/lib/DX/Role/SimpleAction.pm
@@ -2,6 +2,8 @@ package DX::Role::SimpleAction;
 
 use DX::Role;
 
+with 'DX::Role::Action';
+
 has target_path => (is => 'ro', required => 1);
 
 has _updates => (is => 'lazy');
diff --git a/lib/DX/Role/Step.pm b/lib/DX/Role/Step.pm
new file mode 100644
index 0000000..4c36391
--- /dev/null
+++ b/lib/DX/Role/Step.pm
@@ -0,0 +1,5 @@
+package DX::Role::Step;
+
+use DX::Role;
+
+1;
diff --git a/lib/DX/Scope.pm b/lib/DX/Scope.pm
index b41a5ce..76bda01 100644
--- a/lib/DX/Scope.pm
+++ b/lib/DX/Scope.pm
@@ -1,12 +1,13 @@
 package DX::Scope;
 
+use Types::Standard qw(HashRef ArrayRef);
 use DX::Class;
 
-has predicates => (is => 'ro', required => 1);
+has predicates => (is => 'ro', isa => HashRef[Predicate], required => 1);
 
-has globals => (is => 'ro', required => 1);
+has globals => (is => 'ro', isa => DictValue, required => 1);
 
-has locals => (is => 'ro', required => 1);
+has locals => (is => 'ro', isa => ArrayRef[DictValue], required => 1);
 
 #has known_facts => (is => 'ro', required => 1);
 
diff --git a/lib/DX/SearchState.pm b/lib/DX/SearchState.pm
index 6e9954f..c339382 100644
--- a/lib/DX/SearchState.pm
+++ b/lib/DX/SearchState.pm
@@ -2,11 +2,19 @@ package DX::SearchState;
 
 use DX::Class;
 
-has current_hypothesis => (is => 'ro', required => 1);
+has current_hypothesis => (is => 'ro', isa => Hypothesis, required => 1);
 
-has resume_step => (is => 'ro');
+has resume_step => (is => 'ro', isa => Step);
 
-has alternatives => (is => 'ro', required => 1);
+has alternatives => (is => 'ro', isa => AlternativeList, required => 1);
+
+sub new_for {
+  my ($class, $hyp) = @_;
+  $class->new(
+    current_hypothesis => $hyp,
+    alternatives => [],
+  );
+}
 
 sub with_one_step {
   my ($self) = @_;
diff --git a/lib/DX/Step/Normal.pm b/lib/DX/Step/Normal.pm
index 6a1e589..11890ca 100644
--- a/lib/DX/Step/Normal.pm
+++ b/lib/DX/Step/Normal.pm
@@ -1,12 +1,15 @@
 package DX::Step::Normal;
 
+use Types::Standard qw(ArrayRef);
 use DX::Class;
 
-has actions => (is => 'ro', required => 1);
+with 'DX::Role::Step';
 
-has depends_on => (is => 'ro', required => 1);
+has actions => (is => 'ro', isa => ArrayRef[Action], required => 1);
 
-has alternative_step => (is => 'ro');
+has depends_on => (is => 'ro', isa => DependencyGroupList, required => 1);
+
+has alternative_step => (is => 'ro', isa => Step);
 
 sub but_with_dependencies_on {
   my ($self, @deps) = @_;
@@ -20,6 +23,7 @@ sub but_with_alternative_step {
 
 sub apply_to {
   my ($self, $old_hyp) = @_;
+#::Dwarn($self->depends_on);
   return ($self->_apply_to_hyp($old_hyp), $self->alternative_step);
 }
 
diff --git a/lib/DX/Types.pm b/lib/DX/Types.pm
new file mode 100644
index 0000000..729fa60
--- /dev/null
+++ b/lib/DX/Types.pm
@@ -0,0 +1,71 @@
+package DX::Types;
+
+use strictures 2;
+use Type::Library
+  -base,
+  -declare => (
+    (our @CLASSES = qw(
+      Hypothesis Scope ResolvedPropositionSet Proposition DependencyMap
+    )),
+    (our @ROLES = qw(
+      Step Action ActionPolicy Predicate Value
+    )),
+    qw(
+      DependencyType _DependencyTree DependecySpec
+      One DependencyGroupEntry DependencyGroup
+    ),
+  )
+;
+use Type::Utils -all;
+use Types::Standard qw(
+  ArrayRef Tuple HashRef Dict Maybe Optional slurpy Str
+);
+use DX::Utils qw(:event_types :dep_types);
+
+foreach my $class (our @CLASSES) {
+  class_type $class => { class => 'DX::'.$class };
+}
+
+foreach my $role (our @ROLES) {
+  role_type $role => { role => 'DX::Role::'.$role };
+}
+
+class_type DictValue => { class => 'DX::Value::Dict' };
+
+declare AlternativeList => as ArrayRef[Tuple[Hypothesis, Step]];
+
+declare DependencyType => where {
+  foreach my $cand (EXISTENCE_OF, INDICES_OF, TYPE_OF, CONTENTS_OF) {
+    return 1 if $_ eq $cand;
+  }
+  return 0;
+};
+
+declare EventType => where {
+  foreach my $cand (VALUE_SET, VALUE_EXISTS) {
+    return 1 if $_ eq $cand;
+  }
+  return 0;
+};
+
+declare _DependencyTree => where { is_DependencyTree($_) };
+
+declare DependencySpec => as Tuple[DependencyType, slurpy ArrayRef[Str]];
+
+declare One => where { !ref($_) and $_ eq 1 };
+
+declare DependencyTree => # [ \%subtree, \%existence_of, ... ]
+  as HashRef[Tuple[
+       Maybe[_DependencyTree],
+       (Optional[Maybe[HashRef[One]]]) x 4
+     ]];
+
+declare DependencyGroupEntry =>
+  as Tuple[DependencyType, slurpy ArrayRef[Value|Str]];
+
+declare DependencyGroup =>
+  as Tuple[Maybe[Value], slurpy ArrayRef[DependencyGroupEntry]];
+
+declare DependencyGroupList => as ArrayRef[DependencyGroup];
+
+1;
diff --git a/lib/DX/Utils.pm b/lib/DX/Utils.pm
index 89f2fdd..9c89107 100644
--- a/lib/DX/Utils.pm
+++ b/lib/DX/Utils.pm
@@ -43,18 +43,22 @@ our @VALUE_EXISTS = (EXISTENCE_OF(), INDICES_OF(), TYPE_OF(), CONTENTS_OF());
 our @VALUE_SET = (INDICES_OF(), TYPE_OF(), CONTENTS_OF());
 
 sub step {
+  require DX::Step::Normal;
   DX::Step::Normal->new(@_);
 }
 
 sub string {
+  require DX::Value::String;
   DX::Value::String->new(string_value => $_[0])
 }
 
 sub number {
+  require DX::Value::Number;
   DX::Value::Number->new(number_value => $_[0]);
 }
 
 sub dict {
+  require DX::Value::Dict;
   DX::Value::Dict->new(
     members => { @_ },
   );
@@ -62,6 +66,7 @@ sub dict {
 
 sub proposition {
   my ($pred, @args) = @_;
+  require DX::Proposition;
   DX::Proposition->new(
     predicate => $pred,
     args => \@args,
@@ -69,21 +74,16 @@ sub proposition {
 }
 
 {
-  require DX::Deparse;
-  my $dp = DX::Deparse->new;
+  my $dp;
 
   sub deparse {
+    $dp ||= do {
+      require DX::Deparse;
+      DX::Deparse->new;
+    };
     my ($thing) = @_;
     $dp->fmt($thing);
   }
 }
 
-# Here so that circular require doesn't stab us in the face
-
-require DX::Step::Normal;
-require DX::Value::String;
-require DX::Value::Number;
-require DX::Value::Dict;
-require DX::Proposition;
-
 1;
diff --git a/t/01basics.t b/t/01basics.t
index 2c6c307..fa69c59 100644
--- a/t/01basics.t
+++ b/t/01basics.t
@@ -9,7 +9,7 @@ my $ab = use_module('DX::ActionBuilder::UnsetValue')->new(
 
 my $scope = use_module('DX::Scope')->new(
   predicates => {
-    '=' => use_module('DX::Predicate::Equals')->new,
+    'eq' => use_module('DX::Predicate::Equals')->new,
     member_at => use_module('DX::Predicate::MemberAt')->new,
     is_dict => use_module('DX::Predicate::IsDict')->new,
   },
@@ -30,9 +30,11 @@ my $hyp = use_module('DX::Hypothesis')->new(
   outstanding_propositions => [
     proposition(is_dict => 'X'),
     proposition(member_at => 'X', string('a'), string('b')),
-    proposition(member_at => 'X', string('a'), string('b')),
+    #proposition(member_at => 'X', string('a'), string('c')),
+    proposition(eq => 'X', dict(a => string('b'), c => string('d'))),
   ],
   actions => [],
+  action_policy => use_module('DX::ActionPolicy::Allow')->new
 );
 
 my $ss = use_module('DX::SearchState')->new(
@@ -41,4 +43,6 @@ my $ss = use_module('DX::SearchState')->new(
 );
 
 #::Dwarn($ss->with_one_step->with_one_step);
-warn deparse($ss->with_one_step->with_one_step->with_one_step);
+warn deparse(my $f = $ss->with_one_step->with_one_step->with_one_step);
+
+::Dwarn($f->current_hypothesis->resolved_propositions->dependency_map);