Commit | Line | Data |
b40e416a |
1 | package DX::RuleSet; |
2 | |
3 | use Moo; |
02ae4168 |
4 | use DX::Op::SetupScope; |
b40e416a |
5 | use DX::Op::CallRule; |
6 | use DX::Op::MemberOf; |
b40e416a |
7 | use DX::Op::ApplyConstraint; |
8 | use DX::Op::Return; |
734376d9 |
9 | use DX::Op::Cut; |
71217e42 |
10 | use DX::Op::Backtrack; |
5ef4d923 |
11 | use DX::Op::Observe; |
71217e42 |
12 | use DX::Op::Not; |
13 | use DX::Op::ProposeAction; |
2c467394 |
14 | use DX::Op::ModifyAction; |
71217e42 |
15 | use DX::Op::Materialize; |
896fd92e |
16 | use DX::Op::Prop; |
859049a3 |
17 | use DX::Op::Exists; |
37e9670d |
18 | use DX::Op::Predicate; |
577a2146 |
19 | use DX::Op::HasAction; |
138613a8 |
20 | use DX::Op::FindAll; |
f5a02c91 |
21 | use DX::Op::ForEach; |
b40e416a |
22 | use List::Util qw(reduce); |
23 | |
24 | has rules => (is => 'ro', default => sub { {} }); |
25 | |
37e9670d |
26 | sub add_predicate { |
27 | my ($self, $name, $vars, @cases) = @_; |
28 | my $full_name = join('/', $name, scalar @$vars); |
29 | push @{$self->rules->{$full_name}}, DX::Op::Predicate->new( |
30 | arg_names => $vars, arg_cases => \@cases |
31 | ); |
32 | } |
33 | |
b40e416a |
34 | sub add_rule { |
35 | my ($self, $name, $vars, @body) = @_; |
36 | my $full_name = join('/', $name, scalar @$vars); |
37 | push @{$self->rules->{$full_name}}, $self->_make_rule($vars, @body); |
38 | return $self; |
39 | } |
40 | |
41 | sub _make_rule { |
42 | my ($self, $vars, @body) = @_; |
deec7cc4 |
43 | my $head = $self->expand_and_link(DX::Op::Return->new, @body); |
02ae4168 |
44 | DX::Op::SetupScope->new(arg_names => $vars, next => $head); |
b40e416a |
45 | } |
46 | |
deec7cc4 |
47 | sub expand_and_link { |
71217e42 |
48 | my ($self, $last, @body) = @_; |
49 | return reduce { $b->but(next => $a) } |
50 | $last, |
deec7cc4 |
51 | reverse map $self->expand($_), @body; |
71217e42 |
52 | } |
53 | |
b40e416a |
54 | sub expand { |
deec7cc4 |
55 | my ($self, $thing) = @_; |
56 | if (ref($thing) eq 'ARRAY') { |
57 | my ($type, @rest) = @$thing; |
58 | if ($self->can(my $expand_meth = "_expand_op_${type}")) { |
59 | return $self->$expand_meth(@rest); |
60 | } |
61 | return $self->_expand_call(@$thing); |
6d533c9d |
62 | } |
deec7cc4 |
63 | return $thing; |
b40e416a |
64 | } |
65 | |
66 | sub _expand_call { |
67 | my ($self, $name, @args) = @_; |
68 | DX::Op::CallRule->new(rule_name => $name, rule_args => \@args); |
69 | } |
70 | |
71217e42 |
71 | sub _expand_op_cut { return DX::Op::Cut->new } |
734376d9 |
72 | |
71217e42 |
73 | sub _expand_op_fail { return DX::Op::Backtrack->new } |
74 | |
75 | sub _expand_op_not { |
76 | my ($self, @contents) = @_; |
77 | my $cut = DX::Op::Cut->new(next => DX::Op::Backtrack->new); |
78 | DX::Op::Not->new( |
deec7cc4 |
79 | body => $self->expand_and_link($cut, @contents) |
71217e42 |
80 | ); |
81 | } |
82 | |
138613a8 |
83 | sub _expand_op_findall { |
84 | my ($self, $coll_name, $var_name, @contents) = @_; |
f5a02c91 |
85 | DX::Op::FindAll->new( |
138613a8 |
86 | coll_name => $coll_name, |
87 | var_name => $var_name, |
88 | body => $self->expand_and_link(DX::Op::Return->new, @contents), |
89 | ); |
90 | } |
91 | |
f5a02c91 |
92 | sub _expand_op_foreach { |
93 | my ($self, $var_name, $body, $each_body) = @_; |
94 | DX::Op::ForEach->new( |
95 | var_name => $var_name, |
96 | body => $self->expand_and_link(DX::Op::Return->new, @$body), |
97 | each_body => $self->expand_and_link(DX::Op::Return->new, @$each_body), |
98 | ); |
99 | } |
100 | |
71217e42 |
101 | sub _expand_op_member_of { |
385fa954 |
102 | my ($self, $member_var, $coll_var) = @_; |
b40e416a |
103 | DX::Op::MemberOf->new( |
104 | member_var => $member_var, |
385fa954 |
105 | coll_var => $coll_var, |
b40e416a |
106 | ); |
107 | } |
108 | |
71217e42 |
109 | sub _expand_op_constrain { |
b40e416a |
110 | my ($self, $vars, $constraint) = @_; |
111 | DX::Op::ApplyConstraint->new( |
112 | vars => $vars, |
113 | constraint => $constraint |
114 | ); |
115 | } |
116 | |
71217e42 |
117 | sub _expand_op_observe { |
5ef4d923 |
118 | my ($self, $vars, $builder) = @_; |
119 | DX::Op::Observe->new( |
120 | vars => $vars, |
121 | builder => $builder, |
122 | ); |
123 | } |
124 | |
71217e42 |
125 | sub _expand_op_act { |
126 | my ($self, $vars, $builder) = @_; |
127 | DX::Op::ProposeAction->new( |
128 | vars => $vars, |
129 | builder => $builder, |
130 | ); |
131 | } |
132 | |
2c467394 |
133 | sub _expand_op_react { |
134 | my ($self, $vars, $builder) = @_; |
135 | DX::Op::ModifyAction->new( |
136 | vars => $vars, |
137 | builder => $builder, |
138 | ); |
139 | } |
140 | |
71217e42 |
141 | sub _expand_op_materialize { |
142 | my ($self, $var_name) = @_; |
143 | DX::Op::Materialize->new(var_name => $var_name); |
144 | } |
145 | |
896fd92e |
146 | sub _expand_op_prop { |
147 | my ($self, @args) = @_; |
148 | my %new; @new{qw(of name value)} = @args; |
149 | DX::Op::Prop->new(%new); |
150 | } |
151 | |
859049a3 |
152 | sub _expand_op_exists { |
153 | my ($self, $vars, @body) = @_; |
154 | DX::Op::Exists->new( |
155 | vars => $vars, |
deec7cc4 |
156 | body => $self->expand_and_link(DX::Op::Return->new, @body) |
859049a3 |
157 | ); |
158 | } |
159 | |
577a2146 |
160 | sub _expand_op_has_action { |
161 | my ($self, @args) = @_; |
162 | DX::Op::HasAction->new(arg_spec => \@args); |
163 | } |
164 | |
b40e416a |
165 | 1; |