File Coverage

blib/lib/Ordeal/Model/Parser.pm
Criterion Covered Total %
statement 230 281 81.8
branch 34 64 53.1
condition 3 11 27.2
subroutine 57 63 90.4
pod 1 1 100.0
total 325 420 77.3


line stmt bran cond sub pod time code
1             package Ordeal::Model::Parser;
2              
3             # vim: ts=3 sts=3 sw=3 et ai :
4              
5 6     6   112 use 5.020;
  6         118  
6 6     6   34 use strict; # redundant, but still useful to document
  6         11  
  6         120  
7 6     6   33 use warnings;
  6         12  
  6         250  
8             { our $VERSION = '0.004'; }
9 6     6   93 use Ouch;
  6         14  
  6         36  
10              
11 6     6   440 use constant SHOW_CHARS => 20;
  6         22  
  6         368  
12 6     6   34 use constant ELLIPSIS => '...';
  6         11  
  6         335  
13              
14 6     6   40 use experimental qw< signatures postderef >;
  6         12  
  6         35  
15 6     6   1048 no warnings qw< experimental::signatures experimental::postderef >;
  6         12  
  6         263  
16              
17 6     6   44 use Exporter qw< import >;
  6         21  
  6         22920  
18             our @EXPORT_OK = qw< PARSE >;
19              
20 2     2 1 4 sub PARSE ($text) {
  2         4  
  2         4  
21 2         7 state $expression = _expression();
22 2         5 my $ast = $expression->(\$text);
23 2         5 my $pos = pos $text;
24 2         13 my ($blanks, $rest) = substr($text, $pos) =~ m{\A (\s*) (.*) }mxs;
25 2 50       7 if (length $rest) {
26 0   0     0 $pos += length($blanks // '');
27 0         0 my $prest = $rest;
28 0 0       0 $prest = length($rest) > SHOW_CHARS
29             ? (substr($rest, 0, SHOW_CHARS - length ELLIPSIS) . ELLIPSIS)
30             : $rest;
31 0         0 ouch 400, "unknown sequence starting at $pos '$prest'", $rest;
32             }
33 2         8 return $ast;
34             }
35              
36             ########################################################################
37             # Generic parsing facilities
38              
39 6     6   8 sub __alternator (@alternatives) {
  6         11  
  6         8  
40 22     22   27 return sub ($rtext) {
  22         29  
  22         29  
41 22         43 __ews($rtext);
42 22         44 for my $alt (@alternatives) {
43 46 100       77 next unless defined(my $retval = $alt->($rtext));
44 12         38 return $retval;
45             }
46 10         29 return;
47 6         26 };
48             }
49              
50 78     78   101 sub __ews ($rtext) { return __ewsr()->($rtext) }
  78         102  
  78         87  
  78         126  
51 78     78   123 sub __ewsr { state $retval = __regexper(qr{\s+}) }
52              
53 7     7   11 sub __exact ($what, @retval) {
  7         12  
  7         10  
  7         9  
54 7         10 my $wlen = length $what;
55 30     30   37 return sub ($rtext) {
  30         35  
  30         42  
56 30   100     67 my $pos = pos($$rtext) // 0;
57 30 100       66 return if length($$rtext) - $pos < $wlen;
58 22 100       66 return if substr($$rtext, $pos, $wlen) ne $what;
59 8         16 pos($$rtext) = $pos + $wlen;
60 8         24 return [@retval];
61 7         32 };
62             }
63              
64 1     1   2 sub __lister ($what, $sep = undef) {
  1         3  
  1         2  
  1         2  
65 1 50 33     15 $sep = __exact($sep) if defined($sep) && ! ref($sep);
66 2     2   4 return sub ($rtext) {
  2         3  
  2         3  
67 2         6 __ews($rtext);
68 2 50       5 defined(my $base = $what->($rtext)) or return;
69             my $rest = __starer(
70 2         4 sub ($rtext) {
71 2 50       5 if ($sep) {
72 2         21 __ews($rtext);
73 2 50       6 $sep->($rtext) or return; # check & discard
74             }
75 0         0 __ews($rtext);
76 0         0 $what->($rtext);
77             }
78 2         12 )->($rtext);
79 2 50       23 $sep->($rtext) if $sep; # optional ending
80 2         5 unshift $rest->@*, $base;
81 2         6 return $rest;
82 1         8 };
83             }
84              
85 7     7   13 sub __regexper ($rx) {
  7         25  
  7         10  
86 96     96   116 return sub ($rtext) {
  96         117  
  96         119  
87 96 100       950 my (undef, $retval) = $$rtext =~ m{\G()$rx}cgmxs or return;
88 4         19 return [$retval];
89 7         53 };
90             }
91              
92             sub __resolver { # probably unneeded
93 0     0   0 state $retval = sub ($what) {
  0         0  
  0         0  
94 0 0       0 return $what if ref $what;
95 0         0 return __PACKAGE__->can($what);
96 0     0   0 };
97             }
98              
99 9     9   13 sub __sequencer (@items) {
  9         17  
  9         13  
100 26     26   31 return sub ($rtext) {
  26         30  
  26         35  
101 26         39 my $pos = pos $$rtext;
102 26         34 my @retval;
103 26         46 for my $item (@items) {
104 38         63 my $ews = __ews($rtext);
105 38 100       88 $item = __exact($item) unless ref $item;
106 38 100       65 if (defined(my $piece = $item->($rtext))) {
107 20         61 push @retval, $piece;
108             }
109             else { # fail
110 18         44 pos($$rtext) = $pos;
111 18         80 return;
112             }
113             }
114 8         27 return \@retval;
115 9         54 };
116             }
117              
118 6     6   10 sub __starer ($what, $min = 0) {
  6         9  
  6         8  
  6         9  
119 10     10   13 return sub ($rtext) {
  10         12  
  10         15  
120 10         19 my $pos = pos $$rtext;
121 10         17 my @retval;
122 10         13 my $local_min = $min;
123 10         14 while ('possible') {
124 14         30 __ews($rtext);
125 14 100       32 defined(my $piece = $what->($rtext)) or last;
126 4         9 push @retval, $piece;
127 4 50       8 if ($local_min > 0) {
128 0         0 --$local_min;
129             }
130             else {
131 4         8 $pos = pos $$rtext;
132             }
133             }
134 10         21 pos($$rtext) = $pos; # "undo" last try/tries
135 10 50       24 return if $local_min > 0; # failed to match at least $min
136 10         25 return \@retval;
137 6         35 };
138             }
139              
140             ########################################################################
141             # Specific grammar
142              
143             sub _addend {
144 2     2   5 state $r = sub ($rtext) {
  2         4  
  2         4  
145 2         7 state $op = __regexper(qr{([*x])});
146 2         6 state $seq = __sequencer(
147             __starer(__sequencer(_positive_int(), $op)),
148             _atom(),
149             __starer(__sequencer($op, _positive_int())),
150             );
151 2 50       6 my $match = $seq->($rtext) or return;
152 2         5 my ($pre, $retval, $post) = $match->@*;
153 2         5 $retval = ___mult($retval, reverse($_->@*)) for reverse($pre->@*);
154 2         5 $retval = ___mult($retval, ($_->@*)) for ($post->@*);
155 2         5 return $retval;
156             }
157 1     1   7 }
158              
159             sub _atom {
160 1     1   3 state $base = _atom_base();
161 1         5 state $unaries = __starer(_atom_unary());
162 2     2   2 state $retval = sub ($rtext) {
  2         4  
  2         3  
163 2 50       5 my $retval = $base->($rtext) or return;
164 2         5 for my $unary ($unaries->($rtext)->@*) {
165 4         11 my ($op, @rest) = $unary->@*;
166 4         23 $retval = [$op, $retval, @rest];
167             }
168 2         8 return $retval;
169 1         5 };
170             }
171              
172             sub _atom_base {
173 0     0   0 state $sub_expression = sub ($rtext) {
  0         0  
  0         0  
174 0         0 state $seq = __sequencer('(', _expression(), ')');
175 0 0       0 my $match = $seq->($rtext) or return;
176 0         0 return $match->[1];
177 1     1   5 };
178 1         4 state $retval = __alternator(
179             _identifier(),
180             $sub_expression,
181             );
182             }
183              
184             sub _atom_unary {
185 1     1   4 state $r = __alternator(_sslicer(), _slicer(), _sorter(), _shuffler());
186             }
187              
188             sub _expression {
189 2     2   5 state $r = sub ($rtext) {
  2         2  
  2         4  
190 2         6 state $addend = _addend();
191 2         7 state $seq = __sequencer(
192             $addend,
193             __starer(__sequencer(__regexper(qr{([-+])}), $addend)),
194             );
195 2         6 state $name_for = {'+' => 'sum', '-' => 'subtract'};
196 2 50       6 my $match = $seq->($rtext) or return;
197 2         5 my ($retval, $transformations) = $match->@*;
198 2         4 for my $t ($transformations->@*) {
199 0         0 my ($op, $addend) = $t->@*;
200 0         0 $retval = [$name_for->{"$op->@*"}, $retval, $addend];
201             }
202 2         5 return $retval;
203 1     1   8 };
204             }
205              
206             sub _identifier {
207 2     2   4 state $retval = sub ($rtext) {
  2         3  
  2         3  
208 2         4 state $alts = __alternator(_token(), _quoted_string());
209 2 50       14 my $rv = $alts->($rtext) or return;
210 2         7 return [resolve => $rv->[0]];
211 1     1   6 };
212             }
213              
214 3     3   8 sub _int { state $r = __alternator(_simple_int(), _random_int()) }
215              
216 1     1   4 sub _int_item { state $r = __alternator(_int_sr(), _int_range(), _int()) }
217              
218 2     2   8 sub _int_item_list { state $r = __lister(_int_item(), ',') }
219              
220 1     1   4 sub _int_range { state $r = _ranger((_int()) x 2) }
221              
222             sub _int_sr {
223 2     2   13 state $r = sub ($rtext) {
  2         18  
  2         4  
224 2         6 state $seq = __sequencer('#', _positive_int());
225 2 50       6 my $list = $seq->($rtext) or return;
226 2         6 my ($n) = ___promote_simple_ints($list->[1]);
227 2         9 return [range => 0 => [math_subtract => $n => 1]];
228             }
229 1     1   9 }
230              
231             sub _positive_int {
232 3     3   12 state $r = __alternator(_positive_simple_int(), _positive_random_int());
233              
234             }
235              
236             sub _positive_random_int {
237 2     2   4 state $r = sub ($rtext) {
  2         3  
  2         3  
238 2         7 state $ri = _random_int();
239 2         6 my $pos = pos $$rtext;
240 2 50       92 my $r = $ri->($rtext) or return;
241              
242 0         0 state $is_positive;
243 0         0 $is_positive ||= sub ($x) {
244 0 0       0 return $x > 0 unless ref $x;
245 0         0 for my $i (1 .. $#$x) { # skip 1st item in array
246 0 0       0 return unless $is_positive->($x->[$i]);
247             }
248 0         0 return 1; # all checks were good
249 0   0     0 };
250 0 0       0 return $r if $is_positive->($r);
251              
252 0         0 return;
253 1     1   9 };
254             }
255              
256 1     1   18 sub _positive_simple_int { state $r = __regexper(qr{([1-9][0-9]*)}) }
257              
258 1     1   17 sub _quoted_string { state $r = __regexper(qr{"((?:[^\\"]|\\.)*)"}) }
259              
260             sub _random_int {
261 8     8   14 state $r = sub ($rtext) {
  8         12  
  8         11  
262 8         15 state $seq = __sequencer('{', _int_item_list(), '}');
263 8 50       17 my $list = $seq->($rtext) or return;
264 0         0 return [random => ___promote_simple_ints($list->[1]->@*)];
265 2     2   21 };
266             }
267              
268 1     1   2 sub _ranger ($t1, $t2) {
  1         2  
  1         2  
  1         2  
269 1         3 my $ranger = __sequencer($t1, '..', $t2);
270 0     0   0 return sub ($rtext) {
  0         0  
  0         0  
271 0 0       0 my $range = $ranger->($rtext) or return;
272 0         0 return [range => ___promote_simple_ints($range->@[0, 2])];
273 1         5 };
274             }
275              
276 1     1   4 sub _shuffler { state $r = __exact('@', 'shuffle') }
277              
278 1     1   7 sub _simple_int { state $r = __regexper(qr{(0|-?[1-9][0-9]*)}) }
279              
280             sub _slicer {
281 6     6   10 state $r = sub ($rtext) {
  6         8  
  6         6  
282 6         11 state $slicer = __sequencer('[', _int_item_list(), ']');
283 6 100       13 my $slice = $slicer->($rtext) or return;
284 2         6 return [slice => ___promote_simple_ints($slice->[1]->@*)];
285 1     1   7 };
286             }
287              
288 1     1   4 sub _sorter { state $r = __exact('!', 'sort') }
289              
290             sub _sslicer {
291 6     6   10 state $r = sub ($rtext) {
  6         7  
  6         9  
292 6         11 state $catcher = _int();
293 6 50       12 my $catched = $catcher->($rtext) or return;
294 0         0 my ($n) = ___promote_simple_ints($catched);
295 0         0 return [slice => [range => 0 => [math_subtract => $n => 1]]];
296 1     1   16 };
297             }
298              
299 1     1   6 sub _token { state $r = __regexper(qr{([a-zA-Z]\w*)}) }
300              
301              
302              
303             ########################################################################
304             # Convenience functions
305 0     0   0 sub ___mult ($atom, $op, $n) {
  0         0  
  0         0  
  0         0  
  0         0  
306 0         0 state $name_for = {'*' => 'repeat', 'x' => 'replicate'};
307 0         0 return [$name_for->{"$op->@*"}, $atom, ___promote_simple_ints($n)];
308             }
309              
310 4     4   6 sub ___promote_simple_ints (@list) {
  4         8  
  4         5  
311 4 100       10 map {($_->@* <= 1) ? ($_->@*) : $_} @list;
  4         21  
312             }
313              
314 0     0     sub ___log ($rtext, $prefix = '') {
  0            
  0            
  0            
315 0   0       my $pos = pos($$rtext) // 0;
316 0           my $rest = substr $$rtext, $pos;
317             }
318              
319             1;