Commit | Line | Data |
b40e416a |
1 | package DX::RuleSet; |
2 | |
3 | use Moo; |
4 | use DX::Op::CallRule; |
5 | use DX::Op::MemberOf; |
b40e416a |
6 | use DX::Op::ApplyConstraint; |
7 | use DX::Op::Return; |
734376d9 |
8 | use DX::Op::Cut; |
5ef4d923 |
9 | use DX::Op::Observe; |
b40e416a |
10 | use List::Util qw(reduce); |
11 | |
12 | has rules => (is => 'ro', default => sub { {} }); |
13 | |
14 | sub add_rule { |
15 | my ($self, $name, $vars, @body) = @_; |
16 | my $full_name = join('/', $name, scalar @$vars); |
17 | push @{$self->rules->{$full_name}}, $self->_make_rule($vars, @body); |
18 | return $self; |
19 | } |
20 | |
21 | sub _make_rule { |
22 | my ($self, $vars, @body) = @_; |
23 | my $head = reduce { $b->but(next => $a) } |
24 | DX::Op::Return->new, |
25 | reverse map $self->expand(@$_), @body; |
26 | [ $vars, $head ]; |
27 | } |
28 | |
29 | sub expand { |
30 | my ($self, $type, @rest) = @_; |
6d533c9d |
31 | if ($self->can(my $expand_meth = "_expand_${type}")) { |
32 | return $self->$expand_meth(@rest); |
33 | } |
34 | return $self->_expand_call($type, @rest); |
b40e416a |
35 | } |
36 | |
37 | sub _expand_call { |
38 | my ($self, $name, @args) = @_; |
39 | DX::Op::CallRule->new(rule_name => $name, rule_args => \@args); |
40 | } |
41 | |
734376d9 |
42 | sub _expand_cut { return DX::Op::Cut->new } |
43 | |
b40e416a |
44 | sub _expand_member_of { |
385fa954 |
45 | my ($self, $member_var, $coll_var) = @_; |
b40e416a |
46 | DX::Op::MemberOf->new( |
47 | member_var => $member_var, |
385fa954 |
48 | coll_var => $coll_var, |
b40e416a |
49 | ); |
50 | } |
51 | |
b40e416a |
52 | sub _expand_constrain { |
53 | my ($self, $vars, $constraint) = @_; |
54 | DX::Op::ApplyConstraint->new( |
55 | vars => $vars, |
56 | constraint => $constraint |
57 | ); |
58 | } |
59 | |
5ef4d923 |
60 | sub _expand_observe { |
61 | my ($self, $vars, $builder) = @_; |
62 | DX::Op::Observe->new( |
63 | vars => $vars, |
64 | builder => $builder, |
65 | ); |
66 | } |
67 | |
b40e416a |
68 | 1; |