File Coverage

blib/lib/Logic/Basic.pm
Criterion Covered Total %
statement 79 96 82.2
branch 5 6 83.3
condition 7 21 33.3
subroutine 36 47 76.6
pod n/a
total 127 170 74.7


line stmt bran cond sub pod time code
1             package Logic::Basic;
2              
3 7     7   7452 use 5.006001;
  7         27  
  7         270  
4 7     7   41 use strict;
  7         19  
  7         274  
5 7     7   34 no warnings;
  7         13  
  7         265  
6              
7 7     7   34 use Perl6::Attributes;
  7         11  
  7         47  
8              
9              
10             package Logic::Basic::Sequence;
11              
12 7     7   9705 use Carp;
  7         14  
  7         8190  
13              
14             sub new {
15 13     13   61 my ($class, @gens) = @_;
16              
17 13   33     125 bless {
18             gens => \@gens,
19             } => ref $class || $class;
20             }
21              
22             sub generators {
23 0     0   0 my ($self) = @_;
24 0         0 @.gens;
  0         0  
25             }
26              
27             sub create {
28 14     14   17 my ($self) = @_;
29              
30 14         29 $self;
31             }
32              
33             sub enter {
34 14     14   18 my ($self, $stack, $state) = @_;
35              
36 14         14 $stack->descend(@.gens);
  14         51  
37 14         41 1;
38             }
39              
40 10     10   23 sub backtrack { }
41              
42 10     10   19 sub cleanup { }
43              
44              
45             package Logic::Basic::Alternation;
46              
47             sub new {
48 9     9   46 my ($class, @gens) = @_;
49            
50 9   33     80 bless {
51             gens => \@gens,
52             } => ref $class || $class;
53             }
54              
55             sub generators {
56 0     0   0 my ($self) = @_;
57 0         0 @.gens;
  0         0  
58             }
59              
60             sub create {
61 9     9   15 my ($parent) = @_;
62              
63 9         64 my $self = bless {
64             current => undef,
65             index => 0,
66             alternation => $parent,
67             } => ref $parent;
68             }
69              
70             sub enter {
71 30     30   43 my ($self, $stack, $state) = @_;
72              
73 30 100       39 if ($.index < @{$.alternation{gens}}-1) {
  30 50       84  
  7         36  
74 23         81 $stack->descend($.alternation{gens}[$.index]);
75             }
76             elsif ($.index == @{$.alternation{gens}}-1) {
77 7         27 $stack->tail_descend($.alternation{gens}[$.index]);
78             }
79             }
80              
81             sub backtrack {
82 21     21   29 my ($self) = @_;
83              
84 21         34 $.index++;
85 21         26 goto &{$self->can('enter')};
  21         83  
86             }
87              
88 0     0   0 sub cleanup { }
89              
90              
91             package Logic::Basic::Identity;
92              
93             sub new {
94 2     2   20 my ($class) = @_;
95 2         11 $class;
96             }
97              
98             sub create {
99 11     11   18 my ($class) = @_;
100 11   33     79 bless { } => ref $class || $class;
101             }
102              
103             sub enter {
104 11     11   15 my ($self, $stack, $state) = @_;
105 11         46 1;
106             }
107              
108 2     2   4 sub backtrack { }
109 11     11   19 sub cleanup { }
110              
111              
112             package Logic::Basic::Fail;
113              
114             sub new {
115 2     2   3 my ($class) = @_;
116 2         27 $class;
117             }
118              
119             sub create {
120 16     16   29 my ($class) = @_;
121 16   33     87 bless { } => ref $class || $class;
122             }
123              
124 16     16   43 sub enter { }
125 0     0   0 sub backtrack { }
126 16     16   31 sub cleanup { }
127              
128              
129             package Logic::Basic::Assertion;
130              
131             sub new {
132 6     6   13 my ($class, $code) = @_;
133 6   33     64 bless {
134             code => $code,
135             } => ref $class || $class;
136             }
137              
138             sub create {
139 152     152   187 my ($self) = @_;
140 152         265 $self;
141             }
142              
143             sub enter {
144 152     152   167 my ($self, $stack, $state) = @_;
145 152         154 &.code($stack, $state);
  152         322  
146             }
147              
148 20     20   44 sub backtrack { }
149 152     152   214 sub cleanup { }
150              
151              
152             package Logic::Basic::Rule;
153              
154             sub new {
155 2     2   6 my ($class, $code) = @_;
156 2   33     24 bless {
157             code => $code,
158             } => ref $class || $class;
159             }
160              
161             sub create {
162 2     2   4 my ($self) = @_;
163 2         5 $self;
164             }
165              
166             sub enter {
167 2     2   4 my ($self, $stack, $state) = @_;
168 2         4 my $obj = &.code();
  2         7  
169 2 100       13 if ($obj) {
170 1         5 $stack->tail_descend($obj);
171             }
172             }
173              
174 0     0   0 sub backtrack { }
175 1     1   3 sub cleanup { }
176              
177              
178             package Logic::Basic::Bound;
179              
180             sub new {
181 2     2   9 my ($class, $var) = @_;
182 2   33     25 bless {
183             var => $var,
184             } => ref $class || $class;
185             }
186              
187             sub create {
188 2     2   3 my ($self) = @_;
189 2         5 $self;
190             }
191              
192             sub enter {
193 2     2   5 my ($self, $stack, $state) = @_;
194 2         9 $.var->bound($state);
195             }
196              
197 0     0   0 sub backtrack { }
198 1     1   3 sub cleanup { }
199              
200              
201             package Logic::Basic::Block;
202              
203             sub new {
204 0     0     my ($class) = @_;
205 0           $class;
206             }
207              
208             sub create {
209 0     0     my ($self) = @_;
210 0           $self;
211             }
212              
213             sub enter {
214 0     0     1;
215             }
216              
217             sub backtrack {
218 0     0     1;
219             }
220              
221 0     0     sub cleanup { }
222              
223             1;